[scalapack] 02/03: New upstream version 2.0.2
Drew Parsons
dparsons at moszumanska.debian.org
Fri Jul 7 15:58:04 UTC 2017
This is an automated email from the git hooks/post-receive script.
dparsons pushed a commit to branch experimental
in repository scalapack.
commit 81f71b936ba02b309d87089fe8ce01baa6d3022a
Author: Drew Parsons <dparsons at debian.org>
Date: Fri Jul 7 23:51:56 2017 +0800
New upstream version 2.0.2
---
BLACS/CMakeLists.txt | 4 +
BLACS/INSTALL/CMakeLists.txt | 4 +
BLACS/INSTALL/Cintface.c | 21 +
BLACS/INSTALL/Fintface.f | 8 +
BLACS/INSTALL/Makefile_install | 42 +
BLACS/INSTALL/README | 27 +
BLACS/INSTALL/cmpi_sane.c | 71 +
BLACS/INSTALL/fmpi_sane.f | 72 +
BLACS/INSTALL/mpif.h | 85 +
BLACS/INSTALL/size.c | 7 +
BLACS/INSTALL/syserrors.c | 27 +
BLACS/INSTALL/tc_UseMpich.c | 25 +
BLACS/INSTALL/tc_cCsameF77.c | 38 +
BLACS/INSTALL/tc_fCsameF77.f | 44 +
BLACS/Makefile | 11 +
BLACS/SRC/BI_Arecv.c | 35 +
BLACS/SRC/BI_ArgCheck.c | 108 +
BLACS/SRC/BI_Asend.c | 28 +
BLACS/SRC/BI_BeComb.c | 102 +
BLACS/SRC/BI_BlacsAbort.c | 9 +
BLACS/SRC/BI_BlacsErr.c | 33 +
BLACS/SRC/BI_BlacsWarn.c | 25 +
BLACS/SRC/BI_BuffIsFree.c | 64 +
BLACS/SRC/BI_ContxtNum.c | 17 +
BLACS/SRC/BI_EmergencyBuff.c | 50 +
BLACS/SRC/BI_GetBuff.c | 76 +
BLACS/SRC/BI_GetMpiGeType.c | 24 +
BLACS/SRC/BI_GetMpiTrType.c | 123 +
BLACS/SRC/BI_GlobalVars.c | 14 +
BLACS/SRC/BI_HypBR.c | 21 +
BLACS/SRC/BI_HypBS.c | 18 +
BLACS/SRC/BI_IdringBR.c | 14 +
BLACS/SRC/BI_IdringBS.c | 13 +
BLACS/SRC/BI_MpathBR.c | 49 +
BLACS/SRC/BI_MpathBS.c | 50 +
BLACS/SRC/BI_MringComb.c | 84 +
BLACS/SRC/BI_Pack.c | 51 +
BLACS/SRC/BI_Rsend.c | 9 +
BLACS/SRC/BI_Srecv.c | 22 +
BLACS/SRC/BI_SringBR.c | 28 +
BLACS/SRC/BI_SringBS.c | 13 +
BLACS/SRC/BI_Ssend.c | 7 +
BLACS/SRC/BI_TransDist.c | 58 +
BLACS/SRC/BI_TransUserComm.c | 16 +
BLACS/SRC/BI_TreeBR.c | 39 +
BLACS/SRC/BI_TreeBS.c | 59 +
BLACS/SRC/BI_TreeComb.c | 156 +
BLACS/SRC/BI_Unpack.c | 16 +
BLACS/SRC/BI_UpdateBuffs.c | 57 +
BLACS/SRC/BI_cMPI_amn.c | 9 +
BLACS/SRC/BI_cMPI_amn2.c | 6 +
BLACS/SRC/BI_cMPI_amx.c | 9 +
BLACS/SRC/BI_cMPI_amx2.c | 6 +
BLACS/SRC/BI_cMPI_sum.c | 6 +
BLACS/SRC/BI_cvvamn.c | 34 +
BLACS/SRC/BI_cvvamn2.c | 37 +
BLACS/SRC/BI_cvvamx.c | 34 +
BLACS/SRC/BI_cvvamx2.c | 37 +
BLACS/SRC/BI_cvvsum.c | 8 +
BLACS/SRC/BI_dMPI_amn.c | 9 +
BLACS/SRC/BI_dMPI_amn2.c | 6 +
BLACS/SRC/BI_dMPI_amx.c | 9 +
BLACS/SRC/BI_dMPI_amx2.c | 6 +
BLACS/SRC/BI_dmvcopy.c | 27 +
BLACS/SRC/BI_dvmcopy.c | 28 +
BLACS/SRC/BI_dvvamn.c | 32 +
BLACS/SRC/BI_dvvamn2.c | 14 +
BLACS/SRC/BI_dvvamx.c | 32 +
BLACS/SRC/BI_dvvamx2.c | 14 +
BLACS/SRC/BI_dvvsum.c | 7 +
BLACS/SRC/BI_iMPI_amn.c | 9 +
BLACS/SRC/BI_iMPI_amn2.c | 6 +
BLACS/SRC/BI_iMPI_amx.c | 9 +
BLACS/SRC/BI_iMPI_amx2.c | 6 +
BLACS/SRC/BI_imvcopy.c | 27 +
BLACS/SRC/BI_ivmcopy.c | 28 +
BLACS/SRC/BI_ivvamn.c | 32 +
BLACS/SRC/BI_ivvamn2.c | 15 +
BLACS/SRC/BI_ivvamx.c | 32 +
BLACS/SRC/BI_ivvamx2.c | 14 +
BLACS/SRC/BI_ivvsum.c | 7 +
BLACS/SRC/BI_sMPI_amn.c | 9 +
BLACS/SRC/BI_sMPI_amn2.c | 6 +
BLACS/SRC/BI_sMPI_amx.c | 9 +
BLACS/SRC/BI_sMPI_amx2.c | 6 +
BLACS/SRC/BI_smvcopy.c | 27 +
BLACS/SRC/BI_svmcopy.c | 28 +
BLACS/SRC/BI_svvamn.c | 32 +
BLACS/SRC/BI_svvamn2.c | 14 +
BLACS/SRC/BI_svvamx.c | 32 +
BLACS/SRC/BI_svvamx2.c | 14 +
BLACS/SRC/BI_svvsum.c | 7 +
BLACS/SRC/BI_zMPI_amn.c | 9 +
BLACS/SRC/BI_zMPI_amn2.c | 6 +
BLACS/SRC/BI_zMPI_amx.c | 9 +
BLACS/SRC/BI_zMPI_amx2.c | 6 +
BLACS/SRC/BI_zMPI_sum.c | 6 +
BLACS/SRC/BI_zvvamn.c | 34 +
BLACS/SRC/BI_zvvamn2.c | 37 +
BLACS/SRC/BI_zvvamx.c | 34 +
BLACS/SRC/BI_zvvamx2.c | 37 +
BLACS/SRC/BI_zvvsum.c | 8 +
BLACS/SRC/Bconfig.h | 106 +
BLACS/SRC/Bdef.h | 527 +
BLACS/SRC/CMakeLists.txt | 84 +
BLACS/SRC/Makefile | 93 +
BLACS/SRC/blacs2sys_.c | 30 +
BLACS/SRC/blacs_abort_.c | 20 +
BLACS/SRC/blacs_barr_.c | 28 +
BLACS/SRC/blacs_exit_.c | 45 +
BLACS/SRC/blacs_free_.c | 24 +
BLACS/SRC/blacs_get_.c | 69 +
BLACS/SRC/blacs_grid_.c | 32 +
BLACS/SRC/blacs_info_.c | 32 +
BLACS/SRC/blacs_init_.c | 38 +
BLACS/SRC/blacs_map_.c | 140 +
BLACS/SRC/blacs_pcoord_.c | 17 +
BLACS/SRC/blacs_pinfo_.c | 27 +
BLACS/SRC/blacs_pnum_.c | 16 +
BLACS/SRC/blacs_set_.c | 67 +
BLACS/SRC/blacs_setup_.c | 15 +
BLACS/SRC/cgamn2d_.c | 373 +
BLACS/SRC/cgamx2d_.c | 373 +
BLACS/SRC/cgebr2d_.c | 226 +
BLACS/SRC/cgebs2d_.c | 195 +
BLACS/SRC/cgerv2d_.c | 82 +
BLACS/SRC/cgesd2d_.c | 95 +
BLACS/SRC/cgsum2d_.c | 238 +
BLACS/SRC/ctrbr2d_.c | 224 +
BLACS/SRC/ctrbs2d_.c | 206 +
BLACS/SRC/ctrrv2d_.c | 101 +
BLACS/SRC/ctrsd2d_.c | 113 +
BLACS/SRC/dcputime00_.c | 10 +
BLACS/SRC/dgamn2d_.c | 373 +
BLACS/SRC/dgamx2d_.c | 373 +
BLACS/SRC/dgebr2d_.c | 226 +
BLACS/SRC/dgebs2d_.c | 195 +
BLACS/SRC/dgerv2d_.c | 82 +
BLACS/SRC/dgesd2d_.c | 96 +
BLACS/SRC/dgsum2d_.c | 235 +
BLACS/SRC/dtrbr2d_.c | 224 +
BLACS/SRC/dtrbs2d_.c | 206 +
BLACS/SRC/dtrrv2d_.c | 101 +
BLACS/SRC/dtrsd2d_.c | 113 +
BLACS/SRC/dwalltime00_.c | 10 +
BLACS/SRC/free_handle_.c | 50 +
BLACS/SRC/igamn2d_.c | 370 +
BLACS/SRC/igamx2d_.c | 370 +
BLACS/SRC/igebr2d_.c | 226 +
BLACS/SRC/igebs2d_.c | 194 +
BLACS/SRC/igerv2d_.c | 82 +
BLACS/SRC/igesd2d_.c | 95 +
BLACS/SRC/igsum2d_.c | 234 +
BLACS/SRC/itrbr2d_.c | 224 +
BLACS/SRC/itrbs2d_.c | 206 +
BLACS/SRC/itrrv2d_.c | 101 +
BLACS/SRC/itrsd2d_.c | 113 +
BLACS/SRC/kbrid_.c | 29 +
BLACS/SRC/kbsid_.c | 29 +
BLACS/SRC/krecvid_.c | 10 +
BLACS/SRC/ksendid_.c | 10 +
BLACS/SRC/sgamn2d_.c | 373 +
BLACS/SRC/sgamx2d_.c | 373 +
BLACS/SRC/sgebr2d_.c | 226 +
BLACS/SRC/sgebs2d_.c | 195 +
BLACS/SRC/sgerv2d_.c | 82 +
BLACS/SRC/sgesd2d_.c | 95 +
BLACS/SRC/sgsum2d_.c | 235 +
BLACS/SRC/src-C.c.in | 2 +
BLACS/SRC/strbr2d_.c | 224 +
BLACS/SRC/strbs2d_.c | 206 +
BLACS/SRC/strrv2d_.c | 101 +
BLACS/SRC/strsd2d_.c | 113 +
BLACS/SRC/sys2blacs_.c | 55 +
BLACS/SRC/zgamn2d_.c | 373 +
BLACS/SRC/zgamx2d_.c | 373 +
BLACS/SRC/zgebr2d_.c | 226 +
BLACS/SRC/zgebs2d_.c | 195 +
BLACS/SRC/zgerv2d_.c | 82 +
BLACS/SRC/zgesd2d_.c | 95 +
BLACS/SRC/zgsum2d_.c | 240 +
BLACS/SRC/ztrbr2d_.c | 224 +
BLACS/SRC/ztrbs2d_.c | 206 +
BLACS/SRC/ztrrv2d_.c | 101 +
BLACS/SRC/ztrsd2d_.c | 113 +
BLACS/TESTING/CMakeLists.txt | 49 +
BLACS/TESTING/Cbt.c | 973 ++
BLACS/TESTING/Cbt.h | 19 +
BLACS/TESTING/Makefile | 48 +
BLACS/TESTING/README | 11 +
BLACS/TESTING/blacstest.f | 21722 ++++++++++++++++++++++++++++++
BLACS/TESTING/bsbr.dat | 18 +
BLACS/TESTING/bt.dat | 10 +
BLACS/TESTING/btprim.f | 377 +
BLACS/TESTING/comb.dat | 20 +
BLACS/TESTING/runtest.cmake | 24 +
BLACS/TESTING/sdrv.dat | 16 +
BLACS/TESTING/tools.f | 2087 +++
CMAKE/CTestCustom.cmake.in | 42 +
CMAKE/CheckBLACSCompilerFlags.cmake | 90 +
CMAKE/FortranMangling.cmake | 67 +
CMAKE/scalapack-config-build.cmake.in | 1 +
CMAKE/scalapack-config-install.cmake.in | 2 +
CMAKE/scalapack-config-version.cmake.in | 8 +
CMakeLists.txt | 311 +
CTestConfig.cmake | 13 +
EXAMPLE/Makefile | 53 +-
INSTALL/SLmake.ALPHA | 103 -
INSTALL/SLmake.HPPA | 103 -
INSTALL/SLmake.I860 | 102 -
INSTALL/SLmake.IRIX64 | 106 -
INSTALL/SLmake.LINUX | 103 -
INSTALL/SLmake.O2K | 104 -
INSTALL/SLmake.PCA | 104 -
INSTALL/SLmake.PGON | 102 -
INSTALL/SLmake.POWER2 | 103 -
INSTALL/SLmake.POWER3 | 103 -
INSTALL/SLmake.RS6K | 103 -
INSTALL/SLmake.SP2 | 102 -
INSTALL/SLmake.SUN4SOL2 | 106 -
INSTALL/SLmake.SUNMP | 105 -
INSTALL/SLmake.SX4 | 103 -
INSTALL/SLmake.T3D | 115 -
INSTALL/SLmake.T3E | 114 -
INSTALL/SLmake.pghpf.SUN4SOL2 | 103 -
INSTALL/scalapack_install.pdf | Bin 248214 -> 0 bytes
INSTALL/scalapack_install.ps | 7357 ----------
LICENSE | 48 +
LOG-SUMMARY | 719 -
Makefile | 54 +-
PBLAS/CMakeLists.txt | 3 +
PBLAS/SRC/CMakeLists.txt | 67 +
PBLAS/SRC/Makefile | 50 +-
PBLAS/SRC/PBBLAS/CMakeLists.txt | 14 +
PBLAS/SRC/PBBLAS/Makefile | 30 +-
PBLAS/SRC/PBtools.h | 20 +-
PBLAS/SRC/PTOOLS/CMakeLists.txt | 36 +
PBLAS/SRC/PTOOLS/Makefile | 44 +-
PBLAS/SRC/PTZBLAS/CMakeLists.txt | 48 +
PBLAS/SRC/PTZBLAS/Makefile | 40 +-
PBLAS/SRC/PTZBLAS/csyr.f | 1 +
PBLAS/SRC/PTZBLAS/csyr2.f | 4 +
PBLAS/SRC/PTZBLAS/zsyr.f | 1 +
PBLAS/SRC/PTZBLAS/zsyr2.f | 4 +
PBLAS/SRC/pctrsm_.c | 9 +
PBLAS/SRC/pdtrsm_.c | 9 +
PBLAS/SRC/pstrsm_.c | 10 +
PBLAS/SRC/pztrsm_.c | 10 +
PBLAS/TESTING/CMakeLists.txt | 78 +
PBLAS/TESTING/Makefile | 168 +-
PBLAS/TESTING/PB_Cabort.c | 158 -
PBLAS/TESTING/PB_Cwarn.c | 164 -
PBLAS/TESTING/pcblas1tst.f | 22 +-
PBLAS/TESTING/pcblas2tst.f | 20 +-
PBLAS/TESTING/pcblas3tst.f | 22 +-
PBLAS/TESTING/pcblastst.f | 2 +
PBLAS/TESTING/pdblas1tst.f | 20 +-
PBLAS/TESTING/pdblas2tst.f | 20 +-
PBLAS/TESTING/pdblas3tst.f | 22 +-
PBLAS/TESTING/pdblastst.f | 1 +
PBLAS/TESTING/psblas1tst.f | 20 +-
PBLAS/TESTING/psblas2tst.f | 20 +-
PBLAS/TESTING/psblas3tst.f | 20 +-
PBLAS/TESTING/psblastst.f | 2 +
PBLAS/TESTING/pzblas1tst.f | 22 +-
PBLAS/TESTING/pzblas2tst.f | 20 +-
PBLAS/TESTING/pzblas3tst.f | 22 +-
PBLAS/TESTING/pzblastst.f | 2 +
PBLAS/TIMING/CMakeLists.txt | 78 +
PBLAS/TIMING/Makefile | 164 +-
PBLAS/TIMING/PB_Cabort.c | 158 -
PBLAS/TIMING/PB_Cwarn.c | 164 -
PBLAS/TIMING/pcblas1tim.f | 22 +-
PBLAS/TIMING/pcblas2tim.f | 20 +-
PBLAS/TIMING/pcblas3tim.f | 22 +-
PBLAS/TIMING/pdblas1tim.f | 20 +-
PBLAS/TIMING/pdblas2tim.f | 20 +-
PBLAS/TIMING/pdblas3tim.f | 20 +-
PBLAS/TIMING/psblas1tim.f | 20 +-
PBLAS/TIMING/psblas2tim.f | 20 +-
PBLAS/TIMING/psblas3tim.f | 20 +-
PBLAS/TIMING/pzblas1tim.f | 22 +-
PBLAS/TIMING/pzblas2tim.f | 20 +-
PBLAS/TIMING/pzblas3tim.f | 22 +-
README | 111 +-
REDIST/CMakeLists.txt | 2 +
REDIST/SRC/CMakeLists.txt | 20 +
REDIST/SRC/Makefile | 58 +-
REDIST/TESTING/CMakeLists.txt | 41 +
REDIST/TESTING/Makefile | 95 +-
SLmake.inc | 145 -
SLmake.inc.example | 60 +
SRC/CMakeLists.txt | 148 +
SRC/Makefile | 70 +-
SRC/bdlaapp.f | 167 +
SRC/bdlaexc.f | 367 +
SRC/bdtrexc.f | 564 +
SRC/bslaapp.f | 167 +
SRC/bslaexc.f | 367 +
SRC/bstrexc.f | 564 +
SRC/cdbtf2.f | 3 +
SRC/cdbtrf.f | 3 +
SRC/cdttrf.f | 3 +
SRC/cdttrsv.f | 3 +
SRC/clamov.c | 11 +
SRC/cpttrsv.f | 3 +
SRC/ddbtf2.f | 3 +
SRC/ddbtrf.f | 3 +
SRC/ddttrf.f | 3 +
SRC/ddttrsv.f | 3 +
SRC/dlamov.c | 11 +
SRC/dlaqr6.f | 861 ++
SRC/dlar1va.f | 423 +
SRC/dlaref.f | 100 +-
SRC/dlarrb2.f | 662 +
SRC/dlarrd2.f | 678 +
SRC/dlarre2.f | 764 ++
SRC/dlarre2a.f | 774 ++
SRC/dlarrf2.f | 354 +
SRC/dlarrv2.f | 1166 ++
SRC/dpttrsv.f | 3 +
SRC/dstegr2.f | 522 +
SRC/dstegr2a.f | 465 +
SRC/dstegr2b.f | 345 +
SRC/lamov.h | 104 +
SRC/pblas.h | 22 +
SRC/pcdbtrf.f | 21 +-
SRC/pcdbtrsv.f | 19 +-
SRC/pcdttrf.f | 11 +-
SRC/pcdttrsv.f | 11 +-
SRC/pcgbtrf.f | 25 +-
SRC/pcgbtrs.f | 21 +-
SRC/pcgecon.f | 4 +-
SRC/pcgels.f | 6 +-
SRC/pcheev.f | 18 +-
SRC/pcheevr.f | 1219 ++
SRC/pcheevx.f | 3 +
SRC/pchettrd.f | 13 +-
SRC/pclacp2.f | 25 +-
SRC/pclarfb.f | 21 +-
SRC/pclarzb.f | 15 +-
SRC/pclascl.f | 42 +-
SRC/pcpbtrf.f | 21 +-
SRC/pcpbtrsv.f | 19 +-
SRC/pcpttrf.f | 2 +-
SRC/pcpttrsv.f | 2 +-
SRC/pcunmrq.f | 22 +-
SRC/pddbtrf.f | 25 +-
SRC/pddbtrsv.f | 17 +-
SRC/pdgbtrf.f | 21 +-
SRC/pdgbtrs.f | 21 +-
SRC/pdgebal.f | 443 +
SRC/pdgecon.f | 4 +-
SRC/pdgehrd.f | 3 +-
SRC/pdgels.f | 6 +-
SRC/pdhseqr.f | 682 +
SRC/pdlabad.f | 1 +
SRC/pdlacp2.f | 25 +-
SRC/pdlacp3.f | 22 +-
SRC/pdlahqr.f | 111 +-
SRC/pdlaiect.c | 27 +-
SRC/pdlamch.f | 1 +
SRC/pdlamve.f | 205 +
SRC/pdlaqr0.f | 929 ++
SRC/{pdlahqr.f => pdlaqr1.f} | 561 +-
SRC/pdlaqr2.f | 671 +
SRC/pdlaqr3.f | 1154 ++
SRC/pdlaqr4.f | 633 +
SRC/pdlaqr5.f | 2275 ++++
SRC/pdlarfb.f | 21 +-
SRC/pdlarzb.f | 15 +-
SRC/pdlascl.f | 42 +-
SRC/pdlasmsub.f | 20 +-
SRC/pdlasrt.f | 11 +-
SRC/pdormrq.f | 22 +-
SRC/pdpbtrf.f | 19 +-
SRC/pdpbtrsv.f | 17 +-
SRC/pdrot.f | 442 +
SRC/pdsyev.f | 5 +-
SRC/pdsyevr.f | 1167 ++
SRC/pdsyevx.f | 3 +
SRC/pdsyttrd.f | 13 +-
SRC/pdtrord.f | 3454 +++++
SRC/pdtrsen.f | 709 +
SRC/pilaenvx.f | 649 +
SRC/pilaver.f | 32 +
SRC/piparmq.f | 304 +
SRC/pjlaenv.f | 1 +
SRC/pmpcol.f | 109 +
SRC/pmpim2.f | 76 +
SRC/psdbtrf.f | 25 +-
SRC/psdbtrsv.f | 17 +-
SRC/psgbtrf.f | 21 +-
SRC/psgbtrs.f | 21 +-
SRC/psgebal.f | 443 +
SRC/psgecon.f | 4 +-
SRC/psgehrd.f | 15 +-
SRC/psgels.f | 6 +-
SRC/pshseqr.f | 682 +
SRC/pslabad.f | 1 +
SRC/pslacp2.f | 25 +-
SRC/pslacp3.f | 32 +-
SRC/pslahqr.f | 121 +-
SRC/pslaiect.c | 20 +-
SRC/pslamch.f | 1 +
SRC/pslamve.f | 205 +
SRC/pslaqr0.f | 929 ++
SRC/{pslahqr.f => pslaqr1.f} | 571 +-
SRC/pslaqr2.f | 671 +
SRC/pslaqr3.f | 1156 ++
SRC/pslaqr4.f | 633 +
SRC/pslaqr5.f | 2275 ++++
SRC/pslarfb.f | 21 +-
SRC/pslarzb.f | 8 +-
SRC/pslascl.f | 42 +-
SRC/pslasmsub.f | 28 +-
SRC/pslasrt.f | 11 +-
SRC/psormrq.f | 22 +-
SRC/pspbtrf.f | 19 +-
SRC/pspbtrsv.f | 17 +-
SRC/psrot.f | 442 +
SRC/pssyev.f | 5 +-
SRC/pssyevr.f | 1167 ++
SRC/pssyevx.f | 3 +
SRC/pssyttrd.f | 13 +-
SRC/pstrord.f | 3454 +++++
SRC/pstrsen.f | 709 +
SRC/pzdbtrf.f | 21 +-
SRC/pzdbtrsv.f | 19 +-
SRC/pzdttrf.f | 11 +-
SRC/pzdttrsv.f | 11 +-
SRC/pzgbtrf.f | 25 +-
SRC/pzgbtrs.f | 21 +-
SRC/pzgecon.f | 4 +-
SRC/pzgels.f | 6 +-
SRC/pzheev.f | 18 +-
SRC/pzheevr.f | 1219 ++
SRC/pzheevx.f | 3 +
SRC/pzhettrd.f | 13 +-
SRC/pzlacp2.f | 25 +-
SRC/pzlarfb.f | 21 +-
SRC/pzlarzb.f | 15 +-
SRC/pzlascl.f | 42 +-
SRC/pzpbtrf.f | 21 +-
SRC/pzpbtrsv.f | 19 +-
SRC/pzpttrf.f | 11 +-
SRC/pzpttrsv.f | 11 +-
SRC/pzunmrq.f | 22 +-
SRC/sdbtf2.f | 3 +
SRC/sdbtrf.f | 3 +
SRC/sdttrf.f | 3 +
SRC/sdttrsv.f | 3 +
SRC/slamov.c | 11 +
SRC/slaqr6.f | 861 ++
SRC/slar1va.f | 423 +
SRC/slaref.f | 109 +-
SRC/slarrb2.f | 662 +
SRC/slarrd2.f | 678 +
SRC/slarre2.f | 764 ++
SRC/slarre2a.f | 774 ++
SRC/slarrf2.f | 354 +
SRC/slarrv2.f | 1166 ++
SRC/spttrsv.f | 3 +
SRC/sstegr2.f | 522 +
SRC/sstegr2a.f | 465 +
SRC/sstegr2b.f | 345 +
SRC/zdbtf2.f | 3 +
SRC/zdbtrf.f | 3 +
SRC/zdttrf.f | 3 +
SRC/zdttrsv.f | 3 +
SRC/zlamov.c | 11 +
SRC/zpttrsv.f | 3 +
TESTING/CMakeLists.txt | 110 +
TESTING/EIG/CMakeLists.txt | 99 +
TESTING/EIG/Makefile | 416 +-
TESTING/EIG/pcgseptst.f | 5 +
TESTING/EIG/pclasizeheevr.f | 188 +
TESTING/EIG/pclasizesepr.f | 167 +
TESTING/EIG/pcsepchk.f | 9 +-
TESTING/EIG/pcseprdriver.f | 260 +
TESTING/EIG/pcseprreq.f | 227 +
TESTING/EIG/pcseprsubtst.f | 827 ++
TESTING/EIG/pcseprtst.f | 823 ++
TESTING/EIG/pcseptst.f | 4 +
TESTING/EIG/pdgseptst.f | 4 +
TESTING/EIG/pdhseqrdriver.f | 564 +
TESTING/EIG/pdlasizesepr.f | 143 +
TESTING/EIG/pdlasizesyevr.f | 188 +
TESTING/EIG/pdmatgen2.f | 702 +
TESTING/EIG/pdsepchk.f | 9 +-
TESTING/EIG/pdsepinfo.f | 1 +
TESTING/EIG/pdseprdriver.f | 260 +
TESTING/EIG/pdseprreq.f | 220 +
TESTING/EIG/pdseprsubtst.f | 802 ++
TESTING/EIG/pdseprtst.f | 801 ++
TESTING/EIG/pdseptst.f | 4 +
TESTING/EIG/pdsvdtst.f | 2 +-
TESTING/EIG/psgseptst.f | 4 +
TESTING/EIG/pshseqrdriver.f | 565 +
TESTING/EIG/pslasizesepr.f | 143 +
TESTING/EIG/pslasizesyevr.f | 188 +
TESTING/EIG/psmatgen2.f | 702 +
TESTING/EIG/pssepchk.f | 9 +-
TESTING/EIG/pssepinfo.f | 3 +
TESTING/EIG/psseprdriver.f | 260 +
TESTING/EIG/psseprreq.f | 220 +
TESTING/EIG/psseprsubtst.f | 802 ++
TESTING/EIG/psseprtst.f | 801 ++
TESTING/EIG/psseptst.f | 5 +
TESTING/EIG/pssvdtst.f | 2 +-
TESTING/EIG/pzgseptst.f | 4 +
TESTING/EIG/pzlasizeheevr.f | 188 +
TESTING/EIG/pzlasizesepr.f | 167 +
TESTING/EIG/pzsdpsubtst.f | 4 +-
TESTING/EIG/pzsepchk.f | 9 +-
TESTING/EIG/pzseprdriver.f | 260 +
TESTING/EIG/pzseprreq.f | 227 +
TESTING/EIG/pzseprsubtst.f | 828 ++
TESTING/EIG/pzseprtst.f | 823 ++
TESTING/EIG/pzseptst.f | 4 +
TESTING/EIG/xpjlaenv.f | 1 +
TESTING/LIN/CMakeLists.txt | 112 +
TESTING/LIN/Makefile | 499 +-
TESTING/LIN/pcdbmv1.f | 2 +-
TESTING/LIN/pcgbmv1.f | 2 +-
TESTING/LIN/pcludriver.f | 2 +-
TESTING/LIN/pcpbmv1.f | 2 +-
TESTING/LIN/pcqrt16.f | 1 +
TESTING/LIN/pddbmv1.f | 2 +-
TESTING/LIN/pdgbmv1.f | 2 +-
TESTING/LIN/pdludriver.f | 2 +-
TESTING/LIN/pdpbmv1.f | 2 +-
TESTING/LIN/pdqrt16.f | 1 +
TESTING/LIN/psdbmv1.f | 2 +-
TESTING/LIN/psgbmv1.f | 2 +-
TESTING/LIN/pspbmv1.f | 2 +-
TESTING/LIN/psqrt16.f | 1 +
TESTING/LIN/pzdbmv1.f | 2 +-
TESTING/LIN/pzgbmv1.f | 2 +-
TESTING/LIN/pzludriver.f | 2 +-
TESTING/LIN/pzpbmv1.f | 2 +-
TESTING/LIN/pzqrt16.f | 1 +
TESTING/QR.dat | 2 +-
TESTING/SEPR.dat | 161 +
TOOLS/CMakeLists.txt | 44 +
TOOLS/LAPACK/CMakeLists.txt | 16 +
TOOLS/LAPACK/Makefile | 36 +-
TOOLS/LAPACK/clarnd.f | 2 +
TOOLS/LAPACK/clatms.f | 3 +
TOOLS/LAPACK/dlarnd.f | 2 +
TOOLS/LAPACK/dlarot.f | 2 +
TOOLS/LAPACK/dlatms.f | 2 +
TOOLS/LAPACK/icmax1.f | 96 -
TOOLS/LAPACK/izmax1.f | 96 -
TOOLS/LAPACK/slarnd.f | 2 +
TOOLS/LAPACK/slarot.f | 2 +
TOOLS/LAPACK/slatms.f | 2 +
TOOLS/LAPACK/zlarnd.f | 2 +
TOOLS/LAPACK/zlatms.f | 3 +
TOOLS/Makefile | 42 +-
TOOLS/desc_convert.f | 10 +
TOOLS/pccol2row.f | 4 +-
TOOLS/pcrow2col.f | 2 +
TOOLS/pctreecomb.f | 2 +
TOOLS/pdcol2row.f | 4 +
TOOLS/pdrow2col.f | 5 +
TOOLS/pdtreecomb.f | 2 +
TOOLS/picol2row.f | 4 +
TOOLS/pirow2col.f | 5 +
TOOLS/pitreecomb.f | 2 +
TOOLS/pscol2row.f | 5 +
TOOLS/pslawrite.f | 2 +-
TOOLS/psrow2col.f | 5 +
TOOLS/pstreecomb.f | 1 +
TOOLS/pzcol2row.f | 2 +
TOOLS/pzlawrite.f | 2 +-
TOOLS/pzrow2col.f | 2 +
TOOLS/pztreecomb.f | 2 +
scalapack.pc.in | 9 +
scalapack_build.cmake | 224 +
580 files changed, 103794 insertions(+), 13718 deletions(-)
diff --git a/BLACS/CMakeLists.txt b/BLACS/CMakeLists.txt
new file mode 100644
index 0000000..18058e2
--- /dev/null
+++ b/BLACS/CMakeLists.txt
@@ -0,0 +1,4 @@
+add_subdirectory(SRC)
+if(BUILD_TESTING)
+ add_subdirectory(TESTING)
+endif(BUILD_TESTING)
diff --git a/BLACS/INSTALL/CMakeLists.txt b/BLACS/INSTALL/CMakeLists.txt
new file mode 100644
index 0000000..f1f3253
--- /dev/null
+++ b/BLACS/INSTALL/CMakeLists.txt
@@ -0,0 +1,4 @@
+cmake_minimum_required(VERSION 2.8)
+project(INSTALL C Fortran)
+
+add_executable(xintface Fintface.f Cintface.c)
diff --git a/BLACS/INSTALL/Cintface.c b/BLACS/INSTALL/Cintface.c
new file mode 100644
index 0000000..7d48096
--- /dev/null
+++ b/BLACS/INSTALL/Cintface.c
@@ -0,0 +1,21 @@
+#include <stdio.h>
+
+void c_intface_(int *i)
+{
+ fprintf(stdout, "Add_\n");
+}
+
+void c_intface(int *i)
+{
+ fprintf(stdout, "NoChange\n");
+}
+
+void c_intface__(int *i)
+{
+ fprintf(stdout, "f77IsF2C\n");
+}
+
+void C_INTFACE(int *i)
+{
+ fprintf(stdout, "UpCase\n");
+}
diff --git a/BLACS/INSTALL/Fintface.f b/BLACS/INSTALL/Fintface.f
new file mode 100644
index 0000000..a74724f
--- /dev/null
+++ b/BLACS/INSTALL/Fintface.f
@@ -0,0 +1,8 @@
+ program intface
+ external c_intface
+ integer i
+
+ call c_intface(i)
+
+ stop
+ end
diff --git a/BLACS/INSTALL/Makefile_install b/BLACS/INSTALL/Makefile_install
new file mode 100644
index 0000000..5ca8eb1
--- /dev/null
+++ b/BLACS/INSTALL/Makefile_install
@@ -0,0 +1,42 @@
+include ../../SLmake.inc
+
+help :
+ @ echo " "
+ @ echo " "
+ @ echo "You need to specify which INSTALL executable to build."
+ @ echo "General choices are: xsize, xintface, xsyserrors"
+ @ echo "MPI specific choices are: xsyserrors, xtc_CsameF77, xtc_UseMpich,"
+ @ echo " xcmpi_sane, xfmpi_sane"
+ @ echo " "
+ @ echo "Here is a brief explanation of each of these routines: "
+ cat README
+
+xsize : size.o
+ $(CCLOADER) $(CCLOADFLAGS) -o $@ size.o
+
+xintface : Fintface.o Cintface.o
+ $(FCLOADER) $(FCLOADFLAGS) -o $@ Fintface.o Cintface.o
+
+xsyserrors : syserrors.o
+ $(CCLOADER) $(CCLOADFLAGS) -o $@ syserrors.o
+
+xtc_CsameFC : tc_fCsameF77.o tc_cCsameF77.o
+ $(FCLOADER) $(FCLOADFLAGS) -o $@ tc_fCsameF77.o tc_cCsameF77.o
+
+xtc_UseMpich : tc_UseMpich.o
+ $(CCLOADER) $(CCLOADFLAGS) -o $@ tc_UseMpich.o
+
+xcmpi_sane : cmpi_sane.o
+ $(CCLOADER) $(CCLOADFLAGS) -o $@ cmpi_sane.o
+
+xfmpi_sane : mpif.h fmpi_sane.o
+ $(FCLOADER) $(FCLOADFLAGS) -o $@ fmpi_sane.o
+
+clean:
+ rm -f size.o Fintface.o Cintface.o syserrors.o transcomm.o \
+ mpi_sane.o fmpi_sane.o tc_UseMpich.o tc_fCsameF77.o tc_cCsameF77.o
+
+.f.o: ; $(FC) -c $(FCFLAGS) $*.f
+
+.c.o:
+ $(CC) -c $(CCFLAGS) $(CDEFS) $<
diff --git a/BLACS/INSTALL/README b/BLACS/INSTALL/README
new file mode 100644
index 0000000..cff55e8
--- /dev/null
+++ b/BLACS/INSTALL/README
@@ -0,0 +1,27 @@
+These routines help to configure the BLACS and its tester during installation.
+See the paper "Installing and testing the BLACS" for details.
+
+
+xintface will tell you the correct setting for Bmake.inc's INTFACE macro.
+
+xsize prints out the correct sizes for various data types, which are hardwired
+in btprim_PVM.c ibtsizeof.
+
+============================ MPI SPECIFIC ROUTINES ============================
+xsyserrors indicates the correct setting for Bmake.inc's SYSERRORS macro.
+
+xcmpi_sane will give you a sanity test to see if the most basic MPI program
+will run on your system using the C interface to MPI.
+
+xfmpi_sane will give you a sanity test to see if the most basic MPI program
+will run on your system using the Fortran77 interface to MPI.
+
+ ***** FINDING THE CORRECT TRANSCOMM SETTING *****
+The remaining routines exist in order to allow the user to find the correct
+setting for Bmake.inc's TRANSCOMM macro. THESE ROUTINES USE HEURISTICS, AND
+THUS MAY BE INCORRECT.
+
+First make and run xtc_CsameF77. If this reports back not to set TRANSCOMM
+to -DCSameF77 or does not complete, make and run xtc_UseMpich. If this fails to
+compile or does not tell you what to set TRANSCOMM to, you must leave TRANSCOMM
+blank.
diff --git a/BLACS/INSTALL/cmpi_sane.c b/BLACS/INSTALL/cmpi_sane.c
new file mode 100644
index 0000000..fbef5e0
--- /dev/null
+++ b/BLACS/INSTALL/cmpi_sane.c
@@ -0,0 +1,71 @@
+#include <stdio.h>
+#include "mpi.h"
+/*
+ * Increase/decrease this value to test if a process of a particular size can
+ * be spawned to a particular machine
+ */
+#define WASTE_SIZE 100
+#define NPROC 4
+main(int narg, char **args)
+/*
+ * This program checks to make sure that you can run a basic program on your
+ * machine using MPI. Can increase WASTE_SIZE if you think size of executable
+ * may be causing launching problems.
+ */
+{
+ int i, Iam, Np;
+ int irank[NPROC];
+ double WasteOfSpace[WASTE_SIZE];
+ MPI_Comm mcom;
+ MPI_Group wgrp, mgrp;
+ MPI_Status stat;
+
+ MPI_Init(&narg, &args);
+ MPI_Comm_size(MPI_COMM_WORLD, &Np);
+ if (Np < NPROC)
+ {
+ fprintf(stderr, "Not enough processes to run sanity check; need %d, but I've only got %d\n", NPROC, Np);
+ MPI_Abort(MPI_COMM_WORLD, -1);
+ }
+
+ for (i=0; i != WASTE_SIZE; i++) WasteOfSpace[i] = 0.0; /* page in Waste */
+/*
+ * Form context with NPROC members
+ */
+ for (i=0; i != NPROC; i++) irank[i] = i;
+ MPI_Comm_group(MPI_COMM_WORLD, &wgrp);
+ MPI_Group_incl(wgrp, NPROC, irank, &mgrp);
+ MPI_Comm_create(MPI_COMM_WORLD, mgrp, &mcom);
+ MPI_Group_free(&mgrp);
+/*
+ * Everyone in new communicator sends a message to his neighbor
+ */
+ if (mcom != MPI_COMM_NULL)
+ {
+ MPI_Comm_rank(mcom, &Iam);
+/*
+ * Odd nodes receive first, so we don't hang if MPI_Send is globally blocking
+ */
+ if (Iam % 2)
+ {
+ MPI_Recv(&i, 1, MPI_INT, (NPROC+Iam-1)%NPROC, 0, mcom, &stat);
+ MPI_Send(&Iam, 1, MPI_INT, (Iam+1)%NPROC, 0, mcom);
+ }
+ else
+ {
+ MPI_Send(&Iam, 1, MPI_INT, (Iam+1)%NPROC, 0, mcom);
+ MPI_Recv(&i, 1, MPI_INT, (NPROC+Iam-1)%NPROC, 0, mcom, &stat);
+ }
+/*
+ * Make sure we've received the right information
+ */
+ if (i != (NPROC+Iam-1)%NPROC)
+ {
+ fprintf(stderr, "Communication does not seem to work properly!!\n");
+ MPI_Abort(MPI_COMM_WORLD, -1);
+ }
+ }
+ fprintf(stdout, "%d: C MPI sanity test passed\n", Iam);
+ MPI_Finalize();
+ exit(0);
+}
diff --git a/BLACS/INSTALL/fmpi_sane.f b/BLACS/INSTALL/fmpi_sane.f
new file mode 100644
index 0000000..523745a
--- /dev/null
+++ b/BLACS/INSTALL/fmpi_sane.f
@@ -0,0 +1,72 @@
+ program fmpi_sane
+*
+* This program checks to make sure that you can run a basic program
+* on your machine using the Fortran77 interface to MPI.
+* Can increase parameter wastesz, if you think size of executable
+* is causing launching problem.
+*
+ include 'mpif.h'
+ integer nproc, wastesz
+ parameter (nproc = 4)
+ parameter (wastesz = 100)
+ integer i, Iam, Np, ierr
+ integer mcom, wgrp, mgrp
+ integer irank(nproc), stat(MPI_STATUS_SIZE)
+ double precision WasteSpc(wastesz)
+
+ call mpi_init(ierr)
+ call mpi_comm_size(MPI_COMM_WORLD, Np, ierr)
+ if (Np .lt. nproc) then
+ print*,'Not enough processes to run sanity check'
+ call mpi_abort(MPI_COMM_WORLD, -1, ierr)
+ end if
+*
+* Access all of WasteSpc
+*
+ do 10 i = 1, wastesz
+ WasteSpc(i) = 0.0D0
+10 continue
+*
+* Form context with NPROC members
+*
+ do 20 i = 1, nproc
+ irank(i) = i - 1
+20 continue
+ call mpi_comm_group(MPI_COMM_WORLD, wgrp, ierr)
+ call mpi_group_incl(wgrp, nproc, irank, mgrp, ierr)
+ call mpi_comm_create(MPI_COMM_WORLD, mgrp, mcom, ierr)
+ call mpi_group_free(mgrp, ierr)
+*
+* Everyone in new communicator sends a message to his neighbor
+*
+ if (mcom .ne. MPI_COMM_NULL) then
+ call mpi_comm_rank(mcom, Iam, ierr)
+*
+* Odd nodes receive first, so we don't hang if MPI_Send is
+* globally blocking
+*
+ if (mod(Iam, 2) .ne. 0) then
+ call mpi_recv(i, 1, MPI_INTEGER, MOD(nproc+Iam-1, nproc),
+ & 0, mcom, stat, ierr)
+ call mpi_send(Iam, 1, MPI_INTEGER, MOD(Iam+1, nproc),
+ & 0, mcom, ierr)
+ else
+ call mpi_send(Iam, 1, MPI_INTEGER, MOD(Iam+1, nproc),
+ & 0, mcom, ierr)
+ call mpi_recv(i, 1, MPI_INTEGER, MOD(nproc+Iam-1, nproc),
+ & 0, mcom, stat, ierr)
+ end if
+*
+* Make sure we've received the right information
+*
+ if (i .ne. MOD(nproc+Iam-1, nproc)) then
+ print*,'Communication does not seem to work properly!!'
+ call mpi_abort(MPI_COMM_WORLD, -1, ierr)
+ end if
+ end if
+
+ print*,Iam,' F77 MPI sanity test passed.'
+ call mpi_finalize(ierr)
+
+ stop
+ end
diff --git a/BLACS/INSTALL/mpif.h b/BLACS/INSTALL/mpif.h
new file mode 100644
index 0000000..d602b45
--- /dev/null
+++ b/BLACS/INSTALL/mpif.h
@@ -0,0 +1,85 @@
+! -*- fortran -*-
+!
+! Copyright (c) 2004-2006 The Trustees of Indiana University and Indiana
+! University Research and Technology
+! Corporation. All rights reserved.
+! Copyright (c) 2004-2005 The University of Tennessee and The University
+! of Tennessee Research Foundation. All rights
+! reserved.
+! Copyright (c) 2004-2005 High Performance Computing Center Stuttgart,
+! University of Stuttgart. All rights reserved.
+! Copyright (c) 2004-2005 The Regents of the University of California.
+! All rights reserved.
+! Copyright (c) 2006-2007 Cisco Systems, Inc. All rights reserved.
+! $COPYRIGHT$
+!
+! Additional copyrights may follow
+!
+! $HEADER$
+!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! WARNING WARNING WARNING WARNING WARNING WARNING WARNING WARNING WARNING
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!
+! Do ***not*** copy this file to the directory where your Fortran
+! fortran application is compiled unless it is absolutely necessary! Most
+! modern Fortran compilers now support the -I command line flag, which
+! tells the compiler where to find .h files (specifically, this one). For
+! example:
+!
+! shell$ mpif77 foo.f -o foo -I$OMPI_HOME/include
+!
+! will probably do the trick (assuming that you have set OMPI_HOME
+! properly).
+!
+! That being said, OMPI's "mpif77" wrapper compiler should
+! automatically include the -I option for you. The following command
+! should be equivalent to the command listed above:
+!
+! shell$ mpif77 foo.f -o foo
+!
+! You should not copy this file to your local directory because it is
+! possible that this file will be changed between versions of Open MPI.
+! Indeed, this mpif.h is incompatible with the mpif.f of other
+! implementations of MPI. Using this mpif.h with other implementations
+! of MPI, or with other versions of Open MPI will result in undefined
+! behavior (to include incorrect results, segmentation faults,
+! unexplainable "hanging" in your application, etc.). Always use the
+! -I command line option instead (or let mpif77 do it for you).
+!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! WARNING WARNING WARNING WARNING WARNING WARNING WARNING WARNING WARNING
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+!
+! Include the back-end file that has the bulk of the MPI Fortran
+! interface.
+!
+
+ include 'mpif-common.h'
+
+!
+! These "external" statements are specific to the MPI F77 interface
+! (and are toxic to the MPI F90 interface), and are therefore in the
+! MPI F77-specific header file (i.e., this one).
+!
+ external MPI_NULL_COPY_FN, MPI_NULL_DELETE_FN
+ external MPI_COMM_NULL_COPY_FN, MPI_COMM_NULL_DELETE_FN
+ external MPI_TYPE_NULL_COPY_FN, MPI_TYPE_NULL_DELETE_FN
+ external MPI_DUP_FN, MPI_COMM_DUP_FN, MPI_TYPE_DUP_FN
+ external MPI_WIN_NULL_COPY_FN
+ external MPI_WIN_NULL_DELETE_FN
+ external MPI_WIN_DUP_FN
+! Note that MPI_CONVERSION_FN_NULL is a "constant" (it is only ever
+! checked for comparison; it is never invoked), but it is passed as
+! a function pointer (to MPI_REGISTER_DATAREP) and therefore must be
+! the same size/type. It is therefore external'ed here, and not
+! defined with an integer value in mpif-common.h.
+ external MPI_CONVERSION_FN_NULL
+
+!
+! double precision functions
+!
+ external MPI_WTIME, MPI_WTICK , PMPI_WTICK, PMPI_WTIME
+ double precision MPI_WTIME, MPI_WTICK , PMPI_WTICK, PMPI_WTIME
+
diff --git a/BLACS/INSTALL/size.c b/BLACS/INSTALL/size.c
new file mode 100644
index 0000000..7fb2b40
--- /dev/null
+++ b/BLACS/INSTALL/size.c
@@ -0,0 +1,7 @@
+#include <stdio.h>
+main()
+{
+ printf("ISIZE=%d\nSSIZE=%d\nDSIZE=%d\nCSIZE=%d\nZSIZE=%d\n",
+ sizeof(int), sizeof(float), sizeof(double),
+ 2*sizeof(float), 2*sizeof(double));
+}
diff --git a/BLACS/INSTALL/syserrors.c b/BLACS/INSTALL/syserrors.c
new file mode 100644
index 0000000..26a2e28
--- /dev/null
+++ b/BLACS/INSTALL/syserrors.c
@@ -0,0 +1,27 @@
+#include <stdio.h>
+#include <mpi.h>
+
+main(int nargs, char **args)
+{
+ MPI_Datatype Dtype, Dt;
+ int i, j, ierr;
+
+ MPI_Init(&nargs, &args);
+ printf( "If this routine does not complete, you should set SYSERRORS = -DZeroByteTypeBug.\n");
+
+ i = 0;
+ j = 1;
+ ierr = MPI_Type_indexed(1, &i, &j, MPI_INT, &Dtype);
+ if (ierr == MPI_SUCCESS)
+ {
+ MPI_Type_commit(&Dtype);
+ ierr = MPI_Type_vector(0, 1, 1, MPI_INT, &Dt);
+ if (ierr != MPI_SUCCESS)
+ printf("MPI_Type_vector returned %d, set SYSERRORS = -DZeroByteTypeBug\n", ierr);
+ else MPI_Type_commit(&Dt);
+ }
+ else printf("MPI_Type_commit returned %d, set SYSERRORS = -DZeroByteTypeBug\n", ierr);
+ if (ierr == MPI_SUCCESS) printf("Leave SYSERRORS blank for this system.\n");
+
+ MPI_Finalize();
+}
diff --git a/BLACS/INSTALL/tc_UseMpich.c b/BLACS/INSTALL/tc_UseMpich.c
new file mode 100644
index 0000000..08c3090
--- /dev/null
+++ b/BLACS/INSTALL/tc_UseMpich.c
@@ -0,0 +1,25 @@
+#include <stdio.h>
+#include <mpi.h>
+main()
+{
+ MPI_Comm ccomm;
+ int fcomm;
+ extern void *MPIR_ToPointer();
+ extern int MPIR_FromPointer();
+ extern void *MPIR_RmPointer();
+
+ if (sizeof(int) < sizeof(int*))
+ {
+ fcomm = MPIR_FromPointer(MPI_COMM_WORLD);
+ ccomm = (MPI_Comm) MPIR_ToPointer(fcomm);
+ if (ccomm == MPI_COMM_WORLD)
+ printf("Set TRANSCOMM = -DUseMpich -DPOINTER_64_BITS=1\n");
+ else
+ printf("Do _NOT_ set TRANSCOMM = -DUseMpich -DPOINTER_64_BITS=1\n");
+ }
+ else
+ {
+ printf("Compile and run xtc_CsameF77 for correct TRANSCOMM setting.\n");
+ printf("If xtc_CsameF77 fails, leave TRANSCOMM blank.\n");
+ }
+}
diff --git a/BLACS/INSTALL/tc_cCsameF77.c b/BLACS/INSTALL/tc_cCsameF77.c
new file mode 100644
index 0000000..5fb6add
--- /dev/null
+++ b/BLACS/INSTALL/tc_cCsameF77.c
@@ -0,0 +1,38 @@
+#include <mpi.h>
+
+int Ccommcheck(int F77World, int f77comm)
+{
+ int Np, Iam, i, OK=1;
+
+ if (sizeof(int) != sizeof(MPI_Comm)) OK=0;
+ else if ((MPI_Comm) F77World != MPI_COMM_WORLD) OK=0;
+ else
+ {
+ MPI_Comm_rank(MPI_COMM_WORLD, &Iam);
+ if (Iam > 1) OK = ((MPI_Comm) f77comm == MPI_COMM_NULL);
+ else
+ {
+ i = MPI_Comm_size((MPI_Comm) f77comm, &Np);
+ if (i != MPI_SUCCESS) OK = 0;
+ else if (Np != 2) OK = 0;
+ }
+ }
+ MPI_Allreduce(&OK, &i, 1, MPI_INT, MPI_MIN, MPI_COMM_WORLD);
+ return(i);
+}
+
+/*
+ * Fortran interfaces
+ */
+int CCOMMCHECK(int *F77World, int *f77comm)
+{
+ return(Ccommcheck(*F77World, *f77comm));
+}
+int ccommcheck_(int *F77World, int *f77comm)
+{
+ return(Ccommcheck(*F77World, *f77comm));
+}
+int ccommcheck(int *F77World, int *f77comm)
+{
+ return(Ccommcheck(*F77World, *f77comm));
+}
diff --git a/BLACS/INSTALL/tc_fCsameF77.f b/BLACS/INSTALL/tc_fCsameF77.f
new file mode 100644
index 0000000..81ecac8
--- /dev/null
+++ b/BLACS/INSTALL/tc_fCsameF77.f
@@ -0,0 +1,44 @@
+ program tctst
+ include 'mpif.h'
+ integer f77com, wgrp, f77grp, Iam, i, ierr
+ integer irank(2)
+ external Ccommcheck
+ integer Ccommcheck
+
+ call mpi_init(ierr)
+ call mpi_comm_size(MPI_COMM_WORLD, i, ierr)
+ call mpi_comm_rank(MPI_COMM_WORLD, Iam, ierr)
+ if (i .lt. 2) then
+ print*,'Need at least 2 processes to run test, aborting.'
+ else
+ if (Iam .eq. 0) then
+ print*,'If this routine does not complete successfully,'
+ print*,'Do _NOT_ set TRANSCOMM = -DCSameF77'
+ print*,' '
+ print*,' '
+ end if
+*
+* Form context with 2 members
+*
+ irank(1) = 0
+ irank(2) = 1
+ call mpi_comm_group(MPI_COMM_WORLD, wgrp, ierr)
+ call mpi_group_incl(wgrp, 2, irank, f77grp, ierr)
+ call mpi_comm_create(MPI_COMM_WORLD, f77grp, f77com, ierr)
+ call mpi_group_free(f77grp, ierr)
+
+ i = Ccommcheck(MPI_COMM_WORLD, f77com)
+ if (Iam .eq. 0) then
+ if (i .eq. 0) then
+ print*,'Do _NOT_ set TRANSCOMM = -DCSameF77'
+ else
+ print*,'Set TRANSCOMM = -DCSameF77'
+ end if
+ end if
+
+ if (f77grp .ne. MPI_COMM_NULL) call mpi_comm_free(f77com, ierr)
+ end if
+ call mpi_finalize(ierr)
+
+ stop
+ end
diff --git a/BLACS/Makefile b/BLACS/Makefile
new file mode 100644
index 0000000..58d1e81
--- /dev/null
+++ b/BLACS/Makefile
@@ -0,0 +1,11 @@
+all : lib tester
+
+clean:
+ ( cd TESTING ; make clean )
+ ( cd SRC ; make clean )
+
+tester :
+ ( cd TESTING ; make )
+
+lib :
+ ( cd SRC ; make )
diff --git a/BLACS/SRC/BI_Arecv.c b/BLACS/SRC/BI_Arecv.c
new file mode 100644
index 0000000..4b36a05
--- /dev/null
+++ b/BLACS/SRC/BI_Arecv.c
@@ -0,0 +1,35 @@
+#include "Bdef.h"
+
+void BI_Arecv(BLACSCONTEXT *ctxt, int src, int msgid, BLACBUFF *bp)
+{
+ int i, info, errclass;
+
+ info=MPI_Irecv(bp->Buff, bp->N, bp->dtype, src, msgid, ctxt->scp->comm,
+ &bp->Aops[bp->nAops]);
+ while(info != MPI_SUCCESS)
+ {
+ i=MPI_Error_class(info, &errclass);
+ if ( (errclass != MPI_ERR_UNKNOWN) && (errclass != MPI_ERR_OTHER) &&
+ (errclass != MPI_ERR_INTERN) )
+ {
+ Mmpierror(info, "MPI_Irecv", ctxt, __LINE__, __FILE__);
+ BI_BlacsErr(BI_ContxtNum(ctxt), __LINE__, __FILE__,
+ "MPI error %d on call to MPI_Irecv", info);
+ }
+#if (BlacsDebugLvl > 0)
+ else BI_BlacsWarn(BI_ContxtNum(ctxt), __LINE__, __FILE__,
+"MPI error %d assumed to mean out of non-blocking resources on call to MPI_Irecv",
+ info);
+#endif
+ info=MPI_Irecv(bp->Buff, bp->N, bp->dtype, src, msgid, ctxt->scp->comm,
+ &bp->Aops[bp->nAops]);
+ }
+ bp->nAops++;
+/*
+ * Signal if we need to use status to figure out true length of received message
+ * We only need do this if we are doing our own buffering
+ */
+#ifndef MpiBuffGood
+ if (bp->dtype == MPI_PACKED) bp->N = -bp->nAops;
+#endif
+}
diff --git a/BLACS/SRC/BI_ArgCheck.c b/BLACS/SRC/BI_ArgCheck.c
new file mode 100644
index 0000000..0c73b02
--- /dev/null
+++ b/BLACS/SRC/BI_ArgCheck.c
@@ -0,0 +1,108 @@
+#include "Bdef.h"
+
+
+void BI_ArgCheck(int ConTxt, int RoutType, char *routine, char scope,
+ char uplo, char diag, int m, int n, int lda, int nprocs,
+ int *prows, int *pcols)
+{
+#if (BlacsDebugLvl > 0)
+ char *srcdest;
+ int i=1, prow, pcol, Ng, nprow, npcol, myrow, mycol;
+ BLACSCONTEXT *ctxt;
+
+ MGetConTxt(ConTxt, ctxt);
+ Mgridinfo(ctxt, Ng, nprow, npcol, myrow, mycol);
+
+ if ( (scope != 'r') && (scope != 'c') && (scope != 'a') )
+ BI_BlacsErr(ConTxt, -1, routine, "Unknown scope, scope=%c", scope);
+ if ( (uplo != 'u') && (uplo != 'l') )
+ {
+ if (RoutType != RT_COMB)
+ BI_BlacsWarn(ConTxt, -1, routine,
+ "UPLO=%c, will be assumed to mean LOWER", uplo);
+ else i = 0; /* combine aux, for rect. matrix */
+ }
+ if ( (diag != 'u') && (diag != 'n') )
+ {
+ if (i) BI_BlacsWarn(ConTxt, -1, routine,
+ "DIAG=%c, will be assumed to mean NON-UNIT", diag);
+ }
+ if (m * n != 0)
+ {
+ if (m < 0)
+ BI_BlacsErr(ConTxt, -1, routine, "Illegal number of rows, M=%d", m);
+ if (n < 0)
+ BI_BlacsErr(ConTxt, -1, routine, "Illegal number of columns, N=%d", n);
+ if (lda < m)
+ BI_BlacsWarn(ConTxt, -1, routine,
+ "Illegal LDA, LDA=%d, M=%d; LDA assumed to be %d",
+ lda, m, m);
+ }
+
+ if ( (RoutType == RT_RV) || (RoutType == RT_BR) ) srcdest = "SRC";
+ else srcdest = "DEST";
+
+ if (RoutType == RT_SD)
+ {
+ if ( (nprocs > Ng) || (nprocs < 0) )
+ BI_BlacsErr(ConTxt, -1, routine,
+ "Trying to send to %d procs, but only %d in grid",
+ nprocs, Ng);
+ }
+
+ for (i=0; i < nprocs; i++)
+ {
+ prow = prows[i];
+ pcol = pcols[i];
+
+ if ( (prow < 0) || (prow >= nprow) )
+ {
+ if ( !((RoutType == RT_COMB) && (prow == -1)) )
+ BI_BlacsErr(ConTxt, -1, routine,
+ "R%s out of range; R%s=%d, NPROW=%d",
+ srcdest, srcdest, prow, nprow);
+ }
+ if ( (pcol < 0) || (pcol >= npcol) )
+ {
+ if ( !((RoutType == RT_COMB) && (prow == -1)) )
+ BI_BlacsErr(ConTxt, -1, routine,
+ "C%s out of range; C%s=%d, NPCOL=%d",
+ srcdest, srcdest, pcol, npcol);
+ }
+ if (RoutType == RT_SD) /* point to point send */
+ {
+ if ( (prow == myrow) && (pcol == mycol) )
+ BI_BlacsWarn(ConTxt, -1, routine, "Node sending message to itself");
+ }
+ else if (RoutType == RT_RV) /* point to point send */
+ {
+ if ( (prow == myrow) && (pcol == mycol) )
+ BI_BlacsWarn(ConTxt, -1, routine,
+ "Node recving message from itself");
+ }
+ else if (RoutType == RT_BR) /* broadcast/recv */
+ {
+ if ( (prow == myrow) && (pcol == mycol) )
+ BI_BlacsErr(ConTxt, -1, routine,
+ "Node tries to recv its own broadcast");
+
+ if (scope == 'r')
+ {
+ if (myrow != prow)
+ BI_BlacsWarn(ConTxt, -1, routine,
+ "Row broadcast: MYROW=%d, but RSRC=%d",
+ myrow, prow);
+ }
+ else if (scope == 'c')
+ {
+ if (mycol != pcol)
+ {
+ BI_BlacsErr(ConTxt, -1, routine,
+ "Column broadcast: MYCOL=%d, but CSRC=%d",
+ mycol, pcol);
+ }
+ }
+ }
+ }
+#endif
+}
diff --git a/BLACS/SRC/BI_Asend.c b/BLACS/SRC/BI_Asend.c
new file mode 100644
index 0000000..d74dd0f
--- /dev/null
+++ b/BLACS/SRC/BI_Asend.c
@@ -0,0 +1,28 @@
+#include "Bdef.h"
+
+void BI_Asend(BLACSCONTEXT *ctxt, int dest, int msgid, BLACBUFF *bp)
+{
+ int i, info, errclass;
+
+ info=MPI_Isend(bp->Buff, bp->N, bp->dtype, dest, msgid, ctxt->scp->comm,
+ &bp->Aops[bp->nAops]);
+ while(info != MPI_SUCCESS)
+ {
+ i=MPI_Error_class(info, &errclass);
+ if ( (errclass != MPI_ERR_UNKNOWN) && (errclass != MPI_ERR_OTHER) &&
+ (errclass != MPI_ERR_INTERN) )
+ {
+ Mmpierror(info, "MPI_Isend", ctxt, __LINE__, __FILE__);
+ BI_BlacsErr(BI_ContxtNum(ctxt), __LINE__, __FILE__,
+ "MPI error %d on call to MPI_Isend", info);
+ }
+#if (BlacsDebugLvl > 0)
+ else BI_BlacsWarn(BI_ContxtNum(ctxt), __LINE__, __FILE__,
+"MPI error %d assumed to mean out of non-blocking resources on call to MPI_Isend",
+ info);
+#endif
+ info=MPI_Isend(bp->Buff, bp->N, bp->dtype, dest, msgid, ctxt->scp->comm,
+ &bp->Aops[bp->nAops]);
+ }
+ bp->nAops++;
+}
diff --git a/BLACS/SRC/BI_BeComb.c b/BLACS/SRC/BI_BeComb.c
new file mode 100644
index 0000000..9afb537
--- /dev/null
+++ b/BLACS/SRC/BI_BeComb.c
@@ -0,0 +1,102 @@
+#include "Bdef.h"
+
+/*
+ * The bidirectional exchange topology (BE) is specialized for dealing with
+ * case where all nodes participating in the operation need to
+ * receive the answer. It works best when # of nodes is some even
+ * power of two. This topology is based on an algorithm presented by
+ * Robert van de Geijn, et al.
+ */
+void BI_BeComb(BLACSCONTEXT *ctxt, BLACBUFF *bp, BLACBUFF *bp2,
+ int N, VVFUNPTR Xvvop)
+/*
+ * -- V1.1ALPHA (test version) BLACS routine --
+ * University of Tennessee, October 1, 1995
+ * Written by Clint Whaley.
+ *
+ * Purpose
+ * =======
+ * Perform a element-by-element combine on vectors.
+ * The answer will be left on all participating processes. Since this method
+ * uses a hypercube communication pattern, the number of nodes participating
+ * in the operation must be a power of 2 for it to perform efficiently.
+ *
+ * Arguments
+ * =========
+ * CTXT (input) pointer to BLACSCONTEXT
+ * The BLACS context where operation is taking place.
+ *
+ * BP (input/output) pointer to BLACBUFF.
+ * BLACBUFF is a special data type used by the BLACS to control
+ * buffers and the asynchronous operations coming out of them.
+ * This BLACBUFF should have a buffer who's first N elements
+ * contain the data to be combined. Additional space may be
+ * required, depending upon what combine is being performed.
+ *
+ * BP2 (workspace) pointer to BLACBUFF.
+ * This BLACBUFF is used to receive information for combining with
+ * this process's information.
+ *
+ * N (input) int
+ * The number of elements in the vector to be combined.
+ *
+ * Xvvop (input) pointer to typed operation function
+ * Points to a typed function which performs the required operation
+ * (e.g. summation) on the two N-element vectors.
+ *
+ * ------------------------------------------------------------------------
+ */
+{
+ void BI_Ssend(BLACSCONTEXT *, int, int, BLACBUFF *);
+ void BI_Srecv(BLACSCONTEXT *, int, int, BLACBUFF *);
+ void BI_Rsend(BLACSCONTEXT *, int, int, BLACBUFF *);
+ void BI_Arecv(BLACSCONTEXT *, int, int, BLACBUFF *);
+ void BI_UpdateBuffs(BLACBUFF *);
+ BLACBUFF *BI_GetBuff(int);
+ int BI_BuffIsFree(BLACBUFF *, int);
+
+ int Np, Iam, dest, msgid, Rmsgid, np2, bit, ierr;
+ extern MPI_Status *BI_Stats;
+
+ Np = ctxt->scp->Np;
+ if (Np < 2) return;
+ Iam = ctxt->scp->Iam;
+ msgid = Mscopeid(ctxt);
+ Rmsgid = Mscopeid(ctxt);
+
+ for (np2=4; np2 < Np; np2 <<= 1);
+ if (np2 > Np) np2 >>= 1;
+
+ if (np2 != Np)
+ {
+ dest = (Iam ^ np2);
+ if (Iam >= np2) /* I'm node beyond power of 2 */
+ {
+ BI_Arecv(ctxt, dest, Rmsgid, bp);
+ BI_Ssend(ctxt, dest, msgid, bp);
+ BI_BuffIsFree(bp, 1);
+ }
+ else if (Iam < (Np^np2)) /* need to fan in contents of */
+ { /* non-power of 2 nodes */
+ BI_Srecv(ctxt, dest, msgid, bp2);
+ Xvvop(N, bp->Buff, bp2->Buff);
+ }
+ }
+
+ if (Iam < np2)
+ {
+ for (bit=1; (bit ^ np2); bit <<= 1)
+ {
+ dest = Iam ^ bit;
+ ierr=MPI_Sendrecv(bp->Buff, bp->N, bp->dtype, dest, msgid, bp2->Buff,
+ bp2->N, bp2->dtype, dest, msgid, ctxt->scp->comm,
+ BI_Stats);
+ Xvvop(N, bp->Buff, bp2->Buff);
+ }
+/*
+ * For nodes that are not part of the hypercube proper, we must
+ * send data back.
+ */
+ if (Iam < (Np^np2)) BI_Rsend(ctxt, (Iam ^ np2), Rmsgid, bp);
+ } /* end if (nodes inside power of 2) */
+}
diff --git a/BLACS/SRC/BI_BlacsAbort.c b/BLACS/SRC/BI_BlacsAbort.c
new file mode 100644
index 0000000..5282564
--- /dev/null
+++ b/BLACS/SRC/BI_BlacsAbort.c
@@ -0,0 +1,9 @@
+#include "Bdef.h"
+
+void BI_BlacsAbort(int ErrNo)
+{
+ int ierr;
+ fflush(stderr);
+ fflush(stdout);
+ ierr=MPI_Abort(MPI_COMM_WORLD, ErrNo);
+}
diff --git a/BLACS/SRC/BI_BlacsErr.c b/BLACS/SRC/BI_BlacsErr.c
new file mode 100644
index 0000000..785bb78
--- /dev/null
+++ b/BLACS/SRC/BI_BlacsErr.c
@@ -0,0 +1,33 @@
+#include "Bdef.h"
+
+void BI_BlacsErr(int ConTxt, int line, char *file, char *form, ...)
+{
+#ifdef __STDC__
+ void BI_BlacsAbort(int ErrNo);
+#else
+ void BI_BlacsAbort();
+#endif
+ extern int BI_Iam;
+ int myrow, mycol;
+ va_list argptr;
+ char cline[100];
+ BLACSCONTEXT *ctxt;
+
+ va_start(argptr, form);
+ vsprintf(cline, form, argptr);
+ va_end(argptr);
+
+ if (ConTxt > -1)
+ {
+ MGetConTxt(ConTxt, ctxt);
+ myrow = ctxt->cscp.Iam;
+ mycol = ctxt->rscp.Iam;
+ }
+ else myrow = mycol = -1;
+
+ fprintf(stderr,
+"BLACS ERROR '%s'\nfrom {%d,%d}, pnum=%d, Contxt=%d, on line %d of file '%s'.\n\n",
+ cline, myrow, mycol, BI_Iam, ConTxt, line, file);
+
+ BI_BlacsAbort(1);
+}
diff --git a/BLACS/SRC/BI_BlacsWarn.c b/BLACS/SRC/BI_BlacsWarn.c
new file mode 100644
index 0000000..a4c7aea
--- /dev/null
+++ b/BLACS/SRC/BI_BlacsWarn.c
@@ -0,0 +1,25 @@
+#include "Bdef.h"
+
+void BI_BlacsWarn(int ConTxt, int line, char *file, char *form, ...)
+{
+ extern int BI_Iam;
+ extern BLACSCONTEXT **BI_MyContxts;
+ int myrow, mycol;
+ va_list argptr;
+ char cline[100];
+
+ va_start(argptr, form);
+ vsprintf(cline, form, argptr);
+ va_end(argptr);
+
+ if (ConTxt > -1)
+ {
+ myrow = BI_MyContxts[ConTxt]->cscp.Iam;
+ mycol = BI_MyContxts[ConTxt]->rscp.Iam;
+ }
+ else myrow = mycol = -1;
+
+ fprintf(stderr,
+"BLACS WARNING '%s'\nfrom {%d,%d}, pnum=%d, Contxt=%d, on line %d of file '%s'.\n\n",
+ cline, myrow, mycol, BI_Iam, ConTxt, line, file);
+}
diff --git a/BLACS/SRC/BI_BuffIsFree.c b/BLACS/SRC/BI_BuffIsFree.c
new file mode 100644
index 0000000..5a07d6a
--- /dev/null
+++ b/BLACS/SRC/BI_BuffIsFree.c
@@ -0,0 +1,64 @@
+#include "Bdef.h"
+
+int BI_BuffIsFree(BLACBUFF *bp, int Wait)
+/*
+ * Check to see if buff is finished with async. operations. If Wait != 0,
+ * wait for all async. operations to complete.
+ */
+{
+ int i, info;
+ extern MPI_Status *BI_Stats;
+ extern int BI_Np;
+
+
+ if (!Wait)
+ {
+ info=MPI_Testall(bp->nAops, bp->Aops, &i, BI_Stats);
+ if (!i)
+ {
+/*
+ * If we are doing our own Packing, need to check true length of receive
+ */
+#ifndef MpiBuffGood
+/*
+ * If we have an outstanding receive, make sure that when it
+ * completes we correctly set bp->N, if required
+ */
+ if (bp->N < 0)
+ {
+ if (bp->Aops[-bp->N-1] == MPI_REQUEST_NULL)
+ {
+ info=MPI_Get_count(&BI_Stats[(-bp->N-1)*MPI_STATUS_SIZE],MPI_PACKED, &i);
+ if (i != MPI_UNDEFINED) bp->N = i;
+ else BI_BlacsWarn(-1, __LINE__, __FILE__,
+ "MPI_Get_count returned MPI_UNDEFINED.\n");
+ }
+ }
+#endif
+ return(0);
+ }
+ }
+ else
+ {
+ info=MPI_Waitall(bp->nAops, bp->Aops, BI_Stats);
+ }
+
+ bp->nAops = 0;
+/*
+ * If we are doing our own packing, need to check true length of receive
+ */
+#ifndef MpiBuffGood
+/*
+ * If we had an outstanding receive, make sure that we correctly set bp->N,
+ * if required
+ */
+ if (bp->N < 0)
+ {
+ info=MPI_Get_count(&BI_Stats[(-bp->N-1)*MPI_STATUS_SIZE],MPI_PACKED, &i);
+ if (i != MPI_UNDEFINED) bp->N = i;
+ else BI_BlacsWarn(-1, __LINE__, __FILE__,
+ "MPI_Get_count returned MPI_UNDEFINED.\n");
+ }
+#endif
+ return(1);
+}
diff --git a/BLACS/SRC/BI_ContxtNum.c b/BLACS/SRC/BI_ContxtNum.c
new file mode 100644
index 0000000..48f6a4c
--- /dev/null
+++ b/BLACS/SRC/BI_ContxtNum.c
@@ -0,0 +1,17 @@
+#include "Bdef.h"
+
+int BI_ContxtNum(BLACSCONTEXT *ctxt)
+/*
+ * Returns the integer ID of ctxt
+ */
+{
+ int i;
+ extern int BI_MaxNCtxt;
+ extern BLACSCONTEXT **BI_MyContxts;
+
+ if (ctxt == NULL) return(-1);
+ for (i=0; i < BI_MaxNCtxt; i++) if (BI_MyContxts[i] == ctxt) break;
+ if (i == BI_MaxNCtxt)
+ BI_BlacsErr(-1, -1, "BLACS INTERNAL ROUTINE", "illegal context");
+ return(i);
+}
diff --git a/BLACS/SRC/BI_EmergencyBuff.c b/BLACS/SRC/BI_EmergencyBuff.c
new file mode 100644
index 0000000..78d9777
--- /dev/null
+++ b/BLACS/SRC/BI_EmergencyBuff.c
@@ -0,0 +1,50 @@
+#include "Bdef.h"
+
+/***************************************************************************
+ * If there is insufficient space to allocate a needed buffer, this *
+ * routine is called. It moniters active buffers for the time defined by *
+ * the user-changeable macro value BUFWAIT. If in that time no active *
+ * buffer becomes inactive, a hang is assumed, and the grid is killed. *
+ ***************************************************************************/
+void BI_EmergencyBuff(int length)
+{
+ void BI_UpdateBuffs(BLACBUFF *);
+
+ char *cptr;
+ int i, j;
+ double Mwalltime(void);
+ double t1;
+ extern int BI_Np;
+ extern BLACBUFF *BI_ReadyB, *BI_ActiveQ;
+
+ j = sizeof(BLACBUFF);
+ if (j % sizeof(MPI_Request))
+ j += sizeof(MPI_Request) - j % sizeof(MPI_Request);
+ i = j + BI_Np*sizeof(MPI_Request);
+ if (i % BUFFALIGN) i += BUFFALIGN - i % BUFFALIGN;
+ t1 = Mwalltime();
+ while ( (BI_ActiveQ) && (Mwalltime() - t1 < BUFWAIT) && !(BI_ReadyB) )
+ {
+ BI_UpdateBuffs(NULL);
+ if (BI_ReadyB)
+ {
+ if (BI_ReadyB->Len < length)
+ {
+ free(BI_ReadyB);
+ cptr = malloc(length + i);
+ BI_ReadyB = (BLACBUFF *) cptr;
+ if (BI_ReadyB)
+ {
+ BI_ReadyB->nAops = 0;
+ BI_ReadyB->Aops = (MPI_Request *) &cptr[j];
+ BI_ReadyB->Buff = &cptr[i];
+ BI_ReadyB->Len = length;
+ }
+ }
+ }
+ }
+ if (BI_ReadyB == NULL)
+ {
+ BI_BlacsErr(-1, __LINE__, __FILE__, "BLACS out of buffer space");
+ }
+}
diff --git a/BLACS/SRC/BI_GetBuff.c b/BLACS/SRC/BI_GetBuff.c
new file mode 100644
index 0000000..e65f6f9
--- /dev/null
+++ b/BLACS/SRC/BI_GetBuff.c
@@ -0,0 +1,76 @@
+#include "Bdef.h"
+/***************************************************************************
+ * The mpi implements globally blocking sends. I.e., a send blocks until *
+ * the dest. node issues a recv. The BLACS assume locally-blocking sends.*
+ * Therefore, the BLACS must fake locally-blocking sends. To do this *
+ * requires an indeterminate number of buffers and the use of *
+ * non-blocking sends. However, it is very important that even though I *
+ * provide a dynamic number of buffers, that getting these buffers does *
+ * not take too long in the critical part of a send operation. *
+ * Therefore, the buffer management is broken into two routines. *
+ * *
+ * Inside the BLACS there are two states a buffer may be in. If the buff *
+ * is currently being used (for instance, an asynchronous send is coming *
+ * from it), it is classified as an ACTIVE buffer, and is on the active *
+ * buffer queue. Otherwise, a buffer is READY: it is not being used *
+ * and is available for the next buffer operation. *
+ * In order to avoid buffer proliferation, only one ready buffer is kept, *
+ * and as active buffers become inactive they either become the ready *
+ * buffer, or are freed. *
+ * *
+ * The first routine, BI_GetBuff, checks if the ready buffer is big enough *
+ * to fulfill the buffer request. If not, the present ready buffer is *
+ * is freed, and a new buffer of the required length is allocated. If *
+ * the buffer is of sufficent size already, no action is taken. *
+ * This routine is purposely very short, as it is called at the beginning *
+ * of each broadcast/send operation. All participating nodes *
+ * are waiting on the source node, so this routine must be very cheap. *
+ * *
+ * The second routine, BI_UpdateBuffs, moves the ready buffer to the active *
+ * buffer queue (if needed). It also checks the entire active buffer *
+ * queue to see if any have finished their operations. If so, they are *
+ * are either moved to the ready buff, or freed. This routine is called *
+ * AFTER the send/broadcast has been started, and thus I am free to make *
+ * it a little more complex. *
+ ***************************************************************************/
+
+BLACBUFF *BI_GetBuff(int length)
+{
+ void BI_EmergencyBuff(int length);
+
+ char *cptr;
+ int i, j;
+ extern int BI_Np;
+ extern BLACBUFF *BI_ReadyB;
+
+/*
+ * If ready buffer already exists, and is big enough, return it. Otherwise,
+ * free the buffer (if it exists) and get one of correct size
+ */
+ if (BI_ReadyB)
+ {
+ if (BI_ReadyB->Len >= length) return(BI_ReadyB);
+ else free(BI_ReadyB);
+ }
+/*
+ * Make sure all buffers aligned correctly
+ */
+ j = sizeof(BLACBUFF);
+ if (j % sizeof(MPI_Request))
+ j += sizeof(MPI_Request) - j % sizeof(MPI_Request);
+ i = j + BI_Np*sizeof(MPI_Request);
+ if (i % BUFFALIGN) i += BUFFALIGN - i % BUFFALIGN;
+ cptr = malloc(i + length);
+ BI_ReadyB = (BLACBUFF *) cptr;
+
+ if (BI_ReadyB != NULL)
+ {
+ BI_ReadyB->nAops = 0;
+ BI_ReadyB->Aops = (MPI_Request *) &cptr[j];
+ BI_ReadyB->Buff = &cptr[i];
+ BI_ReadyB->Len = length;
+ }
+ else BI_EmergencyBuff(length);
+
+ return(BI_ReadyB);
+}
diff --git a/BLACS/SRC/BI_GetMpiGeType.c b/BLACS/SRC/BI_GetMpiGeType.c
new file mode 100644
index 0000000..478e045
--- /dev/null
+++ b/BLACS/SRC/BI_GetMpiGeType.c
@@ -0,0 +1,24 @@
+#include "Bdef.h"
+MPI_Datatype BI_GetMpiGeType(BLACSCONTEXT *ctxt, int m, int n, int lda,
+ MPI_Datatype Dtype, int *N)
+{
+ int info;
+ MPI_Datatype GeType;
+
+/*
+ * Some versions of mpich and its derivitives cannot handle 0 byte typedefs,
+ * so we set type MPI_BYTE as a flag for a 0 byte message
+ */
+#ifdef ZeroByteTypeBug
+ if ( (m < 1) || (n < 1) )
+ {
+ *N = 0;
+ return (MPI_BYTE);
+ }
+#endif
+ *N = 1;
+ info=MPI_Type_vector(n, m, lda, Dtype, &GeType);
+ info=MPI_Type_commit(&GeType);
+
+ return(GeType);
+}
diff --git a/BLACS/SRC/BI_GetMpiTrType.c b/BLACS/SRC/BI_GetMpiTrType.c
new file mode 100644
index 0000000..602aef0
--- /dev/null
+++ b/BLACS/SRC/BI_GetMpiTrType.c
@@ -0,0 +1,123 @@
+#include "Bdef.h"
+
+
+MPI_Datatype BI_GetMpiTrType(BLACSCONTEXT *ctxt, char uplo, char diag,
+ int m, int n, int lda, MPI_Datatype Dtype,
+ int *N)
+{
+ BLACBUFF *BI_GetBuff(int);
+ MPI_Datatype TrType;
+ int info, start, i, k;
+ int *len, *disp;
+ BLACBUFF *bp;
+
+ if (diag == 'u') start = 1;
+ else start = 0;
+
+/*
+ * Some versions of mpich and its derivitives cannot handle 0 byte typedefs,
+ * so we set type MPI_BYTE as a flag for a 0 byte message
+ */
+#ifdef ZeroByteTypeBug
+ if (m > n) i = n * (m-n) + (n*n) - (n*n)/2 + n/2 - n*start;
+ else i = m * (n-m) + (m*m) - (m*m)/2 + m/2 - m*start;
+ if (i < 1)
+ {
+ *N = 0;
+ return (MPI_BYTE);
+ }
+#endif
+ *N = 1;
+
+/*
+ * Get space to hold the length and displacement values
+ */
+ bp = BI_GetBuff( 2 * n * sizeof(int) );
+ len = (int *) bp->Buff;
+ disp = (int *) &bp->Buff[n*sizeof(int)];
+
+ if (m > n)
+ {
+ if (uplo == 'u')
+ {
+ k = m - n + 1 - start;
+ for (i=0; i < n; i++)
+ {
+ len[i] = k + i;
+ disp[i] = i*lda;
+ }
+ }
+ else /* uplo = 'l' and m > n */
+ {
+ k = m - start;
+ lda++;
+ len[0] = k;
+ disp[0] = start;
+ for (i=1; i < n; i++)
+ {
+ len[i] = k - i;
+ disp[i] = disp[i-1] + lda;
+ }
+ }
+ }
+ else /* m <= n */
+ {
+ if (uplo == 'u')
+ {
+ k = 1 - start;
+ for (i=0; i < m; i++)
+ {
+ len[i] = i + k;
+ disp[i] = i*lda;
+ }
+ for (; i < n; i++)
+ {
+ len[i] = m;
+ disp[i] = i*lda;
+ }
+ }
+ else /* uplo = 'l' and m <= n */
+ {
+ k = n - m;
+ for (i=0; i < k; i++)
+ {
+ len[i] = m;
+ disp[i] = i*lda;
+ }
+ if (i < n)
+ {
+ k = n - start;
+ len[i] = k - i;
+ disp[i] = i*lda + start;
+ lda++;
+ for (i++; i < n; i++)
+ {
+ len[i] = k - i;
+ disp[i] = disp[i-1] + lda;
+ }
+ }
+ }
+ }
+#ifdef T3ETrError
+/*
+ * Get rid of 0-length segments to keep T3E happy
+ */
+ for (i=0; i < n; i++)
+ {
+ if (len[i] == 0)
+ {
+ for (k=i+1; k < n; k++)
+ {
+ len[k-1] = len[k];
+ disp[k-1] = disp[k];
+ }
+ if (n > 0) n--;
+ i--; /* check new entry for 0-byte */
+ }
+ }
+#endif
+
+ i=MPI_Type_indexed(n, len, disp, Dtype, &TrType);
+ i=MPI_Type_commit(&TrType);
+ return(TrType);
+}
diff --git a/BLACS/SRC/BI_GlobalVars.c b/BLACS/SRC/BI_GlobalVars.c
new file mode 100644
index 0000000..14d734b
--- /dev/null
+++ b/BLACS/SRC/BI_GlobalVars.c
@@ -0,0 +1,14 @@
+#include "Bdef.h"
+/*
+ * Define global variables
+ */
+int BI_MaxNCtxt=0; /* Number of context pointers allocated */
+int BI_MaxNSysCtxt=0; /* Number of system ctxt ptrs allocated */
+int BI_Iam, BI_Np=(-1); /* My pnum, and # of procs in system */
+BLACBUFF *BI_ReadyB=NULL; /* buffer that is ready for use */
+BLACBUFF *BI_ActiveQ=NULL; /* pointer to start of active buffer queue */
+BLACBUFF BI_AuxBuff;
+BLACSCONTEXT **BI_MyContxts=NULL; /* Array of pointers to my contexts */
+MPI_Comm *BI_SysContxts=NULL;
+int *BI_COMM_WORLD=NULL;
+MPI_Status *BI_Stats=NULL;
diff --git a/BLACS/SRC/BI_HypBR.c b/BLACS/SRC/BI_HypBR.c
new file mode 100644
index 0000000..7a3aee9
--- /dev/null
+++ b/BLACS/SRC/BI_HypBR.c
@@ -0,0 +1,21 @@
+#include "Bdef.h"
+
+int BI_HypBR(BLACSCONTEXT *ctxt, BLACBUFF *bp, SDRVPTR send, int src)
+{
+ void BI_Srecv(BLACSCONTEXT *, int, int, BLACBUFF *);
+ int relnode, bit, Np, Iam, msgid;
+
+ Np = ctxt->scp->Np;
+ Iam = ctxt->scp->Iam;
+ msgid = Mscopeid(ctxt);
+
+ for (bit=2; bit < Np; bit <<= 1);
+ if (bit^Np) return(NPOW2); /* not a power of 2 */
+ relnode = Iam ^ src;
+
+ BI_Srecv(ctxt, BANYNODE, msgid, bp);
+ for(bit=1; (bit^Np); bit <<= 1)
+ if (bit > relnode) send(ctxt, Iam^bit, msgid, bp);
+
+ return(0);
+}
diff --git a/BLACS/SRC/BI_HypBS.c b/BLACS/SRC/BI_HypBS.c
new file mode 100644
index 0000000..e175e43
--- /dev/null
+++ b/BLACS/SRC/BI_HypBS.c
@@ -0,0 +1,18 @@
+#include "Bdef.h"
+int BI_HypBS(BLACSCONTEXT *ctxt, BLACBUFF *bp, SDRVPTR send)
+{
+ int bit, Np, Iam, msgid;
+
+ Np = ctxt->scp->Np;
+ if (Np < 2) return(NORV);
+ Iam = ctxt->scp->Iam;
+ msgid = Mscopeid(ctxt);
+
+ for (bit=2; bit < Np; bit <<= 1);
+ if (bit^Np) return(NPOW2); /* not a power of 2 */
+
+ for(bit=1; (bit^Np); bit <<= 1)
+ send(ctxt, (Iam^bit), msgid, bp);
+
+ return(0); /* error-free return */
+}
diff --git a/BLACS/SRC/BI_IdringBR.c b/BLACS/SRC/BI_IdringBR.c
new file mode 100644
index 0000000..3ece4ad
--- /dev/null
+++ b/BLACS/SRC/BI_IdringBR.c
@@ -0,0 +1,14 @@
+#include "Bdef.h"
+
+void BI_IdringBR(BLACSCONTEXT *ctxt, BLACBUFF *bp, SDRVPTR send, int src, int step)
+{
+ void BI_Srecv(BLACSCONTEXT *, int, int, BLACBUFF *);
+ int Np, Iam, msgid, dest;
+
+ Np = ctxt->scp->Np;
+ Iam = ctxt->scp->Iam;
+ dest = (Np + Iam + step) % Np;
+ msgid = Mscopeid(ctxt);
+ BI_Srecv(ctxt, BANYNODE, msgid, bp);
+ if (dest != src) send(ctxt, dest, msgid, bp);
+}
diff --git a/BLACS/SRC/BI_IdringBS.c b/BLACS/SRC/BI_IdringBS.c
new file mode 100644
index 0000000..e334df4
--- /dev/null
+++ b/BLACS/SRC/BI_IdringBS.c
@@ -0,0 +1,13 @@
+#include "Bdef.h"
+
+void BI_IdringBS(BLACSCONTEXT *ctxt, BLACBUFF *bp, SDRVPTR send, int step)
+{
+ int Np, Iam, msgid;
+
+ Np = ctxt->scp->Np;
+ if (Np < 2) return;
+ Iam = ctxt->scp->Iam;
+ msgid = Mscopeid(ctxt);
+
+ send(ctxt, (Np+Iam+step)%Np, msgid, bp);
+}
diff --git a/BLACS/SRC/BI_MpathBR.c b/BLACS/SRC/BI_MpathBR.c
new file mode 100644
index 0000000..150602b
--- /dev/null
+++ b/BLACS/SRC/BI_MpathBR.c
@@ -0,0 +1,49 @@
+#include "Bdef.h"
+
+void BI_MpathBR(BLACSCONTEXT *ctxt, BLACBUFF *bp, SDRVPTR send, int src, int npaths)
+{
+ void BI_Arecv(BLACSCONTEXT *, int, int, BLACBUFF *);
+ int BI_BuffIsFree(BLACBUFF *, int);
+
+ int pathlen; /* the minimal length of each path */
+ int mydist; /* my distance from src */
+ int faredge; /* node at far end of path */
+ int lastlong; /* distance to node on end of last path with extra node */
+ int Np, Iam, msgid, Np_1, dest;
+
+ msgid = Mscopeid(ctxt);
+ BI_Arecv(ctxt, BANYNODE, msgid, bp);
+ Np = ctxt->scp->Np;
+ Iam = ctxt->scp->Iam;
+ Np_1 = Np - 1;
+ if (npaths == FULLCON) npaths = Np_1;
+
+ if (npaths > 0)
+ {
+ dest = (Iam+1) % Np;
+ mydist = (Np + Iam - src) % Np;
+ }
+ else
+ {
+ dest = (Np_1+Iam) % Np;
+ mydist = (Np + src - Iam) % Np;
+ npaths = -npaths;
+ }
+/*
+ * Make sure npaths is cool
+ */
+ if (npaths > Np_1) npaths = Np_1;
+
+ pathlen = Np_1 / npaths;
+ lastlong = (Np_1%npaths) * (pathlen+1);
+ if (lastlong)
+ {
+ if (mydist <= lastlong) faredge = ((mydist-1)/(pathlen+1)+1)*(pathlen+1);
+ else faredge = ((lastlong-1)/(pathlen+1)+1) * (pathlen+1)
+ + ((mydist-lastlong-1)/pathlen + 1) * pathlen;
+ }
+ else faredge = ((mydist-1)/pathlen + 1) * pathlen;
+
+ BI_BuffIsFree(bp, 1); /* wait for recv to complete */
+ if (mydist < faredge) send(ctxt, dest, msgid, bp);
+}
diff --git a/BLACS/SRC/BI_MpathBS.c b/BLACS/SRC/BI_MpathBS.c
new file mode 100644
index 0000000..f999107
--- /dev/null
+++ b/BLACS/SRC/BI_MpathBS.c
@@ -0,0 +1,50 @@
+#include "Bdef.h"
+
+void BI_MpathBS(BLACSCONTEXT *ctxt, BLACBUFF *bp, SDRVPTR send, int npaths)
+{
+ int pathlen; /* the length of each path */
+ int dist; /* the distance to the node closest to src on each path */
+ int pdest; /* part of dest calculation -- saves unneeded ops */
+ int lastlong; /* number of paths with extra node */
+ int Np, Iam, msgid, Np_1, dir;
+
+ Np = ctxt->scp->Np;
+ if (Np < 2) return;
+ Iam = ctxt->scp->Iam;
+ msgid = Mscopeid(ctxt);
+ Np_1 = Np - 1;
+ if (npaths == FULLCON) npaths = Np_1;
+
+ if (npaths > 0) /* paths are increasing rings */
+ {
+ pdest = Iam;
+ dir = 1;
+ }
+ else /* paths are decreasing rings */
+ {
+ pdest = Np + Iam;
+ dir = -1;
+ npaths = -npaths;
+ }
+/*
+ * Ensure npaths is correct
+ */
+ if (npaths > Np_1) npaths = Np_1;
+ pathlen = Np_1 / npaths;
+
+/*
+ * Loop over all long paths (paths with an extra node), if there are any
+ */
+ lastlong = (Np_1 % npaths) * (pathlen+1); /* last node in long ring */
+ for (dist=1; dist < lastlong; dist += pathlen+1)
+ send(ctxt, (pdest+dir*dist)%Np, msgid, bp);
+
+/*
+ * Loop over all normal length paths
+ */
+ while (dist < Np)
+ {
+ send(ctxt, (pdest+dir*dist)%Np, msgid, bp);
+ dist += pathlen;
+ }
+}
diff --git a/BLACS/SRC/BI_MringComb.c b/BLACS/SRC/BI_MringComb.c
new file mode 100644
index 0000000..5986574
--- /dev/null
+++ b/BLACS/SRC/BI_MringComb.c
@@ -0,0 +1,84 @@
+#include "Bdef.h"
+void BI_MringComb(BLACSCONTEXT *ctxt, BLACBUFF *bp, BLACBUFF *bp2,
+ int N, VVFUNPTR Xvvop, int dest, int nrings)
+{
+ void BI_Ssend(BLACSCONTEXT *, int, int, BLACBUFF *);
+ void BI_Srecv(BLACSCONTEXT *, int, int, BLACBUFF *);
+ void BI_MpathBS(BLACSCONTEXT *, BLACBUFF *, SDRVPTR, int);
+ void BI_MpathBR(BLACSCONTEXT *, BLACBUFF *, SDRVPTR, int, int);
+
+ int Np, Iam, msgid, i, inc, mysrc, mydest, Np_1;
+ int mydist, ringlen, myring;
+ int nearedge, faredge; /* edge closest and farthest from dest */
+ int REBS; /* Is result leave-on-all? */
+
+ Np = ctxt->scp->Np;
+ if (Np < 2) return;
+ Iam = ctxt->scp->Iam;
+ msgid = Mscopeid(ctxt);
+ if (REBS = (dest == -1)) dest = 0;
+
+ if (nrings > 0)
+ {
+ mydist = (Np + dest - Iam) % Np;
+ inc = 1;
+ }
+ else
+ {
+ mydist = (Np + Iam - dest) % Np;
+ inc = -1;
+ nrings = -nrings;
+ }
+ Np_1 = Np - 1;
+ if (nrings > Np_1) nrings = Np_1;
+
+/*
+ * If I'm not the destination
+ */
+ if (Iam != dest)
+ {
+ ringlen = Np_1 / nrings;
+ myring = (mydist-1) / ringlen;
+ if (myring >= nrings) myring = nrings - 1;
+ nearedge = (myring*ringlen) + 1;
+ faredge = nearedge + ringlen - 1;
+ if (myring == nrings-1) faredge += Np_1 % nrings;
+ if (mydist == nearedge) mydest = dest;
+ else mydest = (Np + Iam + inc) % Np;
+ if (mydist != faredge)
+ {
+ BI_Srecv(ctxt, (Np + Iam - inc) % Np, msgid, bp2);
+ Xvvop(N, bp->Buff, bp2->Buff);
+ }
+ BI_Ssend(ctxt, mydest, msgid, bp);
+ if (REBS) BI_MpathBR(ctxt, bp, BI_Ssend, dest, nrings);
+ }
+/*
+ * If I'm the destination process
+ */
+ else
+ {
+ if (!ctxt->TopsRepeat)
+ {
+ for(i=nrings; i; i--)
+ {
+ BI_Srecv(ctxt, BANYNODE, msgid, bp2);
+ Xvvop(N, bp->Buff, bp2->Buff);
+ }
+ }
+ else
+ {
+ ringlen = Np_1 / nrings;
+ if (inc == 1) mysrc = (Np + Iam - 1) % Np;
+ else mysrc = (Iam + 1) % Np;
+ for(i=nrings; i; i--)
+ {
+ BI_Srecv(ctxt, mysrc, msgid, bp2);
+ Xvvop(N, bp->Buff, bp2->Buff);
+ if (inc == 1) mysrc = (Np + mysrc - ringlen) % Np;
+ else mysrc = (mysrc + ringlen) % Np;
+ }
+ }
+ if (REBS) BI_MpathBS(ctxt, bp, BI_Ssend, nrings);
+ }
+} /* end BI_MringComb */
diff --git a/BLACS/SRC/BI_Pack.c b/BLACS/SRC/BI_Pack.c
new file mode 100644
index 0000000..751b694
--- /dev/null
+++ b/BLACS/SRC/BI_Pack.c
@@ -0,0 +1,51 @@
+#include "Bdef.h"
+BLACBUFF *BI_Pack(BLACSCONTEXT *ctxt,BVOID *A,BLACBUFF *bp,MPI_Datatype Dtype)
+{
+ BLACBUFF *BI_GetBuff(int);
+ int i, info, one=1;
+ MPI_Aint eltsiz;
+#ifdef ZeroByteTypeBug
+ char *cptr;
+ extern BLACBUFF BI_AuxBuff;
+ extern int BI_Np;
+#endif
+
+/*
+ * Some versions of mpich and its derivitives cannot handle 0 byte typedefs,
+ * so we have set MPI_BYTE as a flag for a 0 byte message
+ */
+#ifdef ZeroByteTypeBug
+ if (Dtype == MPI_BYTE)
+ {
+ info = sizeof(BLACBUFF);
+ if (info % sizeof(MPI_Request))
+ info += sizeof(MPI_Request) - info % sizeof(MPI_Request);
+ i = info + BI_Np*sizeof(MPI_Request);
+ if (i % BUFFALIGN) i += BUFFALIGN - i % BUFFALIGN;
+ cptr = malloc(i);
+ if (cptr)
+ {
+ bp = (BLACBUFF *) cptr;
+ bp->Len = bp->N = bp->nAops = 0;
+ bp->Aops = (MPI_Request *) &cptr[info];
+ bp->Buff = (char *) &bp->Len;
+ bp->dtype = MPI_BYTE;
+ return(bp);
+ }
+ else BI_BlacsErr(BI_ContxtNum(ctxt), __LINE__, __FILE__,
+ "Not enough memory to allocate 0 byte buffer\n");
+ }
+#endif
+ if (bp == NULL)
+ {
+ info=MPI_Pack_size(one, Dtype, ctxt->scp->comm, &i);
+ bp = BI_GetBuff(i);
+ }
+
+ i = 0;
+ info=MPI_Pack(A, one, Dtype, bp->Buff, bp->Len, &i, ctxt->scp->comm);
+ bp->dtype = MPI_PACKED;
+ bp->N = i;
+
+ return(bp);
+}
diff --git a/BLACS/SRC/BI_Rsend.c b/BLACS/SRC/BI_Rsend.c
new file mode 100644
index 0000000..d42c187
--- /dev/null
+++ b/BLACS/SRC/BI_Rsend.c
@@ -0,0 +1,9 @@
+#include "Bdef.h"
+
+
+void BI_Rsend(BLACSCONTEXT *ctxt, int dest, int msgid, BLACBUFF *bp)
+{
+ int info;
+
+ info=MPI_Rsend(bp->Buff, bp->N, bp->dtype, dest, msgid, ctxt->scp->comm);
+}
diff --git a/BLACS/SRC/BI_Srecv.c b/BLACS/SRC/BI_Srecv.c
new file mode 100644
index 0000000..27f9e80
--- /dev/null
+++ b/BLACS/SRC/BI_Srecv.c
@@ -0,0 +1,22 @@
+#include "Bdef.h"
+
+void BI_Srecv(BLACSCONTEXT *ctxt, int src, int msgid, BLACBUFF *bp)
+{
+ int i, info;
+ extern MPI_Status *BI_Stats;
+
+ info=MPI_Recv(bp->Buff, bp->N, bp->dtype, src, msgid, ctxt->scp->comm,BI_Stats);
+/*
+ * If we are doing our own buffering, need to determine the true length of
+ * the message just received
+ */
+#ifndef MpiBuffGood
+ if (bp->dtype == MPI_PACKED)
+ {
+ info=MPI_Get_count(BI_Stats, MPI_PACKED, &i);
+ if (i != MPI_UNDEFINED) bp->N = i;
+ else BI_BlacsWarn(BI_ContxtNum(ctxt), __LINE__, __FILE__,
+ "MPI_Get_count returned MPI_UNDEFINED.\n");
+ }
+#endif
+}
diff --git a/BLACS/SRC/BI_SringBR.c b/BLACS/SRC/BI_SringBR.c
new file mode 100644
index 0000000..1b8bbcf
--- /dev/null
+++ b/BLACS/SRC/BI_SringBR.c
@@ -0,0 +1,28 @@
+#include "Bdef.h"
+
+void BI_SringBR(BLACSCONTEXT *ctxt, BLACBUFF *bp, SDRVPTR send, int src)
+{
+ void BI_Srecv(BLACSCONTEXT *, int, int, BLACBUFF *);
+
+ int mydist; /* my distance from source */
+ int Np, Iam, msgid, rightedge;
+
+ Np = ctxt->scp->Np;
+ Iam = ctxt->scp->Iam;
+ msgid = Mscopeid(ctxt);
+
+ mydist = (Np + Iam - src) % Np;
+ rightedge = Np/2;
+ BI_Srecv(ctxt, BANYNODE, msgid, bp);
+
+/*
+ * If I'm between source & right edge of split ring, send to right
+ */
+ if (mydist < rightedge)
+ send(ctxt, (Iam+1)%Np, msgid, bp);
+/*
+ * If I'm between source and left edge of split ring, send to left
+ */
+ else if (mydist > rightedge+1)
+ send(ctxt, (Np+Iam-1)%Np, msgid, bp);
+}
diff --git a/BLACS/SRC/BI_SringBS.c b/BLACS/SRC/BI_SringBS.c
new file mode 100644
index 0000000..53ae223
--- /dev/null
+++ b/BLACS/SRC/BI_SringBS.c
@@ -0,0 +1,13 @@
+#include "Bdef.h"
+
+void BI_SringBS(BLACSCONTEXT *ctxt, BLACBUFF *bp, SDRVPTR send)
+{
+ int Np, Iam, msgid;
+
+ Np = ctxt->scp->Np;
+ if (Np < 2) return;
+ Iam = ctxt->scp->Iam;
+ msgid = Mscopeid(ctxt);
+ send(ctxt, (Iam + 1)%Np, msgid, bp);
+ if (Np > 2) send(ctxt, (Np + Iam - 1)%Np, msgid, bp);
+}
diff --git a/BLACS/SRC/BI_Ssend.c b/BLACS/SRC/BI_Ssend.c
new file mode 100644
index 0000000..75c53d0
--- /dev/null
+++ b/BLACS/SRC/BI_Ssend.c
@@ -0,0 +1,7 @@
+#include "Bdef.h"
+
+void BI_Ssend(BLACSCONTEXT *ctxt, int dest, int msgid, BLACBUFF *bp)
+{
+ int info;
+ info=MPI_Send(bp->Buff, bp->N, bp->dtype, dest, msgid, ctxt->scp->comm);
+}
diff --git a/BLACS/SRC/BI_TransDist.c b/BLACS/SRC/BI_TransDist.c
new file mode 100644
index 0000000..cd184f0
--- /dev/null
+++ b/BLACS/SRC/BI_TransDist.c
@@ -0,0 +1,58 @@
+#include "Bdef.h"
+
+void BI_TransDist(BLACSCONTEXT *ctxt, char scope, int m, int n, int *rA,
+ int *cA, int ldrc, BI_DistType *dist, int rdest, int cdest)
+/*
+ * This routine translates distances (offsets from the destination node),
+ * stored in location dist, into row and column coordinates.
+ */
+{
+ int i, j, k, dest;
+ int Ng, nprow, npcol, myrow, mycol;
+
+ Mgridinfo(ctxt, Ng, nprow, npcol, myrow, mycol);
+ if (rdest == -1) rdest = cdest = 0;
+
+ switch (scope)
+ {
+ case 'r':
+ for (j=0; j < n; j++)
+ {
+ for (i=0; i < m; i++)
+ {
+ rA[i] = myrow;
+ cA[i] = (int) (cdest + dist[i]) % npcol;
+ }
+ rA += ldrc;
+ cA += ldrc;
+ dist += m;
+ }
+ break;
+ case 'c':
+ for (j=0; j < n; j++)
+ {
+ for (i=0; i < m; i++)
+ {
+ rA[i] = (int) (rdest + dist[i]) % nprow;
+ cA[i] = mycol;
+ }
+ rA += ldrc;
+ cA += ldrc;
+ dist += m;
+ }
+ break;
+ case 'a':
+ dest = Mvkpnum(ctxt, rdest, cdest);
+ for (j=0; j < n; j++)
+ {
+ for (i=0; i < m; i++)
+ {
+ k = (int) (dest + dist[i]) % Ng; /* figure node number */
+ Mvpcoord(ctxt, k, rA[i], cA[i]); /* figure node coordinates */
+ }
+ rA += ldrc;
+ cA += ldrc;
+ dist += m;
+ }
+ }
+}
diff --git a/BLACS/SRC/BI_TransUserComm.c b/BLACS/SRC/BI_TransUserComm.c
new file mode 100644
index 0000000..9e43a4d
--- /dev/null
+++ b/BLACS/SRC/BI_TransUserComm.c
@@ -0,0 +1,16 @@
+#include "Bdef.h"
+
+MPI_Comm BI_TransUserComm(int Ucomm, int Np, int *pmap)
+{
+ MPI_Comm bcomm, ucomm;
+ MPI_Group bgrp, ugrp;
+ int i;
+ ucomm = MPI_Comm_f2c(Ucomm);
+ i=MPI_Comm_group(ucomm, &ugrp);
+ i=MPI_Group_incl(ugrp, Np, pmap, &bgrp);
+ i=MPI_Comm_create(ucomm, bgrp, &bcomm);
+ i=MPI_Group_free(&ugrp);
+ i=MPI_Group_free(&bgrp);
+
+ return(bcomm);
+}
diff --git a/BLACS/SRC/BI_TreeBR.c b/BLACS/SRC/BI_TreeBR.c
new file mode 100644
index 0000000..872dab8
--- /dev/null
+++ b/BLACS/SRC/BI_TreeBR.c
@@ -0,0 +1,39 @@
+#include "Bdef.h"
+
+void BI_TreeBR(BLACSCONTEXT *ctxt, BLACBUFF *bp, SDRVPTR send, int src, int nbranches)
+{
+ void BI_Srecv(BLACSCONTEXT *, int, int, BLACBUFF *);
+ int Np, Iam, msgid, i, j;
+ int mydist; /* my distance from src */
+ int destdist; /* the distance of the destination node */
+
+ Np = ctxt->scp->Np;
+ if (Np < 2) return;
+ Iam = ctxt->scp->Iam;
+ msgid = Mscopeid(ctxt);
+ mydist = (Np + Iam - src) % Np;
+
+/*
+ * Go up to first step of tree where I send data to other nodes
+ */
+ for (i=nbranches; i < Np; i *= nbranches);
+ for (i /= nbranches; (mydist%i); i /= nbranches);
+ BI_Srecv(ctxt, BANYNODE, msgid, bp);
+
+/*
+ * While I need to send data to others
+ */
+ while ( (i > 1) && !(mydist%i) )
+ {
+ i /= nbranches;
+ j = 1;
+ do
+ {
+ destdist = mydist + j*i;
+ if (destdist < Np)
+ send(ctxt, (src+destdist)%Np, msgid, bp);
+ }
+ while(++j < nbranches);
+ }
+
+} /* end BI_TreeBR */
diff --git a/BLACS/SRC/BI_TreeBS.c b/BLACS/SRC/BI_TreeBS.c
new file mode 100644
index 0000000..a267f90
--- /dev/null
+++ b/BLACS/SRC/BI_TreeBS.c
@@ -0,0 +1,59 @@
+#include "Bdef.h"
+
+/*
+ * Tree_bs/br is a algorithm that does a broadcast send/recv such that the
+ * communication pattern is a tree with an arbitrary number of branches.
+ * The following two pairs of graphs give different ways of viewing the same
+ * algorithm. The first pair shows the trees as they should be visualized
+ * when examining the algorithm. The second pair are isomorphic graphs of
+ * of the first, which show the actual pattern of data movement.
+
+ * Note that a tree broadcast with NBRANCHES = 2 is isomorphic with a
+ * hypercube broadcast (however, it does not require the nodes be a
+ * power of two to work).
+ *
+ * TREE BROADCAST, NBRANCHES = 2 * TREE BROADCAST, NBRANCHES = 3
+ * *
+ * i=4 &______________ *
+ * | \ *
+ * i=2 &______ &______ * i=3 &______________________
+ * | \ | \ * | \ \
+ * i=1 &__ &__ &__ &__ * i=1 &______ &______ &__
+ * | \ | \ | \ | \ * | \ \ | \ \ | \
+ * 0 1 2 3 4 5 6 7 * 0 1 2 3 4 5 6 7
+ *
+ *
+ * ISOMORPHIC GRAPHS OF ABOVE, SHOWN IN MORE FAMILIAR TERMS:
+ *
+ * 0 0
+ * _________|_________ ___________|____________
+ * / | \ / | | \
+ * 4 2 1 6 3 2 1
+ * / \ | | / \
+ * 6 5 3 7 4 5
+ * |
+ * 7
+ */
+void BI_TreeBS(BLACSCONTEXT *ctxt, BLACBUFF *bp, SDRVPTR send, int nbranches)
+{
+ int Np, Iam, msgid, i, j;
+ int destdist; /* the distance of the destination node */
+
+ Np = ctxt->scp->Np;
+ if (Np < 2) return;
+ Iam = ctxt->scp->Iam;
+ msgid = Mscopeid(ctxt);
+
+ for (i=nbranches; i < Np; i*=nbranches);
+ for (i /= nbranches; i > 0; i /= nbranches)
+ {
+ j = 1;
+ do
+ {
+ destdist = i*j;
+ if (destdist < Np)
+ send(ctxt, (destdist+Iam)%Np, msgid, bp);
+ }
+ while(++j < nbranches);
+ }
+} /* end BI_TreeBS */
diff --git a/BLACS/SRC/BI_TreeComb.c b/BLACS/SRC/BI_TreeComb.c
new file mode 100644
index 0000000..443de8d
--- /dev/null
+++ b/BLACS/SRC/BI_TreeComb.c
@@ -0,0 +1,156 @@
+#include "Bdef.h"
+
+/*
+ * This topology supports trees with arbitrary numbers of branches at
+ * each step. The following pictures show the tree that should be visualized
+ * when examining the algorithm.
+ *
+ * TREE GLOBAL OP, NBRANCHES = 2 * TREE GLOBAL OP, NBRANCHES = 3
+ * *
+ * i=4 &______________ *
+ * | \ *
+ * i=2 &______ &______ * i=3 &______________________
+ * | \ | \ * | \ \
+ * i=1 &__ &__ &__ &__ * i=1 &______ &______ &__
+ * | \ | \ | \ | \ * | \ \ | \ \ | \
+ * 0 1 2 3 4 5 6 7 * 0 1 2 3 4 5 6 7
+ */
+
+void BI_TreeComb(BLACSCONTEXT *ctxt, BLACBUFF *bp, BLACBUFF *bp2,
+ int N, VVFUNPTR Xvvop, int dest, int nbranches)
+/*
+ * -- V1.1ALPHA (test version) BLACS routine --
+ * University of Tennessee, October 1, 1995
+ * Written by Clint Whaley.
+ *
+ * Purpose
+ * =======
+ * Perform a element-by-element combine on vectors.
+ * If rdest1 = -1, the answer will be left on all participating processes.
+ * Otherwise, only the process at grid coordinates {rdest1, cdest1} will
+ * have the final answer. Other Processes will have intermediate (useless)
+ * values.
+ *
+ * Arguments
+ * =========
+ * CTXT (input) pointer to BLACSCONTEXT
+ * The BLACS context where operation is taking place.
+ *
+ * BP (input/output) pointer to BLACBUFF.
+ * BLACBUFF is a special data type used by the BLACS to control
+ * buffers and the asynchronous operations coming out of them.
+ * This BLACBUFF should have a buffer who's first N elements
+ * contain the data to be combined. Additional space may be
+ * required, depending upon what combine is being performed.
+ *
+ * BP2 (workspace) pointer to BLACBUFF.
+ * This BLACBUFF is used to receive information for combining with
+ * this process's information.
+ *
+ * DEST (input) int
+ * Node to receive answer. If DEST == -1, all nodes in receive
+ * the answer.
+ *
+ * N (input) int
+ * The number of elements in the vector. N >= 0.
+ *
+ * Xvvop (input) pointer to typed operation function
+ * Points to a typed function which performs the required operation
+ * (e.g. summation) on the two N-element vectors.
+ *
+ * NBRANCHES (input) int
+ * Indicates the degree of the tree to use (see picture above).
+ *
+ * ------------------------------------------------------------------------
+ */
+{
+ void BI_UpdateBuffs(BLACBUFF *);
+ BLACBUFF *BI_GetBuff(int);
+ int BI_BuffIsFree(BLACBUFF *, int);
+ void BI_Ssend(BLACSCONTEXT *, int, int, BLACBUFF *);
+ void BI_Srecv(BLACSCONTEXT *, int, int, BLACBUFF *);
+ void BI_Rsend(BLACSCONTEXT *, int, int, BLACBUFF *);
+ void BI_Arecv(BLACSCONTEXT *, int, int, BLACBUFF *);
+
+ int Np, Iam, msgid, Rmsgid, i, j;
+ int nrcvs=0; /* Number of ReCeiVeS to do */
+ int REBS; /* should info be RE-BroadcaSt? */
+ int rightedge; /* right-most receiving node */
+ int mydist; /* my distance from destination node */
+ int dist;
+ int src; /* Used if we must force repeatability */
+
+ Np = ctxt->scp->Np;
+ if (Np < 2) return;
+ Iam = ctxt->scp->Iam;
+ msgid = Mscopeid(ctxt);
+ Rmsgid = Mscopeid(ctxt);
+ if (REBS = (dest == -1)) dest = 0;
+
+ mydist = (Np + Iam - dest) % Np;
+ if (REBS)
+ {
+ dist = mydist;
+ if (mydist != 0) BI_Arecv(ctxt, BANYNODE, Rmsgid, bp);
+ }
+
+ if (nbranches == FULLCON) nbranches = Np;
+ rightedge = Np - 1 - (Np-1)%nbranches;
+
+ for (i=1; (i < Np); i *= nbranches)
+ {
+ if (mydist%nbranches) /* nodes that send to other nodes */
+ {
+ BI_Ssend(ctxt, (dest + (mydist-mydist%nbranches)*i)%Np, msgid, bp);
+ break; /* I'm done */
+ }
+ else
+ {
+ if (mydist != rightedge) nrcvs = nbranches - 1;
+ else nrcvs = (Np + i - 1) / i - rightedge - 1;
+ mydist /= nbranches;
+ rightedge /= nbranches;
+ rightedge -= (rightedge % nbranches);
+
+ if (!ctxt->TopsRepeat)
+ {
+ for (j=nrcvs; j; j--)
+ {
+ BI_Srecv(ctxt, BANYNODE, msgid, bp2);
+ Xvvop(N, bp->Buff, bp2->Buff);
+ }
+ }
+ else
+ {
+ src = (Iam + i) % Np;
+ for (j=nrcvs; j; j--)
+ {
+ BI_Srecv(ctxt, src, msgid, bp2);
+ Xvvop(N, bp->Buff, bp2->Buff);
+ src = (src + i) % Np;
+ }
+ }
+ }
+ }
+
+/*
+ * Broadcast answer to everyone if RDEST == -1
+ */
+ if (REBS)
+ {
+ mydist = dist;
+ for (i=2; i < Np; i <<= 1);
+ if (mydist > 0) BI_BuffIsFree(bp, 1);
+
+ while (i > 1)
+ {
+ if ( !(mydist%i) )
+ {
+ i >>= 1;
+ dist = mydist + i;
+ if (dist < Np) BI_Rsend(ctxt, dist, Rmsgid, bp);
+ }
+ else i >>= 1;
+ }
+ }
+} /* end BI_TreeComb */
diff --git a/BLACS/SRC/BI_Unpack.c b/BLACS/SRC/BI_Unpack.c
new file mode 100644
index 0000000..4ac8241
--- /dev/null
+++ b/BLACS/SRC/BI_Unpack.c
@@ -0,0 +1,16 @@
+#include "Bdef.h"
+
+void BI_Unpack(BLACSCONTEXT *ctxt, BVOID *A, BLACBUFF *bp, MPI_Datatype Dtype)
+{
+ int i=0, info, one=1;
+
+/*
+ * Some versions of mpich and its derivitives cannot handle 0 byte typedefs,
+ * so we have set MPI_BYTE as a flag for a 0 byte message
+ */
+#ifdef ZeroByteTypeBug
+ if (Dtype == MPI_BYTE) return;
+#endif
+ info=MPI_Unpack(bp->Buff, bp->Len, &i, A, one, Dtype, ctxt->scp->comm);
+ info=MPI_Type_free(&Dtype);
+}
diff --git a/BLACS/SRC/BI_UpdateBuffs.c b/BLACS/SRC/BI_UpdateBuffs.c
new file mode 100644
index 0000000..453f878
--- /dev/null
+++ b/BLACS/SRC/BI_UpdateBuffs.c
@@ -0,0 +1,57 @@
+#include "Bdef.h"
+
+void BI_UpdateBuffs(BLACBUFF *Newbp)
+{
+ int BI_BuffIsFree(BLACBUFF *, int);
+ BLACBUFF *bp, *bp2;
+ extern BLACBUFF *BI_ReadyB, *BI_ActiveQ;
+
+ if (Newbp)
+ {
+ if (BI_ActiveQ == NULL) BI_ActiveQ = Newbp->prev = Newbp;
+ else
+ {
+ BI_ActiveQ->prev->next = Newbp;
+ Newbp->prev = BI_ActiveQ->prev;
+ BI_ActiveQ->prev = Newbp;
+ }
+ Newbp->next = NULL;
+ if (Newbp == BI_ReadyB) BI_ReadyB = NULL;
+ }
+/*
+ * See if any active buffers are ready for reuse.
+ */
+ for (bp=BI_ActiveQ; bp != NULL; bp = bp2)
+ {
+ bp2 = bp->next;
+ if ( BI_BuffIsFree(bp, 0) ) /* if all of buff's Aops are done */
+ {
+/*
+ * Remove bp from BI_ActiveQ -- update pointers
+ */
+ if (bp->next) bp->next->prev = bp->prev;
+ else BI_ActiveQ->prev = bp->prev;
+ if (bp != BI_ActiveQ) bp->prev->next = bp->next;
+ else BI_ActiveQ = BI_ActiveQ->next;
+
+/*
+ * If no ready buffer, inactive buff becomes ready
+ */
+ if (BI_ReadyB == NULL) BI_ReadyB = bp;
+/*
+ * If inactive buff bigger than present ready buff, release ready,
+ * and inactive buff becomes ready
+ */
+ else if (BI_ReadyB->Len < bp->Len)
+ {
+ free(BI_ReadyB);
+ BI_ReadyB = bp;
+ }
+/*
+ * If ready buffer exists and is bigger than inactive buff,
+ * free inactive buff
+ */
+ else free(bp);
+ }
+ }
+} /* end BI_UpdateBuffs */
diff --git a/BLACS/SRC/BI_cMPI_amn.c b/BLACS/SRC/BI_cMPI_amn.c
new file mode 100644
index 0000000..c3e1b6d
--- /dev/null
+++ b/BLACS/SRC/BI_cMPI_amn.c
@@ -0,0 +1,9 @@
+#include "Bdef.h"
+
+void BI_cMPI_amn(void *in, void *inout, int *N, MPI_Datatype *dtype)
+{
+ void BI_cvvamn(int, char *, char *);
+ extern BLACBUFF BI_AuxBuff;
+
+ BI_cvvamn(BI_AuxBuff.Len, inout, in);
+}
diff --git a/BLACS/SRC/BI_cMPI_amn2.c b/BLACS/SRC/BI_cMPI_amn2.c
new file mode 100644
index 0000000..1eaee55
--- /dev/null
+++ b/BLACS/SRC/BI_cMPI_amn2.c
@@ -0,0 +1,6 @@
+#include "Bdef.h"
+void BI_cMPI_amn2(void *in, void *inout, int *N, MPI_Datatype *dtype)
+{
+ void BI_cvvamn2(int, char *, char *);
+ BI_cvvamn2(*N, inout, in);
+}
diff --git a/BLACS/SRC/BI_cMPI_amx.c b/BLACS/SRC/BI_cMPI_amx.c
new file mode 100644
index 0000000..c84ff5f
--- /dev/null
+++ b/BLACS/SRC/BI_cMPI_amx.c
@@ -0,0 +1,9 @@
+#include "Bdef.h"
+
+void BI_cMPI_amx(void *in, void *inout, int *N, MPI_Datatype *dtype)
+{
+ void BI_cvvamx(int, char *, char *);
+ extern BLACBUFF BI_AuxBuff;
+
+ BI_cvvamx(BI_AuxBuff.Len, inout, in);
+}
diff --git a/BLACS/SRC/BI_cMPI_amx2.c b/BLACS/SRC/BI_cMPI_amx2.c
new file mode 100644
index 0000000..9d6f138
--- /dev/null
+++ b/BLACS/SRC/BI_cMPI_amx2.c
@@ -0,0 +1,6 @@
+#include "Bdef.h"
+void BI_cMPI_amx2(void *in, void *inout, int *N, MPI_Datatype *dtype)
+{
+ void BI_cvvamx2(int, char *, char *);
+ BI_cvvamx2(*N, inout, in);
+}
diff --git a/BLACS/SRC/BI_cMPI_sum.c b/BLACS/SRC/BI_cMPI_sum.c
new file mode 100644
index 0000000..14b2412
--- /dev/null
+++ b/BLACS/SRC/BI_cMPI_sum.c
@@ -0,0 +1,6 @@
+#include "Bdef.h"
+void BI_cMPI_sum(void *in, void *inout, int *N, MPI_Datatype *dtype)
+{
+ void BI_cvvsum(int, char *, char *);
+ BI_cvvsum(*N, inout, in);
+}
diff --git a/BLACS/SRC/BI_cvvamn.c b/BLACS/SRC/BI_cvvamn.c
new file mode 100644
index 0000000..8774a6a
--- /dev/null
+++ b/BLACS/SRC/BI_cvvamn.c
@@ -0,0 +1,34 @@
+#include "Bdef.h"
+void BI_cvvamn(int N, char *vec1, char *vec2)
+{
+ SCOMPLEX *v1=(SCOMPLEX*)vec1, *v2=(SCOMPLEX*)vec2;
+ float diff;
+ BI_DistType *dist1, *dist2;
+ int i, k;
+
+ k = N * sizeof(SCOMPLEX);
+ i = k % sizeof(BI_DistType);
+ if (i) k += sizeof(BI_DistType) - i;
+ dist1 = (BI_DistType *) &vec1[k];
+ dist2 = (BI_DistType *) &vec2[k];
+
+ for (k=0; k < N; k++)
+ {
+ diff = Cabs(v1[k]) - Cabs(v2[k]);
+ if (diff > 0)
+ {
+ v1[k].r = v2[k].r;
+ v1[k].i = v2[k].i;
+ dist1[k] = dist2[k];
+ }
+ else if (diff == 0)
+ {
+ if (dist1[k] > dist2[k])
+ {
+ v1[k].r = v2[k].r;
+ v1[k].i = v2[k].i;
+ dist1[k] = dist2[k];
+ }
+ }
+ }
+}
diff --git a/BLACS/SRC/BI_cvvamn2.c b/BLACS/SRC/BI_cvvamn2.c
new file mode 100644
index 0000000..64c8dcd
--- /dev/null
+++ b/BLACS/SRC/BI_cvvamn2.c
@@ -0,0 +1,37 @@
+#include "Bdef.h"
+void BI_cvvamn2(int N, char *vec1, char *vec2)
+{
+ int r, i;
+ float *v1=(float*)vec1, *v2=(float*)vec2;
+ float diff;
+
+ N *= 2;
+ for (r=0, i=1; r != N; r += 2, i += 2)
+ {
+ diff = (Rabs(v1[r]) + Rabs(v1[i])) - (Rabs(v2[r]) + Rabs(v2[i]));
+ if (diff > 0)
+ {
+ v1[r] = v2[r];
+ v1[i] = v2[i];
+ }
+ else if (diff == 0)
+ {
+ if (v1[r] != v2[r])
+ {
+ if (v1[r] < v2[r])
+ {
+ v1[r] = v2[r];
+ v1[i] = v2[i];
+ }
+ }
+ else
+ {
+ if (v1[i] < v2[i])
+ {
+ v1[r] = v2[r];
+ v1[i] = v2[i];
+ }
+ }
+ }
+ }
+}
diff --git a/BLACS/SRC/BI_cvvamx.c b/BLACS/SRC/BI_cvvamx.c
new file mode 100644
index 0000000..8802e1f
--- /dev/null
+++ b/BLACS/SRC/BI_cvvamx.c
@@ -0,0 +1,34 @@
+#include "Bdef.h"
+void BI_cvvamx(int N, char *vec1, char *vec2)
+{
+ SCOMPLEX *v1=(SCOMPLEX*)vec1, *v2=(SCOMPLEX*)vec2;
+ float diff;
+ BI_DistType *dist1, *dist2;
+ int i, k;
+
+ k = N * sizeof(SCOMPLEX);
+ i = k % sizeof(BI_DistType);
+ if (i) k += sizeof(BI_DistType) - i;
+ dist1 = (BI_DistType *) &vec1[k];
+ dist2 = (BI_DistType *) &vec2[k];
+
+ for (k=0; k < N; k++)
+ {
+ diff = Cabs(v1[k]) - Cabs(v2[k]);
+ if (diff < 0)
+ {
+ v1[k].r = v2[k].r;
+ v1[k].i = v2[k].i;
+ dist1[k] = dist2[k];
+ }
+ else if (diff == 0)
+ {
+ if (dist1[k] > dist2[k])
+ {
+ v1[k].r = v2[k].r;
+ v1[k].i = v2[k].i;
+ dist1[k] = dist2[k];
+ }
+ }
+ }
+}
diff --git a/BLACS/SRC/BI_cvvamx2.c b/BLACS/SRC/BI_cvvamx2.c
new file mode 100644
index 0000000..4779d28
--- /dev/null
+++ b/BLACS/SRC/BI_cvvamx2.c
@@ -0,0 +1,37 @@
+#include "Bdef.h"
+void BI_cvvamx2(int N, char *vec1, char *vec2)
+{
+ int r, i;
+ float *v1=(float*)vec1, *v2=(float*)vec2;
+ float diff;
+
+ N *= 2;
+ for (r=0, i=1; r != N; r += 2, i += 2)
+ {
+ diff = (Rabs(v1[r]) + Rabs(v1[i])) - (Rabs(v2[r]) + Rabs(v2[i]));
+ if (diff < 0)
+ {
+ v1[r] = v2[r];
+ v1[i] = v2[i];
+ }
+ else if (diff == 0)
+ {
+ if (v1[r] != v2[r])
+ {
+ if (v1[r] < v2[r])
+ {
+ v1[r] = v2[r];
+ v1[i] = v2[i];
+ }
+ }
+ else
+ {
+ if (v1[i] < v2[i])
+ {
+ v1[r] = v2[r];
+ v1[i] = v2[i];
+ }
+ }
+ }
+ }
+}
diff --git a/BLACS/SRC/BI_cvvsum.c b/BLACS/SRC/BI_cvvsum.c
new file mode 100644
index 0000000..3478f96
--- /dev/null
+++ b/BLACS/SRC/BI_cvvsum.c
@@ -0,0 +1,8 @@
+#include "Bdef.h"
+void BI_cvvsum(int N, char *vec1, char *vec2)
+{
+ float *v1=(float*)vec1, *v2=(float*)vec2;
+ int k;
+ N *=2;
+ for (k=0; k < N; k++) v1[k] += v2[k];
+}
diff --git a/BLACS/SRC/BI_dMPI_amn.c b/BLACS/SRC/BI_dMPI_amn.c
new file mode 100644
index 0000000..e7b0f06
--- /dev/null
+++ b/BLACS/SRC/BI_dMPI_amn.c
@@ -0,0 +1,9 @@
+#include "Bdef.h"
+
+void BI_dMPI_amn(void *in, void *inout, int *N, MPI_Datatype *dtype)
+{
+ void BI_dvvamn(int, char *, char *);
+ extern BLACBUFF BI_AuxBuff;
+
+ BI_dvvamn(BI_AuxBuff.Len, inout, in);
+}
diff --git a/BLACS/SRC/BI_dMPI_amn2.c b/BLACS/SRC/BI_dMPI_amn2.c
new file mode 100644
index 0000000..362371a
--- /dev/null
+++ b/BLACS/SRC/BI_dMPI_amn2.c
@@ -0,0 +1,6 @@
+#include "Bdef.h"
+void BI_dMPI_amn2(void *in, void *inout, int *N, MPI_Datatype *dtype)
+{
+ void BI_dvvamn2(int, char *, char *);
+ BI_dvvamn2(*N, inout, in);
+}
diff --git a/BLACS/SRC/BI_dMPI_amx.c b/BLACS/SRC/BI_dMPI_amx.c
new file mode 100644
index 0000000..8fe6397
--- /dev/null
+++ b/BLACS/SRC/BI_dMPI_amx.c
@@ -0,0 +1,9 @@
+#include "Bdef.h"
+
+void BI_dMPI_amx(void *in, void *inout, int *N, MPI_Datatype *dtype)
+{
+ void BI_dvvamx(int, char *, char *);
+ extern BLACBUFF BI_AuxBuff;
+
+ BI_dvvamx(BI_AuxBuff.Len, inout, in);
+}
diff --git a/BLACS/SRC/BI_dMPI_amx2.c b/BLACS/SRC/BI_dMPI_amx2.c
new file mode 100644
index 0000000..a7b82e6
--- /dev/null
+++ b/BLACS/SRC/BI_dMPI_amx2.c
@@ -0,0 +1,6 @@
+#include "Bdef.h"
+void BI_dMPI_amx2(void *in, void *inout, int *N, MPI_Datatype *dtype)
+{
+ void BI_dvvamx2(int, char *, char *);
+ BI_dvvamx2(*N, inout, in);
+}
diff --git a/BLACS/SRC/BI_dmvcopy.c b/BLACS/SRC/BI_dmvcopy.c
new file mode 100644
index 0000000..277bc25
--- /dev/null
+++ b/BLACS/SRC/BI_dmvcopy.c
@@ -0,0 +1,27 @@
+#include "Bdef.h"
+void BI_dmvcopy(int m, int n, double *A, int lda, double *buff)
+/*
+ * Performs a matrix to vector copy (pack) for the data type double
+ */
+{
+ int i, j;
+
+ if ( (m == lda) || (n == 1) )
+ {
+ m = n * m;
+ for (i=0; i < m; i++) buff[i] = A[i];
+ }
+ else if (m == 1)
+ {
+ for (j=0; j < n; j++) buff[j] = A[j*lda];
+ }
+ else
+ {
+ for (j=0; j < n; j++)
+ {
+ for (i=0; i < m; i++) buff[i] = A[i];
+ A += lda;
+ buff += m;
+ }
+ }
+}
diff --git a/BLACS/SRC/BI_dvmcopy.c b/BLACS/SRC/BI_dvmcopy.c
new file mode 100644
index 0000000..bcf1e36
--- /dev/null
+++ b/BLACS/SRC/BI_dvmcopy.c
@@ -0,0 +1,28 @@
+#include "Bdef.h"
+
+void BI_dvmcopy(int m, int n, double *A, int lda, double *buff)
+/*
+ * performs an vector to matrix copy (unpack) for the data type double
+ */
+{
+ int i, j;
+
+ if ( (m == lda) || (n == 1) )
+ {
+ m = n * m;
+ for (i=0; i < m; i++) A[i] = buff[i];
+ }
+ else if (m == 1)
+ {
+ for (j=0; j < n; j++) A[j*lda] = buff[j];
+ }
+ else
+ {
+ for (j=0; j< n; j++)
+ {
+ for (i=0; i < m; i++) A[i] = buff[i];
+ A += lda;
+ buff += m;
+ }
+ }
+}
diff --git a/BLACS/SRC/BI_dvvamn.c b/BLACS/SRC/BI_dvvamn.c
new file mode 100644
index 0000000..0c5851e
--- /dev/null
+++ b/BLACS/SRC/BI_dvvamn.c
@@ -0,0 +1,32 @@
+#include "Bdef.h"
+void BI_dvvamn(int N, char *vec1, char *vec2)
+{
+ double *v1=(double*)vec1, *v2=(double*)vec2;
+ double diff;
+ BI_DistType *dist1, *dist2;
+ int i, k;
+
+ k = N * sizeof(double);
+ i = k % sizeof(BI_DistType);
+ if (i) k += sizeof(BI_DistType) - i;
+ dist1 = (BI_DistType *) &vec1[k];
+ dist2 = (BI_DistType *) &vec2[k];
+
+ for (k=0; k < N; k++)
+ {
+ diff = Rabs(v1[k]) - Rabs(v2[k]);
+ if (diff > 0)
+ {
+ v1[k] = v2[k];
+ dist1[k] = dist2[k];
+ }
+ else if (diff == 0)
+ {
+ if (dist1[k] > dist2[k])
+ {
+ v1[k] = v2[k];
+ dist1[k] = dist2[k];
+ }
+ }
+ }
+}
diff --git a/BLACS/SRC/BI_dvvamn2.c b/BLACS/SRC/BI_dvvamn2.c
new file mode 100644
index 0000000..3ec758f
--- /dev/null
+++ b/BLACS/SRC/BI_dvvamn2.c
@@ -0,0 +1,14 @@
+#include "Bdef.h"
+void BI_dvvamn2(int N, char *vec1, char *vec2)
+{
+ int k;
+ double *v1=(double*)vec1, *v2=(double*)vec2;
+ double diff;
+
+ for (k=0; k != N; k++)
+ {
+ diff = Rabs(v1[k]) - Rabs(v2[k]);
+ if (diff > 0) v1[k] = v2[k];
+ else if (diff == 0) if (v1[k] < v2[k]) v1[k] = v2[k];
+ }
+}
diff --git a/BLACS/SRC/BI_dvvamx.c b/BLACS/SRC/BI_dvvamx.c
new file mode 100644
index 0000000..ee0b170
--- /dev/null
+++ b/BLACS/SRC/BI_dvvamx.c
@@ -0,0 +1,32 @@
+#include "Bdef.h"
+void BI_dvvamx(int N, char *vec1, char *vec2)
+{
+ double *v1=(double*)vec1, *v2=(double*)vec2;
+ double diff;
+ BI_DistType *dist1, *dist2;
+ int i, k;
+
+ k = N * sizeof(double);
+ i = k % sizeof(BI_DistType);
+ if (i) k += sizeof(BI_DistType) - i;
+ dist1 = (BI_DistType *) &vec1[k];
+ dist2 = (BI_DistType *) &vec2[k];
+
+ for (k=0; k < N; k++)
+ {
+ diff = Rabs(v1[k]) - Rabs(v2[k]);
+ if (diff < 0)
+ {
+ v1[k] = v2[k];
+ dist1[k] = dist2[k];
+ }
+ else if (diff == 0)
+ {
+ if (dist1[k] > dist2[k])
+ {
+ v1[k] = v2[k];
+ dist1[k] = dist2[k];
+ }
+ }
+ }
+}
diff --git a/BLACS/SRC/BI_dvvamx2.c b/BLACS/SRC/BI_dvvamx2.c
new file mode 100644
index 0000000..a849ade
--- /dev/null
+++ b/BLACS/SRC/BI_dvvamx2.c
@@ -0,0 +1,14 @@
+#include "Bdef.h"
+void BI_dvvamx2(int N, char *vec1, char *vec2)
+{
+ int k;
+ double *v1=(double*)vec1, *v2=(double*)vec2;
+ double diff;
+
+ for (k=0; k != N; k++)
+ {
+ diff = Rabs(v1[k]) - Rabs(v2[k]);
+ if (diff < 0) v1[k] = v2[k];
+ else if (diff == 0) if (v1[k] < v2[k]) v1[k] = v2[k];
+ }
+}
diff --git a/BLACS/SRC/BI_dvvsum.c b/BLACS/SRC/BI_dvvsum.c
new file mode 100644
index 0000000..4689ebc
--- /dev/null
+++ b/BLACS/SRC/BI_dvvsum.c
@@ -0,0 +1,7 @@
+#include "Bdef.h"
+void BI_dvvsum(int N, char *vec1, char *vec2)
+{
+ double *v1=(double*)vec1, *v2=(double*)vec2;
+ int k;
+ for (k=0; k < N; k++) v1[k] += v2[k];
+}
diff --git a/BLACS/SRC/BI_iMPI_amn.c b/BLACS/SRC/BI_iMPI_amn.c
new file mode 100644
index 0000000..4633acd
--- /dev/null
+++ b/BLACS/SRC/BI_iMPI_amn.c
@@ -0,0 +1,9 @@
+#include "Bdef.h"
+
+void BI_iMPI_amn(void *in, void *inout, int *N, MPI_Datatype *dtype)
+{
+ void BI_ivvamn(int, char *, char *);
+ extern BLACBUFF BI_AuxBuff;
+
+ BI_ivvamn(BI_AuxBuff.Len, inout, in);
+}
diff --git a/BLACS/SRC/BI_iMPI_amn2.c b/BLACS/SRC/BI_iMPI_amn2.c
new file mode 100644
index 0000000..5798943
--- /dev/null
+++ b/BLACS/SRC/BI_iMPI_amn2.c
@@ -0,0 +1,6 @@
+#include "Bdef.h"
+void BI_iMPI_amn2(void *in, void *inout, int *N, MPI_Datatype *dtype)
+{
+ void BI_ivvamn2(int, char *, char *);
+ BI_ivvamn2(*N, inout, in);
+}
diff --git a/BLACS/SRC/BI_iMPI_amx.c b/BLACS/SRC/BI_iMPI_amx.c
new file mode 100644
index 0000000..44da529
--- /dev/null
+++ b/BLACS/SRC/BI_iMPI_amx.c
@@ -0,0 +1,9 @@
+#include "Bdef.h"
+
+void BI_iMPI_amx(void *in, void *inout, int *N, MPI_Datatype *dtype)
+{
+ void BI_ivvamx(int, char *, char *);
+ extern BLACBUFF BI_AuxBuff;
+
+ BI_ivvamx(BI_AuxBuff.Len, inout, in);
+}
diff --git a/BLACS/SRC/BI_iMPI_amx2.c b/BLACS/SRC/BI_iMPI_amx2.c
new file mode 100644
index 0000000..455d485
--- /dev/null
+++ b/BLACS/SRC/BI_iMPI_amx2.c
@@ -0,0 +1,6 @@
+#include "Bdef.h"
+void BI_iMPI_amx2(void *in, void *inout, int *N, MPI_Datatype *dtype)
+{
+ void BI_ivvamx2(int, char *, char *);
+ BI_ivvamx2(*N, inout, in);
+}
diff --git a/BLACS/SRC/BI_imvcopy.c b/BLACS/SRC/BI_imvcopy.c
new file mode 100644
index 0000000..e1ef42f
--- /dev/null
+++ b/BLACS/SRC/BI_imvcopy.c
@@ -0,0 +1,27 @@
+#include "Bdef.h"
+void BI_imvcopy(int m, int n, int *A, int lda, int *buff)
+/*
+ * Performs a matrix to vector copy (pack) for the data type int
+ */
+{
+ int i, j;
+
+ if ( (m == lda) || (n == 1) )
+ {
+ m = n * m;
+ for (i=0; i < m; i++) buff[i] = A[i];
+ }
+ else if (m == 1)
+ {
+ for (j=0; j < n; j++) buff[j] = A[j*lda];
+ }
+ else
+ {
+ for (j=0; j < n; j++)
+ {
+ for (i=0; i < m; i++) buff[i] = A[i];
+ A += lda;
+ buff += m;
+ }
+ }
+}
diff --git a/BLACS/SRC/BI_ivmcopy.c b/BLACS/SRC/BI_ivmcopy.c
new file mode 100644
index 0000000..244afc2
--- /dev/null
+++ b/BLACS/SRC/BI_ivmcopy.c
@@ -0,0 +1,28 @@
+#include "Bdef.h"
+
+void BI_ivmcopy(int m, int n, int *A, int lda, int *buff)
+/*
+ * performs an vector to matrix copy (unpack) for the data type int
+ */
+{
+ int i, j;
+
+ if ( (m == lda) || (n == 1) )
+ {
+ m = n * m;
+ for (i=0; i < m; i++) A[i] = buff[i];
+ }
+ else if (m == 1)
+ {
+ for (j=0; j < n; j++) A[j*lda] = buff[j];
+ }
+ else
+ {
+ for (j=0; j< n; j++)
+ {
+ for (i=0; i < m; i++) A[i] = buff[i];
+ A += lda;
+ buff += m;
+ }
+ }
+}
diff --git a/BLACS/SRC/BI_ivvamn.c b/BLACS/SRC/BI_ivvamn.c
new file mode 100644
index 0000000..7d6d8c0
--- /dev/null
+++ b/BLACS/SRC/BI_ivvamn.c
@@ -0,0 +1,32 @@
+#include "Bdef.h"
+void BI_ivvamn(int N, char *vec1, char *vec2)
+{
+ int *v1=(int*)vec1, *v2=(int*)vec2;
+ int diff;
+ BI_DistType *dist1, *dist2;
+ int i, k;
+
+ k = N * sizeof(int);
+ i = k % sizeof(BI_DistType);
+ if (i) k += sizeof(BI_DistType) - i;
+ dist1 = (BI_DistType *) &vec1[k];
+ dist2 = (BI_DistType *) &vec2[k];
+
+ for (k=0; k < N; k++)
+ {
+ diff = Rabs(v1[k]) - Rabs(v2[k]);
+ if (diff > 0)
+ {
+ v1[k] = v2[k];
+ dist1[k] = dist2[k];
+ }
+ else if (diff == 0)
+ {
+ if (dist1[k] > dist2[k])
+ {
+ v1[k] = v2[k];
+ dist1[k] = dist2[k];
+ }
+ }
+ }
+}
diff --git a/BLACS/SRC/BI_ivvamn2.c b/BLACS/SRC/BI_ivvamn2.c
new file mode 100644
index 0000000..f201839
--- /dev/null
+++ b/BLACS/SRC/BI_ivvamn2.c
@@ -0,0 +1,15 @@
+#include "Bdef.h"
+
+void BI_ivvamn2(int N, char *vec1, char *vec2)
+{
+ int k;
+ int *v1=(int*)vec1, *v2=(int*)vec2;
+ int diff;
+
+ for (k=0; k != N; k++)
+ {
+ diff = Rabs(v1[k]) - Rabs(v2[k]);
+ if (diff > 0) v1[k] = v2[k];
+ else if (diff == 0) if (v1[k] < v2[k]) v1[k] = v2[k];
+ }
+}
diff --git a/BLACS/SRC/BI_ivvamx.c b/BLACS/SRC/BI_ivvamx.c
new file mode 100644
index 0000000..896235a
--- /dev/null
+++ b/BLACS/SRC/BI_ivvamx.c
@@ -0,0 +1,32 @@
+#include "Bdef.h"
+void BI_ivvamx(int N, char *vec1, char *vec2)
+{
+ int *v1=(int*)vec1, *v2=(int*)vec2;
+ int diff;
+ BI_DistType *dist1, *dist2;
+ int i, k;
+
+ k = N * sizeof(int);
+ i = k % sizeof(BI_DistType);
+ if (i) k += sizeof(BI_DistType) - i;
+ dist1 = (BI_DistType *) &vec1[k];
+ dist2 = (BI_DistType *) &vec2[k];
+
+ for (k=0; k < N; k++)
+ {
+ diff = Rabs(v1[k]) - Rabs(v2[k]);
+ if (diff < 0)
+ {
+ v1[k] = v2[k];
+ dist1[k] = dist2[k];
+ }
+ else if (diff == 0)
+ {
+ if (dist1[k] > dist2[k])
+ {
+ v1[k] = v2[k];
+ dist1[k] = dist2[k];
+ }
+ }
+ }
+}
diff --git a/BLACS/SRC/BI_ivvamx2.c b/BLACS/SRC/BI_ivvamx2.c
new file mode 100644
index 0000000..70ca47a
--- /dev/null
+++ b/BLACS/SRC/BI_ivvamx2.c
@@ -0,0 +1,14 @@
+#include "Bdef.h"
+void BI_ivvamx2(int N, char *vec1, char *vec2)
+{
+ int k;
+ int *v1=(int*)vec1, *v2=(int*)vec2;
+ int diff;
+
+ for (k=0; k != N; k++)
+ {
+ diff = Rabs(v1[k]) - Rabs(v2[k]);
+ if (diff < 0) v1[k] = v2[k];
+ else if (diff == 0) if (v1[k] < v2[k]) v1[k] = v2[k];
+ }
+}
diff --git a/BLACS/SRC/BI_ivvsum.c b/BLACS/SRC/BI_ivvsum.c
new file mode 100644
index 0000000..5e71f7b
--- /dev/null
+++ b/BLACS/SRC/BI_ivvsum.c
@@ -0,0 +1,7 @@
+#include "Bdef.h"
+void BI_ivvsum(int N, char *vec1, char *vec2)
+{
+ int *v1=(int*)vec1, *v2=(int*)vec2;
+ int k;
+ for (k=0; k < N; k++) v1[k] += v2[k];
+}
diff --git a/BLACS/SRC/BI_sMPI_amn.c b/BLACS/SRC/BI_sMPI_amn.c
new file mode 100644
index 0000000..b162508
--- /dev/null
+++ b/BLACS/SRC/BI_sMPI_amn.c
@@ -0,0 +1,9 @@
+#include "Bdef.h"
+
+void BI_sMPI_amn(void *in, void *inout, int *N, MPI_Datatype *dtype)
+{
+ void BI_svvamn(int, char *, char *);
+ extern BLACBUFF BI_AuxBuff;
+
+ BI_svvamn(BI_AuxBuff.Len, inout, in);
+}
diff --git a/BLACS/SRC/BI_sMPI_amn2.c b/BLACS/SRC/BI_sMPI_amn2.c
new file mode 100644
index 0000000..44bdd4e
--- /dev/null
+++ b/BLACS/SRC/BI_sMPI_amn2.c
@@ -0,0 +1,6 @@
+#include "Bdef.h"
+void BI_sMPI_amn2(void *in, void *inout, int *N, MPI_Datatype *dtype)
+{
+ void BI_svvamn2(int, char *, char *);
+ BI_svvamn2(*N, inout, in);
+}
diff --git a/BLACS/SRC/BI_sMPI_amx.c b/BLACS/SRC/BI_sMPI_amx.c
new file mode 100644
index 0000000..13b91c7
--- /dev/null
+++ b/BLACS/SRC/BI_sMPI_amx.c
@@ -0,0 +1,9 @@
+#include "Bdef.h"
+
+void BI_sMPI_amx(void *in, void *inout, int *N, MPI_Datatype *dtype)
+{
+ void BI_svvamx(int, char *, char *);
+ extern BLACBUFF BI_AuxBuff;
+
+ BI_svvamx(BI_AuxBuff.Len, inout, in);
+}
diff --git a/BLACS/SRC/BI_sMPI_amx2.c b/BLACS/SRC/BI_sMPI_amx2.c
new file mode 100644
index 0000000..55dc083
--- /dev/null
+++ b/BLACS/SRC/BI_sMPI_amx2.c
@@ -0,0 +1,6 @@
+#include "Bdef.h"
+void BI_sMPI_amx2(void *in, void *inout, int *N, MPI_Datatype *dtype)
+{
+ void BI_svvamx2(int, char *, char *);
+ BI_svvamx2(*N, inout, in);
+}
diff --git a/BLACS/SRC/BI_smvcopy.c b/BLACS/SRC/BI_smvcopy.c
new file mode 100644
index 0000000..2f2e8b7
--- /dev/null
+++ b/BLACS/SRC/BI_smvcopy.c
@@ -0,0 +1,27 @@
+#include "Bdef.h"
+void BI_smvcopy(int m, int n, float *A, int lda, float *buff)
+/*
+ * Performs a matrix to vector copy (pack) for the data type float
+ */
+{
+ int i, j;
+
+ if ( (m == lda) || (n == 1) )
+ {
+ m = n * m;
+ for (i=0; i < m; i++) buff[i] = A[i];
+ }
+ else if (m == 1)
+ {
+ for (j=0; j < n; j++) buff[j] = A[j*lda];
+ }
+ else
+ {
+ for (j=0; j < n; j++)
+ {
+ for (i=0; i < m; i++) buff[i] = A[i];
+ A += lda;
+ buff += m;
+ }
+ }
+}
diff --git a/BLACS/SRC/BI_svmcopy.c b/BLACS/SRC/BI_svmcopy.c
new file mode 100644
index 0000000..565d860
--- /dev/null
+++ b/BLACS/SRC/BI_svmcopy.c
@@ -0,0 +1,28 @@
+#include "Bdef.h"
+
+void BI_svmcopy(int m, int n, float *A, int lda, float *buff)
+/*
+ * performs an vector to matrix copy (unpack) for the data type float
+ */
+{
+ int i, j;
+
+ if ( (m == lda) || (n == 1) )
+ {
+ m = n * m;
+ for (i=0; i < m; i++) A[i] = buff[i];
+ }
+ else if (m == 1)
+ {
+ for (j=0; j < n; j++) A[j*lda] = buff[j];
+ }
+ else
+ {
+ for (j=0; j< n; j++)
+ {
+ for (i=0; i < m; i++) A[i] = buff[i];
+ A += lda;
+ buff += m;
+ }
+ }
+}
diff --git a/BLACS/SRC/BI_svvamn.c b/BLACS/SRC/BI_svvamn.c
new file mode 100644
index 0000000..7477bf3
--- /dev/null
+++ b/BLACS/SRC/BI_svvamn.c
@@ -0,0 +1,32 @@
+#include "Bdef.h"
+void BI_svvamn(int N, char *vec1, char *vec2)
+{
+ float *v1=(float*)vec1, *v2=(float*)vec2;
+ float diff;
+ BI_DistType *dist1, *dist2;
+ int i, k;
+
+ k = N * sizeof(float);
+ i = k % sizeof(BI_DistType);
+ if (i) k += sizeof(BI_DistType) - i;
+ dist1 = (BI_DistType *) &vec1[k];
+ dist2 = (BI_DistType *) &vec2[k];
+
+ for (k=0; k < N; k++)
+ {
+ diff = Rabs(v1[k]) - Rabs(v2[k]);
+ if (diff > 0)
+ {
+ v1[k] = v2[k];
+ dist1[k] = dist2[k];
+ }
+ else if (diff == 0)
+ {
+ if (dist1[k] > dist2[k])
+ {
+ v1[k] = v2[k];
+ dist1[k] = dist2[k];
+ }
+ }
+ }
+}
diff --git a/BLACS/SRC/BI_svvamn2.c b/BLACS/SRC/BI_svvamn2.c
new file mode 100644
index 0000000..0010530
--- /dev/null
+++ b/BLACS/SRC/BI_svvamn2.c
@@ -0,0 +1,14 @@
+#include "Bdef.h"
+void BI_svvamn2(int N, char *vec1, char *vec2)
+{
+ int k;
+ float *v1=(float*)vec1, *v2=(float*)vec2;
+ float diff;
+
+ for (k=0; k != N; k++)
+ {
+ diff = Rabs(v1[k]) - Rabs(v2[k]);
+ if (diff > 0) v1[k] = v2[k];
+ else if (diff == 0) if (v1[k] < v2[k]) v1[k] = v2[k];
+ }
+}
diff --git a/BLACS/SRC/BI_svvamx.c b/BLACS/SRC/BI_svvamx.c
new file mode 100644
index 0000000..947c6c8
--- /dev/null
+++ b/BLACS/SRC/BI_svvamx.c
@@ -0,0 +1,32 @@
+#include "Bdef.h"
+void BI_svvamx(int N, char *vec1, char *vec2)
+{
+ float *v1=(float*)vec1, *v2=(float*)vec2;
+ float diff;
+ BI_DistType *dist1, *dist2;
+ int i, k;
+
+ k = N * sizeof(float);
+ i = k % sizeof(BI_DistType);
+ if (i) k += sizeof(BI_DistType) - i;
+ dist1 = (BI_DistType *) &vec1[k];
+ dist2 = (BI_DistType *) &vec2[k];
+
+ for (k=0; k < N; k++)
+ {
+ diff = Rabs(v1[k]) - Rabs(v2[k]);
+ if (diff < 0)
+ {
+ v1[k] = v2[k];
+ dist1[k] = dist2[k];
+ }
+ else if (diff == 0)
+ {
+ if (dist1[k] > dist2[k])
+ {
+ v1[k] = v2[k];
+ dist1[k] = dist2[k];
+ }
+ }
+ }
+}
diff --git a/BLACS/SRC/BI_svvamx2.c b/BLACS/SRC/BI_svvamx2.c
new file mode 100644
index 0000000..1912be3
--- /dev/null
+++ b/BLACS/SRC/BI_svvamx2.c
@@ -0,0 +1,14 @@
+#include "Bdef.h"
+void BI_svvamx2(int N, char *vec1, char *vec2)
+{
+ int k;
+ float *v1=(float*)vec1, *v2=(float*)vec2;
+ float diff;
+
+ for (k=0; k != N; k++)
+ {
+ diff = Rabs(v1[k]) - Rabs(v2[k]);
+ if (diff < 0) v1[k] = v2[k];
+ else if (diff == 0) if (v1[k] < v2[k]) v1[k] = v2[k];
+ }
+}
diff --git a/BLACS/SRC/BI_svvsum.c b/BLACS/SRC/BI_svvsum.c
new file mode 100644
index 0000000..2fd7089
--- /dev/null
+++ b/BLACS/SRC/BI_svvsum.c
@@ -0,0 +1,7 @@
+#include "Bdef.h"
+void BI_svvsum(int N, char *vec1, char *vec2)
+{
+ float *v1=(float*)vec1, *v2=(float*)vec2;
+ int k;
+ for (k=0; k < N; k++) v1[k] += v2[k];
+}
diff --git a/BLACS/SRC/BI_zMPI_amn.c b/BLACS/SRC/BI_zMPI_amn.c
new file mode 100644
index 0000000..09ebd67
--- /dev/null
+++ b/BLACS/SRC/BI_zMPI_amn.c
@@ -0,0 +1,9 @@
+#include "Bdef.h"
+
+void BI_zMPI_amn(void *in, void *inout, int *N, MPI_Datatype *dtype)
+{
+ void BI_zvvamn(int, char *, char *);
+ extern BLACBUFF BI_AuxBuff;
+
+ BI_zvvamn(BI_AuxBuff.Len, inout, in);
+}
diff --git a/BLACS/SRC/BI_zMPI_amn2.c b/BLACS/SRC/BI_zMPI_amn2.c
new file mode 100644
index 0000000..a00f831
--- /dev/null
+++ b/BLACS/SRC/BI_zMPI_amn2.c
@@ -0,0 +1,6 @@
+#include "Bdef.h"
+void BI_zMPI_amn2(void *in, void *inout, int *N, MPI_Datatype *dtype)
+{
+ void BI_zvvamn2(int, char *, char *);
+ BI_zvvamn2(*N, inout, in);
+}
diff --git a/BLACS/SRC/BI_zMPI_amx.c b/BLACS/SRC/BI_zMPI_amx.c
new file mode 100644
index 0000000..9914517
--- /dev/null
+++ b/BLACS/SRC/BI_zMPI_amx.c
@@ -0,0 +1,9 @@
+#include "Bdef.h"
+
+void BI_zMPI_amx(void *in, void *inout, int *N, MPI_Datatype *dtype)
+{
+ void BI_zvvamx(int, char *, char *);
+ extern BLACBUFF BI_AuxBuff;
+
+ BI_zvvamx(BI_AuxBuff.Len, inout, in);
+}
diff --git a/BLACS/SRC/BI_zMPI_amx2.c b/BLACS/SRC/BI_zMPI_amx2.c
new file mode 100644
index 0000000..e7068cb
--- /dev/null
+++ b/BLACS/SRC/BI_zMPI_amx2.c
@@ -0,0 +1,6 @@
+#include "Bdef.h"
+void BI_zMPI_amx2(void *in, void *inout, int *N, MPI_Datatype *dtype)
+{
+ void BI_zvvamx2(int, char *, char *);
+ BI_zvvamx2(*N, inout, in);
+}
diff --git a/BLACS/SRC/BI_zMPI_sum.c b/BLACS/SRC/BI_zMPI_sum.c
new file mode 100644
index 0000000..63bb313
--- /dev/null
+++ b/BLACS/SRC/BI_zMPI_sum.c
@@ -0,0 +1,6 @@
+#include "Bdef.h"
+void BI_zMPI_sum(void *in, void *inout, int *N, MPI_Datatype *dtype)
+{
+ void BI_zvvsum(int, char *, char *);
+ BI_zvvsum(*N, inout, in);
+}
diff --git a/BLACS/SRC/BI_zvvamn.c b/BLACS/SRC/BI_zvvamn.c
new file mode 100644
index 0000000..1170e5c
--- /dev/null
+++ b/BLACS/SRC/BI_zvvamn.c
@@ -0,0 +1,34 @@
+#include "Bdef.h"
+void BI_zvvamn(int N, char *vec1, char *vec2)
+{
+ DCOMPLEX *v1=(DCOMPLEX*)vec1, *v2=(DCOMPLEX*)vec2;
+ double diff;
+ BI_DistType *dist1, *dist2;
+ int i, k;
+
+ k = N * sizeof(DCOMPLEX);
+ i = k % sizeof(BI_DistType);
+ if (i) k += sizeof(BI_DistType) - i;
+ dist1 = (BI_DistType *) &vec1[k];
+ dist2 = (BI_DistType *) &vec2[k];
+
+ for (k=0; k < N; k++)
+ {
+ diff = Cabs(v1[k]) - Cabs(v2[k]);
+ if (diff > 0)
+ {
+ v1[k].r = v2[k].r;
+ v1[k].i = v2[k].i;
+ dist1[k] = dist2[k];
+ }
+ else if (diff == 0)
+ {
+ if (dist1[k] > dist2[k])
+ {
+ v1[k].r = v2[k].r;
+ v1[k].i = v2[k].i;
+ dist1[k] = dist2[k];
+ }
+ }
+ }
+}
diff --git a/BLACS/SRC/BI_zvvamn2.c b/BLACS/SRC/BI_zvvamn2.c
new file mode 100644
index 0000000..b7ba54b
--- /dev/null
+++ b/BLACS/SRC/BI_zvvamn2.c
@@ -0,0 +1,37 @@
+#include "Bdef.h"
+void BI_zvvamn2(int N, char *vec1, char *vec2)
+{
+ int r, i;
+ double *v1=(double*)vec1, *v2=(double*)vec2;
+ double diff;
+
+ N *= 2;
+ for (r=0, i=1; r != N; r += 2, i += 2)
+ {
+ diff = (Rabs(v1[r]) + Rabs(v1[i])) - (Rabs(v2[r]) + Rabs(v2[i]));
+ if (diff > 0)
+ {
+ v1[r] = v2[r];
+ v1[i] = v2[i];
+ }
+ else if (diff == 0)
+ {
+ if (v1[r] != v2[r])
+ {
+ if (v1[r] < v2[r])
+ {
+ v1[r] = v2[r];
+ v1[i] = v2[i];
+ }
+ }
+ else
+ {
+ if (v1[i] < v2[i])
+ {
+ v1[r] = v2[r];
+ v1[i] = v2[i];
+ }
+ }
+ }
+ }
+}
diff --git a/BLACS/SRC/BI_zvvamx.c b/BLACS/SRC/BI_zvvamx.c
new file mode 100644
index 0000000..02ab1e1
--- /dev/null
+++ b/BLACS/SRC/BI_zvvamx.c
@@ -0,0 +1,34 @@
+#include "Bdef.h"
+void BI_zvvamx(int N, char *vec1, char *vec2)
+{
+ DCOMPLEX *v1=(DCOMPLEX*)vec1, *v2=(DCOMPLEX*)vec2;
+ double diff;
+ BI_DistType *dist1, *dist2;
+ int i, k;
+
+ k = N * sizeof(DCOMPLEX);
+ i = k % sizeof(BI_DistType);
+ if (i) k += sizeof(BI_DistType) - i;
+ dist1 = (BI_DistType *) &vec1[k];
+ dist2 = (BI_DistType *) &vec2[k];
+
+ for (k=0; k < N; k++)
+ {
+ diff = Cabs(v1[k]) - Cabs(v2[k]);
+ if (diff < 0)
+ {
+ v1[k].r = v2[k].r;
+ v1[k].i = v2[k].i;
+ dist1[k] = dist2[k];
+ }
+ else if (diff == 0)
+ {
+ if (dist1[k] > dist2[k])
+ {
+ v1[k].r = v2[k].r;
+ v1[k].i = v2[k].i;
+ dist1[k] = dist2[k];
+ }
+ }
+ }
+}
diff --git a/BLACS/SRC/BI_zvvamx2.c b/BLACS/SRC/BI_zvvamx2.c
new file mode 100644
index 0000000..05d4905
--- /dev/null
+++ b/BLACS/SRC/BI_zvvamx2.c
@@ -0,0 +1,37 @@
+#include "Bdef.h"
+void BI_zvvamx2(int N, char *vec1, char *vec2)
+{
+ int r, i;
+ double *v1=(double*)vec1, *v2=(double*)vec2;
+ double diff;
+
+ N *= 2;
+ for (r=0, i=1; r != N; r += 2, i += 2)
+ {
+ diff = (Rabs(v1[r]) + Rabs(v1[i])) - (Rabs(v2[r]) + Rabs(v2[i]));
+ if (diff < 0)
+ {
+ v1[r] = v2[r];
+ v1[i] = v2[i];
+ }
+ else if (diff == 0)
+ {
+ if (v1[r] != v2[r])
+ {
+ if (v1[r] < v2[r])
+ {
+ v1[r] = v2[r];
+ v1[i] = v2[i];
+ }
+ }
+ else
+ {
+ if (v1[i] < v2[i])
+ {
+ v1[r] = v2[r];
+ v1[i] = v2[i];
+ }
+ }
+ }
+ }
+}
diff --git a/BLACS/SRC/BI_zvvsum.c b/BLACS/SRC/BI_zvvsum.c
new file mode 100644
index 0000000..1be624b
--- /dev/null
+++ b/BLACS/SRC/BI_zvvsum.c
@@ -0,0 +1,8 @@
+#include "Bdef.h"
+void BI_zvvsum(int N, char *vec1, char *vec2)
+{
+ double *v1=(double*)vec1, *v2=(double*)vec2;
+ int k;
+ N *=2;
+ for (k=0; k < N; k++) v1[k] += v2[k];
+}
diff --git a/BLACS/SRC/Bconfig.h b/BLACS/SRC/Bconfig.h
new file mode 100644
index 0000000..521c701
--- /dev/null
+++ b/BLACS/SRC/Bconfig.h
@@ -0,0 +1,106 @@
+/*
+ * This file includes the standard C libraries, as well as system dependant
+ * include files. All BLACS routines include this file.
+ */
+
+#ifndef BCONFIG_H
+#define BCONFIG_H 1
+
+/*
+ * Include files
+ */
+#include <stdlib.h>
+#include <stdio.h>
+#include <math.h>
+#include <stdarg.h>
+#include <mpi.h>
+
+/*
+ * These macros define the naming strategy needed for a fortran
+ * routine to call a C routine, and whether to build so they may be
+ * called from C or fortran. For the fortran call C interface, ADD_ assumes that
+ * fortran calls expect C routines to have an underscore postfixed to the name
+ * (Suns, and the Intel expect this). NOCHANGE indicates that fortran expects
+ * the name called by fortran to be identical to that compiled by C
+ * (AIX does this). UPCASE says it expects C routines called by fortran
+ * to be in all upcase (CRAY wants this). The variable FORTRAN_CALL_C is always
+ * set to one of these values. If the BLACS will be called from C, we define
+ * INTFACE to be CALL_C, otherwise, it is set to FORTRAN_CALL_C.
+ */
+#define ADD_ 0
+#define NOCHANGE 1
+#define UPCASE 2
+#define FCISF2C 3
+#define C_CALL 4
+
+#ifdef UpCase
+#define FORTRAN_CALL_C UPCASE
+#endif
+
+#ifdef NoChange
+#define FORTRAN_CALL_C NOCHANGE
+#endif
+
+#ifdef Add_
+#define FORTRAN_CALL_C ADD_
+#endif
+
+#ifdef FortranIsF2C
+#define FORTRAN_CALL_C FCISF2C
+#endif
+
+#ifndef FORTRAN_CALL_C
+#define FORTRAN_CALL_C ADD_
+#endif
+
+#ifdef CallFromC
+#define INTFACE C_CALL
+#else
+#define INTFACE FORTRAN_CALL_C
+#endif
+
+/*
+ * Uncomment these macro definitions, and substitute the topology of your
+ * choice to vary the default topology (TOP = ' ') for broadcast and combines.
+#define DefBSTop '1'
+#define DefCombTop '1'
+ */
+
+/*
+ * Uncomment this line if your MPI_Send provides a locally-blocking send
+ */
+/* #define SndIsLocBlk */
+
+/*
+ * Comment out the following line if your MPI does a data copy on every
+ * non-contiguous send
+ */
+#ifndef NoMpiBuff
+#define MpiBuffGood
+#endif
+
+/*
+ * If your MPI cannot form data types of zero length, uncomment the
+ * following definition
+ */
+/* #define ZeroByteTypeBug */
+
+/*
+ * These macros set the timing and debug levels for the BLACS. The fastest
+ * code is produced by setting both values to 0. Higher levels provide
+ * more timing/debug information at the cost of performance. Present levels
+ * of debug are:
+ * 0 : No debug information
+ * 1 : Mainly parameter checking.
+ *
+ * Present levels of timing are:
+ * 0 : No timings taken
+ */
+#ifndef BlacsDebugLvl
+#define BlacsDebugLvl 0
+#endif
+#ifndef BlacsTimingLvl
+#define BlacsTimingLvl 0
+#endif
+
+#endif
diff --git a/BLACS/SRC/Bdef.h b/BLACS/SRC/Bdef.h
new file mode 100644
index 0000000..2cdc7e9
--- /dev/null
+++ b/BLACS/SRC/Bdef.h
@@ -0,0 +1,527 @@
+#ifndef BDEF_H
+#define BDEF_H 1
+
+/*
+ * Include the system dependant and user defined stuff
+ */
+#include "Bconfig.h"
+
+/*
+ * Data type defining a scope for the BLACS
+ */
+typedef struct bLaCsScOpE BLACSSCOPE;
+struct bLaCsScOpE
+{
+ MPI_Comm comm;
+ int ScpId, MaxId, MinId;
+ int Np, Iam;
+};
+/*
+ * Data type defining a context for the BLACS
+ */
+typedef struct bLaCsCoNtExT BLACSCONTEXT;
+struct bLaCsCoNtExT
+{
+ BLACSSCOPE rscp, cscp, ascp, pscp; /* row, column, all, and pt2pt scopes */
+ BLACSSCOPE *scp; /* pointer to present scope */
+ int TopsRepeat; /* Use only repeatable topologies? */
+ int TopsCohrnt; /* Use only coherent topologies? */
+ int Nb_bs, Nr_bs; /* for bcast general tree and multiring tops */
+ int Nb_co, Nr_co; /* for combine general tree and multiring tops */
+};
+
+/*
+ * Define the fortran data types COMPLEX*8 (SCOMPLEX)
+ * and COMPLEX*16 (DCOMPLEX).
+ */
+typedef struct {double r, i;} DCOMPLEX;
+typedef struct {float r, i;} SCOMPLEX;
+
+/*
+ * These variables will be defined to be MPI datatypes for complex and double
+ * complex if we are using the C interface to MPI. If we use the fortran
+ * interface, we need to declare the contants array. I'm too lazy to declare
+ * these guys external in every file that needs them.
+ */
+#ifndef GlobalVars
+ extern int *BI_COMM_WORLD;
+#endif
+
+/*
+ * Definition of buffer type for BLACS' asynchronous operations
+ */
+typedef struct bLaCbUfF BLACBUFF;
+struct bLaCbUfF
+{
+ char *Buff; /* send/recv buffer */
+ int Len; /* length of buffer in bytes */
+ int nAops; /* number of asynchronous operations out of buff */
+ MPI_Request *Aops; /* list of async. operations out of buff */
+ MPI_Datatype dtype; /* data type of buffer */
+ int N; /* number of elements of data type in buff */
+ BLACBUFF *prev, *next; /* pointer to the other BLACBUFF in queue */
+};
+
+/*
+ * Pointer to the combine's vector-vector functions
+ */
+typedef void (*VVFUNPTR)(int, char *, char *);
+typedef void (*SDRVPTR)(BLACSCONTEXT *, int, int, BLACBUFF *);
+
+
+#define BI_DistType unsigned short
+#define BI_MpiDistType MPI_UNSIGNED_SHORT
+
+#define BUFFALIGN 8 /* force all buffers to 8 byte alignment */
+#define BANYNODE MPI_ANY_SOURCE
+#define PT2PTID 9976 /* TAG used for point to point */
+#define NOTINCONTEXT -1 /* Indicates node called gridmap, but not in grid */
+#define MAXNCTXT 10 /* initial guess at max # of contexts */
+#define MAXNSYSCTXT 10 /* initial guess at max # of system context */
+#define AOPDONE MPI_REQUEST_NULL
+#define BUFWAIT 120 /* Length of time to wait for emergency buff */
+
+/*
+ * Error codes
+ */
+#define NORV 1 /* No receiver (only 1 proc in scoped op) */
+#define NPOW2 2 /* Number of procs is not a power of 2 */
+#define BADSCP 3 /* Scope not row, column or all */
+
+/*
+ * Data types
+ */
+#define INTEGER 3
+#define SINGLE 4
+#define DOUBLE 6
+#define COMPLEX8 5
+#define COMPLEX16 7
+
+#define FULLCON 0 /* top is fully connected */
+
+/*
+ * Routine types
+ */
+#define RT_SD 1
+#define RT_RV 2
+#define RT_BS 3
+#define RT_BR 4
+#define RT_COMB 5
+
+/*
+ * Legal WHAT values for BLACS_SET
+ */
+#define SGET_SYSCONTXT 0
+#define SGET_MSGIDS 1
+#define SGET_DEBUGLVL 2
+#define SGET_BLACSCONTXT 10
+#define SGET_NR_BS 11
+#define SGET_NB_BS 12
+#define SGET_NR_CO 13
+#define SGET_NB_CO 14
+#define SGET_TOPSREPEAT 15
+#define SGET_TOPSCOHRNT 16
+
+/*
+ * These are prototypes for error and warning functions -- I don't want
+ * to prototype them in each routine.
+ */
+void BI_BlacsWarn(int ConTxt, int line, char *file, char *form, ...);
+void BI_BlacsErr(int ConTxt, int line, char *file, char *form, ...);
+int BI_ContxtNum(BLACSCONTEXT *ctxt);
+
+/*
+ * If we've got an ANSI standard C compiler, we can use void pointers...
+ */
+#define BVOID void
+
+
+/*
+ * ========================================================================
+ * PREPROCESSOR MACRO FUNCTIONS USED FOR OPTIMIZATION & CONVENIENCE
+ * ========================================================================
+ */
+
+#define Mlowcase(C) ( ((C) > 64 && (C) < 91) ? (C) | 32 : (C) )
+
+/*
+ * Slightly modified gridinfo substitute
+ */
+#define Mgridinfo(ctxt, Ng0, nprow0, npcol0, myrow0, mycol0)\
+{\
+ (Ng0) = (ctxt)->ascp.Np;\
+ (nprow0) = (ctxt)->cscp.Np;\
+ (npcol0) = (ctxt)->rscp.Np;\
+ (myrow0) = (ctxt)->cscp.Iam;\
+ (mycol0) = (ctxt)->rscp.Iam;\
+}
+
+/*
+ * These routines return coordinates based on nodes number, or node number
+ * based on coordinates. Those routines with v after the M return virtual
+ * nodes numbers (i.e., in respect to the grid, not physical node numbers)
+ * based on grid coordinates, or grid coordinates based on virtual node numbers.
+ */
+#define Mpcoord(ctxt, node, prow, pcol)\
+{\
+ (prow) = (node) / (ctxt)->rscp.Np;\
+ (pcol) = (node) % (ctxt)->rscp.Np;\
+}
+#define Mvpcoord(ctxt, node, prow, pcol) \
+ Mpcoord((ctxt), (node), (prow), (pcol));
+
+#define Mkpnum(ctxt, prow, pcol) ( (prow)*(ctxt)->rscp.Np+(pcol) )
+#define Mvkpnum(ctxt, prow, pcol) ( (prow)*(ctxt)->rscp.Np+(pcol) )
+
+/*
+ * This macro returns scoped message ID's.
+ */
+#define Mscopeid(ctxt) (ctxt)->scp->ScpId; \
+ if (++(ctxt)->scp->ScpId == (ctxt)->scp->MaxId) \
+ (ctxt)->scp->ScpId = (ctxt)->scp->MinId;
+
+/*
+ * Get context, and check for validity if debug level is high
+ */
+#if (BlacsDebugLvl > 0)
+#define MGetConTxt(Context, ctxtptr)\
+{\
+ extern BLACSCONTEXT **BI_MyContxts;\
+ extern int BI_MaxNCtxt;\
+ if ( ((Context) >= BI_MaxNCtxt) || ((Context) < 0) )\
+ BI_BlacsErr(-1, __LINE__, __FILE__, "Invalid context handle: %d",\
+ (Context));\
+ else if (BI_MyContxts[(Context)] == NULL)\
+ BI_BlacsErr(-1, __LINE__, __FILE__, "Invalid context, handle=%d",\
+ (Context));\
+ (ctxtptr) = BI_MyContxts[(Context)];\
+}
+#else
+#define MGetConTxt(Context, ctxtptr)\
+{\
+ extern BLACSCONTEXT **BI_MyContxts;\
+ (ctxtptr) = BI_MyContxts[(Context)];\
+}
+#endif
+/*
+ * This macro handles MPI errors
+ */
+#if(BlacsDebugLvl > 0)
+#define Mmpierror(ierr, rout, ctxt, line, file) \
+{ \
+ if ( (ierr) != BI_MPI_SUCCESS )\
+ BI_BlacsErr(BI_ContxtNum((ctxt)), (line), (file), \
+ "MPI error %d on call to %s", (ierr), (rout)); \
+}
+#else
+#define Mmpierror(ierr, rout, ctxt, line, file)
+#endif
+/*
+ * A small macro useful for debugging
+ */
+#define ErrPrint \
+{ \
+ extern int BI_Iam; \
+ fprintf(stderr, "%d: line %d of file %s\n", BI_Iam, __LINE__, __FILE__); \
+}
+
+/*
+ * These macros allow for the funky function declarations and character handling
+ * needed on the CRAY to have a C routine callable from fortran
+ */
+#define F_VOID_FUNC void
+#define F_INT_FUNC int
+#define F_DOUBLE_FUNC double
+
+#if (INTFACE == C_CALL)
+
+#define F2C_CharTrans(c) *(c)
+
+#else
+
+#ifdef CRAY
+#define F2C_CharTrans(c) *( _fcdtocp((c)) )
+#define F_CHAR _fcd
+#else
+#define F2C_CharTrans(c) *(c)
+#define F_CHAR char *
+#endif
+
+#endif
+
+/*
+ * These macros allow for accessing values and addresses of parameters, which
+ * will be pointers if we're using fortran, and values if we're using C.
+ */
+#if (INTFACE == C_CALL)
+#define Mpval(para) (para)
+#define Mpaddress(para) (&(para))
+#define Mwalltime Cdwalltime00
+#else
+#define Mpval(para) (*(para))
+#define Mpaddress(para) (para)
+#define Mwalltime dwalltime00_
+#endif
+
+/*
+ * Real and complex absolute values
+ */
+#define Rabs(x) ( (x) < 0 ? (x) * -1 : (x) )
+#define Cabs(z) ( (((z).i) < 0 ? ((z).i) * -1 : ((z).i)) + (((z).r) < 0 ? ((z).r) * -1 : ((z).r)) )
+
+/*
+ * Figures the length of packed trapezoidal matrix
+ */
+#define trsize(diag, m, n, bytes, length)\
+{\
+ if ( (diag) == 'u' ) (length) = 1;\
+ else (length) = 0;\
+ if ( (m) > (n) )\
+ (length) = ( (n) * ( (m) - (n) ) + ( (n)*(n) ) - ( (n)*(n) )/2 +\
+ (n)/2 - (n) * (length) ) * (bytes);\
+ else\
+ (length) = ( (m) * ( (n) - (m) ) + ( (m)*(m) ) - ( (m)*(m) )/2 +\
+ (m)/2 - (m) * (length) ) * (bytes);\
+}
+
+/*
+ * These macros call the correct packing/unpacking routines
+ */
+#define BI_cmvcopy(m, n, A, lda, buff) \
+ BI_smvcopy(2*(m), (n), (float *) (A), 2*(lda), (float *) (buff))
+#define BI_cvmcopy(m, n, A, lda, buff) \
+ BI_svmcopy(2*(m), (n), (float *) (A), 2*(lda), (float *) (buff))
+#define BI_zmvcopy(m, n, A, lda, buff) \
+ BI_dmvcopy(2*(m), (n), (double *) (A), 2*(lda), (double *) (buff))
+#define BI_zvmcopy(m, n, A, lda, buff) \
+ BI_dvmcopy(2*(m), (n), (double *) (A), 2*(lda), (double *) (buff))
+
+/*
+ * This macro avoids freeing types when the zero-byte workaround was applied
+ */
+#ifdef ZeroByteTypeBug
+#define BI_MPI_TYPE_FREE(t) (*(t) != MPI_BYTE ? MPI_Type_free(t) : 0)
+#else
+#define BI_MPI_TYPE_FREE(t) MPI_Type_free(t)
+#endif
+
+#if (FORTRAN_CALL_C == NOCHANGE)
+/*
+ * These defines set up the naming scheme required to have a fortran
+ * routine call a C routine (which is what the BLACS are written in)
+ * for the following Fortran to C interface:
+ * FORTRAN CALL C DECLARATION
+ * call dgebs2d(...) void dgebs2d(...)
+ */
+
+/*
+ * Support routines
+ */
+#define blacs_pinfo_ blacs_pinfo
+#define blacs_setup_ blacs_setup
+#define setpvmtids_ setpvmtids
+#define blacs_set_ blacs_set
+#define blacs_get_ blacs_get
+#define blacs_gridinit_ blacs_gridinit
+#define blacs_gridmap_ blacs_gridmap
+#define ksendid_ ksendid
+#define krecvid_ krecvid
+#define kbsid_ kbsid
+#define kbrid_ kbrid
+#define blacs_freebuff_ blacs_freebuff
+#define blacs_gridexit_ blacs_gridexit
+#define blacs_abort_ blacs_abort
+#define blacs_exit_ blacs_exit
+#define blacs_gridinfo_ blacs_gridinfo
+#define blacs_pnum_ blacs_pnum
+#define blacs_pcoord_ blacs_pcoord
+#define dcputime00_ dcputime00
+#define dwalltime00_ dwalltime00
+#define blacs_barrier_ blacs_barrier
+
+/*
+ * Main, type dependent, routines
+ */
+#define igesd2d_ igesd2d
+#define igerv2d_ igerv2d
+#define igebs2d_ igebs2d
+#define igebr2d_ igebr2d
+#define itrsd2d_ itrsd2d
+#define itrrv2d_ itrrv2d
+#define itrbs2d_ itrbs2d
+#define itrbr2d_ itrbr2d
+#define igsum2d_ igsum2d
+#define igamx2d_ igamx2d
+#define igamn2d_ igamn2d
+#define sgesd2d_ sgesd2d
+#define sgerv2d_ sgerv2d
+#define sgebs2d_ sgebs2d
+#define sgebr2d_ sgebr2d
+#define strsd2d_ strsd2d
+#define strrv2d_ strrv2d
+#define strbs2d_ strbs2d
+#define strbr2d_ strbr2d
+#define sgsum2d_ sgsum2d
+#define sgamx2d_ sgamx2d
+#define sgamn2d_ sgamn2d
+#define dgesd2d_ dgesd2d
+#define dgerv2d_ dgerv2d
+#define dgebs2d_ dgebs2d
+#define dgebr2d_ dgebr2d
+#define dtrsd2d_ dtrsd2d
+#define dtrrv2d_ dtrrv2d
+#define dtrbs2d_ dtrbs2d
+#define dtrbr2d_ dtrbr2d
+#define dgsum2d_ dgsum2d
+#define dgamx2d_ dgamx2d
+#define dgamn2d_ dgamn2d
+#define cgesd2d_ cgesd2d
+#define cgerv2d_ cgerv2d
+#define cgebs2d_ cgebs2d
+#define cgebr2d_ cgebr2d
+#define ctrsd2d_ ctrsd2d
+#define ctrrv2d_ ctrrv2d
+#define ctrbs2d_ ctrbs2d
+#define ctrbr2d_ ctrbr2d
+#define cgsum2d_ cgsum2d
+#define cgamx2d_ cgamx2d
+#define cgamn2d_ cgamn2d
+#define zgesd2d_ zgesd2d
+#define zgerv2d_ zgerv2d
+#define zgebs2d_ zgebs2d
+#define zgebr2d_ zgebr2d
+#define ztrsd2d_ ztrsd2d
+#define ztrrv2d_ ztrrv2d
+#define ztrbs2d_ ztrbs2d
+#define ztrbr2d_ ztrbr2d
+#define zgsum2d_ zgsum2d
+#define zgamx2d_ zgamx2d
+#define zgamn2d_ zgamn2d
+
+#elif (FORTRAN_CALL_C == UPCASE)
+/*
+ * These defines set up the naming scheme required to have a fortran
+ * routine call a C routine (which is what the BLACS are written in)
+ * for the following Fortran to C interface:
+ * FORTRAN CALL C DECLARATION
+ * call dgebs2d(...) void DGEBS2D(...)
+ */
+/*
+ * Support routines
+ */
+#define blacs_pinfo_ BLACS_PINFO
+#define blacs_setup_ BLACS_SETUP
+#define setpvmtids_ SETPVMTIDS
+#define blacs_set_ BLACS_SET
+#define blacs_get_ BLACS_GET
+#define blacs_gridinit_ BLACS_GRIDINIT
+#define blacs_gridmap_ BLACS_GRIDMAP
+#define ksendid_ KSENDID
+#define krecvid_ KRECVID
+#define kbsid_ KBSID
+#define kbrid_ KBRID
+#define blacs_freebuff_ BLACS_FREEBUFF
+#define blacs_gridexit_ BLACS_GRIDEXIT
+#define blacs_abort_ BLACS_ABORT
+#define blacs_exit_ BLACS_EXIT
+#define blacs_gridinfo_ BLACS_GRIDINFO
+#define blacs_pnum_ BLACS_PNUM
+#define blacs_pcoord_ BLACS_PCOORD
+#define dcputime00_ DCPUTIME00
+#define dwalltime00_ DWALLTIME00
+#define blacs_barrier_ BLACS_BARRIER
+
+/*
+ * Main, type dependent, routines
+ */
+#define igesd2d_ IGESD2D
+#define igerv2d_ IGERV2D
+#define igebs2d_ IGEBS2D
+#define igebr2d_ IGEBR2D
+#define itrsd2d_ ITRSD2D
+#define itrrv2d_ ITRRV2D
+#define itrbs2d_ ITRBS2D
+#define itrbr2d_ ITRBR2D
+#define igsum2d_ IGSUM2D
+#define igamx2d_ IGAMX2D
+#define igamn2d_ IGAMN2D
+#define sgesd2d_ SGESD2D
+#define sgerv2d_ SGERV2D
+#define sgebs2d_ SGEBS2D
+#define sgebr2d_ SGEBR2D
+#define strsd2d_ STRSD2D
+#define strrv2d_ STRRV2D
+#define strbs2d_ STRBS2D
+#define strbr2d_ STRBR2D
+#define sgsum2d_ SGSUM2D
+#define sgamx2d_ SGAMX2D
+#define sgamn2d_ SGAMN2D
+#define dgesd2d_ DGESD2D
+#define dgerv2d_ DGERV2D
+#define dgebs2d_ DGEBS2D
+#define dgebr2d_ DGEBR2D
+#define dtrsd2d_ DTRSD2D
+#define dtrrv2d_ DTRRV2D
+#define dtrbs2d_ DTRBS2D
+#define dtrbr2d_ DTRBR2D
+#define dgsum2d_ DGSUM2D
+#define dgamx2d_ DGAMX2D
+#define dgamn2d_ DGAMN2D
+#define cgesd2d_ CGESD2D
+#define cgerv2d_ CGERV2D
+#define cgebs2d_ CGEBS2D
+#define cgebr2d_ CGEBR2D
+#define ctrsd2d_ CTRSD2D
+#define ctrrv2d_ CTRRV2D
+#define ctrbs2d_ CTRBS2D
+#define ctrbr2d_ CTRBR2D
+#define cgsum2d_ CGSUM2D
+#define cgamx2d_ CGAMX2D
+#define cgamn2d_ CGAMN2D
+#define zgesd2d_ ZGESD2D
+#define zgerv2d_ ZGERV2D
+#define zgebs2d_ ZGEBS2D
+#define zgebr2d_ ZGEBR2D
+#define ztrsd2d_ ZTRSD2D
+#define ztrrv2d_ ZTRRV2D
+#define ztrbs2d_ ZTRBS2D
+#define ztrbr2d_ ZTRBR2D
+#define zgsum2d_ ZGSUM2D
+#define zgamx2d_ ZGAMX2D
+#define zgamn2d_ ZGAMN2D
+
+#elif (FORTRAN_CALL_C == FCISF2C)
+/*
+ * These defines set up the naming scheme required to have a fortran
+ * routine call a C routine (which is what the BLACS are written in)
+ * for systems where the fortran "compiler" is actually f2c (a fortran
+ * to C conversion utility).
+ */
+/*
+ * Initialization routines
+ */
+#define blacs_pinfo_ blacs_pinfo__
+#define blacs_setup_ blacs_setup__
+#define blacs_set_ blacs_set__
+#define blacs_get_ blacs_get__
+#define blacs_gridinit_ blacs_gridinit__
+#define blacs_gridmap_ blacs_gridmap__
+/*
+ * Destruction routines
+ */
+#define blacs_freebuff_ blacs_freebuff__
+#define blacs_gridexit_ blacs_gridexit__
+#define blacs_abort_ blacs_abort__
+#define blacs_exit_ blacs_exit__
+/*
+ * Informational & misc.
+ */
+#define blacs_gridinfo_ blacs_gridinfo__
+#define blacs_pnum_ blacs_pnum__
+#define blacs_pcoord_ blacs_pcoord__
+#define blacs_barrier_ blacs_barrier__
+
+#endif
+
+
+#endif
diff --git a/BLACS/SRC/CMakeLists.txt b/BLACS/SRC/CMakeLists.txt
new file mode 100644
index 0000000..e29d39d
--- /dev/null
+++ b/BLACS/SRC/CMakeLists.txt
@@ -0,0 +1,84 @@
+# --------------------------
+# The communication routines
+# --------------------------
+set (comm
+ igesd2d_.c sgesd2d_.c dgesd2d_.c cgesd2d_.c zgesd2d_.c
+ itrsd2d_.c strsd2d_.c dtrsd2d_.c ctrsd2d_.c ztrsd2d_.c
+ igerv2d_.c sgerv2d_.c dgerv2d_.c cgerv2d_.c zgerv2d_.c
+ itrrv2d_.c strrv2d_.c dtrrv2d_.c ctrrv2d_.c ztrrv2d_.c
+ igebs2d_.c sgebs2d_.c dgebs2d_.c cgebs2d_.c zgebs2d_.c
+ igebr2d_.c sgebr2d_.c dgebr2d_.c cgebr2d_.c zgebr2d_.c
+ itrbs2d_.c strbs2d_.c dtrbs2d_.c ctrbs2d_.c ztrbs2d_.c
+ itrbr2d_.c strbr2d_.c dtrbr2d_.c ctrbr2d_.c ztrbr2d_.c
+ igsum2d_.c sgsum2d_.c dgsum2d_.c cgsum2d_.c zgsum2d_.c
+ igamx2d_.c sgamx2d_.c dgamx2d_.c cgamx2d_.c zgamx2d_.c
+ igamn2d_.c sgamn2d_.c dgamn2d_.c cgamn2d_.c zgamn2d_.c)
+
+# --------------------
+# The support routines
+# --------------------
+set (supp
+ blacs_setup_.c blacs_set_.c blacs_get_.c
+ blacs_abort_.c blacs_exit_.c blacs_pnum_.c blacs_pcoord_.c
+ ksendid_.c krecvid_.c kbsid_.c kbrid_.c
+ dcputime00_.c dwalltime00_.c blacs_pinfo_.c
+ blacs_init_.c blacs_map_.c blacs_free_.c blacs_grid_.c blacs_info_.c
+ blacs_barr_.c sys2blacs_.c blacs2sys_.c free_handle_.c)
+
+# ---------------------
+# The internal routines
+# ---------------------
+set (internal
+ BI_HypBS.c BI_HypBR.c BI_IdringBS.c BI_IdringBR.c
+ BI_MpathBS.c BI_MpathBR.c BI_SringBS.c BI_SringBR.c
+ BI_TreeBS.c BI_TreeBR.c
+ BI_Ssend.c BI_Rsend.c BI_Srecv.c BI_Asend.c BI_Arecv.c
+ BI_TreeComb.c BI_BeComb.c BI_MringComb.c
+ BI_ArgCheck.c BI_TransDist.c BI_GetBuff.c BI_UpdateBuffs.c
+ BI_EmergencyBuff.c BI_BlacsErr.c BI_BlacsWarn.c BI_BlacsAbort.c
+ BI_BuffIsFree.c BI_imvcopy.c BI_smvcopy.c BI_dmvcopy.c
+ BI_ivmcopy.c BI_svmcopy.c BI_dvmcopy.c
+ BI_Pack.c BI_Unpack.c BI_GetMpiGeType.c BI_GetMpiTrType.c
+ BI_ivvsum.c BI_svvsum.c BI_dvvsum.c BI_cvvsum.c BI_zvvsum.c
+ BI_ivvamx.c BI_svvamx.c BI_dvvamx.c BI_cvvamx.c BI_zvvamx.c
+ BI_ivvamx2.c BI_svvamx2.c BI_dvvamx2.c BI_cvvamx2.c BI_zvvamx2.c
+ BI_ivvamn.c BI_svvamn.c BI_dvvamn.c BI_cvvamn.c BI_zvvamn.c
+ BI_ivvamn2.c BI_svvamn2.c BI_dvvamn2.c BI_cvvamn2.c BI_zvvamn2.c
+ BI_iMPI_amx.c BI_sMPI_amx.c BI_dMPI_amx.c BI_cMPI_amx.c
+ BI_zMPI_amx.c BI_iMPI_amx2.c BI_sMPI_amx2.c BI_dMPI_amx2.c
+ BI_cMPI_amx2.c BI_zMPI_amx2.c BI_iMPI_amn.c BI_sMPI_amn.c
+ BI_dMPI_amn.c BI_cMPI_amn.c BI_zMPI_amn.c BI_iMPI_amn2.c
+ BI_sMPI_amn2.c BI_dMPI_amn2.c BI_cMPI_amn2.c BI_zMPI_amn2.c
+ BI_cMPI_sum.c BI_zMPI_sum.c BI_ContxtNum.c BI_GlobalVars.c
+ BI_TransUserComm.c )
+
+
+#
+# Note on CMAKE (from Brad - Kitware)
+#
+#CMake hides the intermediate object files from its interface so there is
+#no direct way to do this within a single target. This limitation comes
+#from the requirement to support generation of build systems like VS IDE
+#project files that do not expose object files explicitly.
+
+# Solution 1 : Build separate libraries, one for each block of objects
+#set(blacsFint ${comm} ${supp})
+#add_library(blacsCint ${comm} ${supp})
+#set_property(TARGET blacsCint PROPERTY COMPILE_DEFINITIONS CallFromC)
+#add_library(scalapack ${internal} ${blacsFint})
+#target_link_libraries(scalapack blacsCint)
+
+# Solution 2 : Create an extra source file that #include-s the original one
+set(srcs ${comm} ${supp})
+set(srcs_C)
+foreach(src ${srcs})
+# string(REPLACE ".c" "-C.c" src_C "${CMAKE_CURRENT_BINARY_DIR}/${src}")
+ string(REPLACE ".c" "-C.c" src_C "${src}")
+ configure_file(src-C.c.in ${src_C} @ONLY)
+ list(APPEND srcs_C ${src_C})
+endforeach()
+
+set(blacs ${srcs} ${srcs_C} ${internal})
+#add_library(scalapack ${srcs} ${srcs_C} ${internal})
+#scalapack_install_library(scalapack)
+
diff --git a/BLACS/SRC/Makefile b/BLACS/SRC/Makefile
new file mode 100644
index 0000000..21fc911
--- /dev/null
+++ b/BLACS/SRC/Makefile
@@ -0,0 +1,93 @@
+dlvl = ../..
+include $(dlvl)/SLmake.inc
+
+# --------------------------
+# The communication routines
+# --------------------------
+comm = igesd2d_.o sgesd2d_.o dgesd2d_.o cgesd2d_.o zgesd2d_.o \
+ itrsd2d_.o strsd2d_.o dtrsd2d_.o ctrsd2d_.o ztrsd2d_.o \
+ igerv2d_.o sgerv2d_.o dgerv2d_.o cgerv2d_.o zgerv2d_.o \
+ itrrv2d_.o strrv2d_.o dtrrv2d_.o ctrrv2d_.o ztrrv2d_.o \
+ igebs2d_.o sgebs2d_.o dgebs2d_.o cgebs2d_.o zgebs2d_.o \
+ igebr2d_.o sgebr2d_.o dgebr2d_.o cgebr2d_.o zgebr2d_.o \
+ itrbs2d_.o strbs2d_.o dtrbs2d_.o ctrbs2d_.o ztrbs2d_.o \
+ itrbr2d_.o strbr2d_.o dtrbr2d_.o ctrbr2d_.o ztrbr2d_.o \
+ igsum2d_.o sgsum2d_.o dgsum2d_.o cgsum2d_.o zgsum2d_.o \
+ igamx2d_.o sgamx2d_.o dgamx2d_.o cgamx2d_.o zgamx2d_.o \
+ igamn2d_.o sgamn2d_.o dgamn2d_.o cgamn2d_.o zgamn2d_.o
+
+# --------------------
+# The support routines
+# --------------------
+supp = blacs_setup_.o blacs_set_.o blacs_get_.o \
+ blacs_abort_.o blacs_exit_.o blacs_pnum_.o blacs_pcoord_.o \
+ ksendid_.o krecvid_.o kbsid_.o kbrid_.o \
+ dcputime00_.o dwalltime00_.o blacs_pinfo_.o \
+ blacs_init_.o blacs_map_.o blacs_free_.o blacs_grid_.o blacs_info_.o \
+ blacs_barr_.o sys2blacs_.o blacs2sys_.o free_handle_.o
+
+
+# ----------------------------
+# The fortran and C interfaces
+# ----------------------------
+Fintobj = $(comm) $(supp)
+Cintobj = $(comm:.o=.oo) $(supp:.o=.oo)
+
+# ---------------------
+# The internal routines
+# ---------------------
+internal = BI_HypBS.o BI_HypBR.o BI_IdringBS.o BI_IdringBR.o \
+ BI_MpathBS.o BI_MpathBR.o BI_SringBS.o BI_SringBR.o \
+ BI_TreeBS.o BI_TreeBR.o \
+ BI_Ssend.o BI_Rsend.o BI_Srecv.o BI_Asend.o BI_Arecv.o \
+ BI_TreeComb.o BI_BeComb.o BI_MringComb.o \
+ BI_ArgCheck.o BI_TransDist.o BI_GetBuff.o BI_UpdateBuffs.o \
+ BI_EmergencyBuff.o BI_BlacsErr.o BI_BlacsWarn.o BI_BlacsAbort.o \
+ BI_BuffIsFree.o BI_imvcopy.o BI_smvcopy.o BI_dmvcopy.o \
+ BI_ivmcopy.o BI_svmcopy.o BI_dvmcopy.o \
+ BI_Pack.o BI_Unpack.o BI_GetMpiGeType.o BI_GetMpiTrType.o \
+ BI_ivvsum.o BI_svvsum.o BI_dvvsum.o BI_cvvsum.o BI_zvvsum.o \
+ BI_ivvamx.o BI_svvamx.o BI_dvvamx.o BI_cvvamx.o BI_zvvamx.o \
+ BI_ivvamx2.o BI_svvamx2.o BI_dvvamx2.o BI_cvvamx2.o BI_zvvamx2.o \
+ BI_ivvamn.o BI_svvamn.o BI_dvvamn.o BI_cvvamn.o BI_zvvamn.o \
+ BI_ivvamn2.o BI_svvamn2.o BI_dvvamn2.o BI_cvvamn2.o BI_zvvamn2.o \
+ BI_iMPI_amx.o BI_sMPI_amx.o BI_dMPI_amx.o BI_cMPI_amx.o \
+ BI_zMPI_amx.o BI_iMPI_amx2.o BI_sMPI_amx2.o BI_dMPI_amx2.o \
+ BI_cMPI_amx2.o BI_zMPI_amx2.o BI_iMPI_amn.o BI_sMPI_amn.o \
+ BI_dMPI_amn.o BI_cMPI_amn.o BI_zMPI_amn.o BI_iMPI_amn2.o \
+ BI_sMPI_amn2.o BI_dMPI_amn2.o BI_cMPI_amn2.o BI_zMPI_amn2.o \
+ BI_cMPI_sum.o BI_zMPI_sum.o BI_ContxtNum.o BI_GlobalVars.o \
+ BI_TransUserComm.o
+
+lib : all
+
+$(internal): Bdef.h Bconfig.h
+
+$(Fintobj): Bdef.h Bconfig.h
+
+# ---------------------------------------
+# Make both C and fortran interface BLACS
+# ---------------------------------------
+all : $(internal) $(Fintobj) $(Cintobj)
+ $(ARCH) $(ARCHFLAGS) ../../$(SCALAPACKLIB) $(internal) $(Fintobj) $(Cintobj)
+ $(RANLIB) ../../$(SCALAPACKLIB)
+
+# -----------------------
+# Delete the object files
+# -----------------------
+clean :
+ rm -f $(Cintobj) $(Fintobj) $(internal)
+
+# ------------------------------------------------------------------------
+# We move C .o files to .oo so that we can use the portable suffix rule for
+# compilation, and still have them coexist with the fortran interface
+# .o files.
+# ------------------------------------------------------------------------
+
+.SUFFIXES: .o .oo
+.c.oo:
+ $(CC) -o C$*.o -c $(CDEFS) $(CCFLAGS) -DCallFromC $<
+ mv C$*.o $*.oo
+.c.o:
+ $(CC) -c $(CDEFS) $(CCFLAGS) $<
+
diff --git a/BLACS/SRC/blacs2sys_.c b/BLACS/SRC/blacs2sys_.c
new file mode 100644
index 0000000..991d743
--- /dev/null
+++ b/BLACS/SRC/blacs2sys_.c
@@ -0,0 +1,30 @@
+#include "Bdef.h"
+#if (INTFACE == C_CALL)
+MPI_Comm Cblacs2sys_handle(int BlacsCtxt)
+#else
+int blacs2sys_handle_(int *BlacsCtxt)
+#endif
+{
+#if (INTFACE == C_CALL)
+ int i[2];
+ extern int BI_MaxNSysCtxt;
+ extern MPI_Comm *BI_SysContxts;
+
+ if (BI_COMM_WORLD == NULL) Cblacs_pinfo(i, &i[1]);
+ if ( (BlacsCtxt >= BI_MaxNSysCtxt) || (BlacsCtxt < 0) )
+ {
+ BI_BlacsErr(-1, __LINE__, __FILE__,
+ "No system context corresponding to BLACS system context handle %d\n",
+ BlacsCtxt);
+ }
+ else if (BI_SysContxts[BlacsCtxt] == MPI_COMM_NULL)
+ {
+ BI_BlacsErr(-1, __LINE__, __FILE__,
+ "No system context corresponding to BLACS system context handle %d\n",
+ BlacsCtxt);
+ }
+ return(BI_SysContxts[BlacsCtxt]);
+#else
+ return(*BlacsCtxt);
+#endif
+}
diff --git a/BLACS/SRC/blacs_abort_.c b/BLACS/SRC/blacs_abort_.c
new file mode 100644
index 0000000..4148e07
--- /dev/null
+++ b/BLACS/SRC/blacs_abort_.c
@@ -0,0 +1,20 @@
+#include "Bdef.h"
+
+#if (INTFACE == C_CALL)
+void Cblacs_abort(int ConTxt, int ErrNo)
+#else
+F_VOID_FUNC blacs_abort_(int *ConTxt, int *ErrNo)
+#endif
+{
+ void Cblacs_gridinfo(int, int *, int *, int *, int *);
+ void BI_BlacsAbort(int ErrNo);
+ int nprow, npcol, myrow, mycol;
+ extern int BI_Iam;
+
+ Cblacs_gridinfo(Mpval(ConTxt), &nprow, &npcol, &myrow, &mycol);
+ fprintf(stderr,
+"{%d,%d}, pnum=%d, Contxt=%d, killed other procs, exiting with error #%d.\n\n",
+ myrow, mycol, BI_Iam, Mpval(ConTxt), Mpval(ErrNo));
+
+ BI_BlacsAbort(Mpval(ErrNo));
+}
diff --git a/BLACS/SRC/blacs_barr_.c b/BLACS/SRC/blacs_barr_.c
new file mode 100644
index 0000000..95edcaf
--- /dev/null
+++ b/BLACS/SRC/blacs_barr_.c
@@ -0,0 +1,28 @@
+#include "Bdef.h"
+
+#if (INTFACE == C_CALL)
+void Cblacs_barrier(int ConTxt, char *scope)
+#else
+F_VOID_FUNC blacs_barrier_(int *ConTxt, F_CHAR scope)
+#endif
+{
+ char tscope;
+ int ierr;
+ BLACSCONTEXT *ctxt;
+
+ tscope = F2C_CharTrans(scope);
+ tscope = Mlowcase(tscope);
+ MGetConTxt(Mpval(ConTxt), ctxt);
+ switch(tscope)
+ {
+ case 'r':
+ MPI_Barrier(ctxt->rscp.comm);
+ break;
+ case 'c':
+ MPI_Barrier(ctxt->cscp.comm);
+ break;
+ case 'a':
+ MPI_Barrier(ctxt->ascp.comm);
+ break;
+ }
+}
diff --git a/BLACS/SRC/blacs_exit_.c b/BLACS/SRC/blacs_exit_.c
new file mode 100644
index 0000000..50ee780
--- /dev/null
+++ b/BLACS/SRC/blacs_exit_.c
@@ -0,0 +1,45 @@
+#include "Bdef.h"
+
+#if (INTFACE == C_CALL)
+void Cblacs_exit(int NotDone)
+#else
+F_VOID_FUNC blacs_exit_(int *NotDone)
+#endif
+{
+ void Cblacs_gridexit(int);
+ void BI_UpdateBuffs(BLACBUFF *);
+ BLACBUFF *BI_GetBuff(int);
+ int BI_BuffIsFree(BLACBUFF *, int);
+ BLACBUFF *bp;
+ extern BLACBUFF *BI_ReadyB, *BI_ActiveQ, BI_AuxBuff;
+ int i;
+ extern int BI_MaxNCtxt, BI_Np;
+ extern BLACSCONTEXT **BI_MyContxts;
+/*
+ * Destroy all contexts
+ */
+ for (i=0; i < BI_MaxNCtxt; i++) if (BI_MyContxts[i]) Cblacs_gridexit(i);
+ free(BI_MyContxts);
+
+ if (BI_ReadyB) free(BI_ReadyB);
+ while (BI_ActiveQ != NULL)
+ {
+ bp = BI_ActiveQ;
+ BI_BuffIsFree(bp, 1); /* wait for async sends to complete */
+ BI_ActiveQ = bp->next;
+ free(bp);
+ }
+ free (BI_AuxBuff.Aops);
+
+/*
+ * Reset parameters to initial values
+ */
+ BI_MaxNCtxt = 0;
+ BI_MyContxts = NULL;
+ BI_Np = -1;
+ if (!Mpval(NotDone))
+ {
+ MPI_Finalize();
+ }
+ BI_ReadyB = NULL;
+}
diff --git a/BLACS/SRC/blacs_free_.c b/BLACS/SRC/blacs_free_.c
new file mode 100644
index 0000000..c499f48
--- /dev/null
+++ b/BLACS/SRC/blacs_free_.c
@@ -0,0 +1,24 @@
+#include "Bdef.h"
+
+#if (INTFACE == C_CALL)
+void Cblacs_freebuff(int ConTxt, int Wait)
+#else
+F_VOID_FUNC blacs_freebuff_(int *ConTxt, int *Wait)
+#endif
+{
+ void BI_UpdateBuffs(BLACBUFF *);
+ int BI_BuffIsFree(BLACBUFF *, int);
+ extern BLACBUFF *BI_ReadyB, *BI_ActiveQ;
+
+ if (Mpval(Wait)) /* wait for all buffers to be done */
+ {
+ while (BI_ActiveQ != NULL) BI_UpdateBuffs(NULL);
+ }
+ else BI_UpdateBuffs(NULL);
+
+ if (BI_ReadyB)
+ {
+ free(BI_ReadyB);
+ BI_ReadyB = NULL;
+ }
+}
diff --git a/BLACS/SRC/blacs_get_.c b/BLACS/SRC/blacs_get_.c
new file mode 100644
index 0000000..e979767
--- /dev/null
+++ b/BLACS/SRC/blacs_get_.c
@@ -0,0 +1,69 @@
+#include "Bdef.h"
+#if (INTFACE == C_CALL)
+void Cblacs_get(int ConTxt, int what, int *val)
+#else
+F_VOID_FUNC blacs_get_(int *ConTxt, int *what, int *val)
+#endif
+{
+ int Csys2blacs_handle(MPI_Comm);
+ int ierr, *iptr;
+ int comm;
+ BLACSCONTEXT *ctxt;
+
+ switch( Mpval(what) )
+ {
+ case SGET_SYSCONTXT:
+ if (BI_COMM_WORLD == NULL) Cblacs_pinfo(val, &ierr);
+#if (INTFACE == C_CALL)
+ *val = Csys2blacs_handle(MPI_COMM_WORLD);
+#else
+ *val = *BI_COMM_WORLD;
+#endif
+ break;
+ case SGET_MSGIDS:
+ if (BI_COMM_WORLD == NULL) Cblacs_pinfo(val, &val[1]);
+ iptr = &val[1];
+ ierr=MPI_Attr_get(MPI_COMM_WORLD, MPI_TAG_UB, (BVOID **) &iptr,val);
+ val[0] = 0;
+ val[1] = *iptr;
+ break;
+ case SGET_DEBUGLVL:
+ *val = BlacsDebugLvl;
+ break;
+ case SGET_BLACSCONTXT:
+ MGetConTxt(Mpval(ConTxt), ctxt);
+#if (INTFACE == C_CALL)
+ *val = Csys2blacs_handle(ctxt->pscp.comm);
+#else /* if user called the fortran interface to the BLACS */
+ *val = MPI_Comm_c2f(ctxt->pscp.comm);
+#endif
+ break;
+ case SGET_NR_BS:
+ MGetConTxt(Mpval(ConTxt), ctxt);
+ *val = ctxt->Nr_bs;
+ break;
+ case SGET_NB_BS:
+ MGetConTxt(Mpval(ConTxt), ctxt);
+ *val = ctxt->Nb_bs - 1;
+ break;
+ case SGET_NR_CO:
+ MGetConTxt(Mpval(ConTxt), ctxt);
+ *val = ctxt->Nr_co;
+ break;
+ case SGET_NB_CO:
+ MGetConTxt(Mpval(ConTxt), ctxt);
+ *val = ctxt->Nb_co - 1;
+ break;
+ case SGET_TOPSREPEAT:
+ MGetConTxt(Mpval(ConTxt), ctxt);
+ *val = ctxt->TopsRepeat;
+ break;
+ case SGET_TOPSCOHRNT:
+ MGetConTxt(Mpval(ConTxt), ctxt);
+ *val = ctxt->TopsCohrnt;
+ break;
+ default:
+ BI_BlacsWarn(Mpval(ConTxt), __LINE__, __FILE__, "Unknown WHAT (%d)",
+ Mpval(what));
+ }
+}
diff --git a/BLACS/SRC/blacs_grid_.c b/BLACS/SRC/blacs_grid_.c
new file mode 100644
index 0000000..df6bd35
--- /dev/null
+++ b/BLACS/SRC/blacs_grid_.c
@@ -0,0 +1,32 @@
+#include "Bdef.h"
+
+#if (INTFACE == C_CALL)
+void Cblacs_gridexit(int ConTxt)
+#else
+F_VOID_FUNC blacs_gridexit_(int *ConTxt)
+#endif
+{
+ int i;
+ BLACSCONTEXT *ctxt;
+ extern int BI_MaxNCtxt;
+ extern BLACSCONTEXT **BI_MyContxts;
+
+ if ( (Mpval(ConTxt) < 0) || (Mpval(ConTxt) >= BI_MaxNCtxt) )
+ BI_BlacsErr(Mpval(ConTxt), __LINE__, __FILE__,
+ "Trying to exit non-existent context");
+
+ if (BI_MyContxts[Mpval(ConTxt)] == NULL)
+ BI_BlacsErr(Mpval(ConTxt), __LINE__, __FILE__,
+ "Trying to exit an already freed context");
+
+ MGetConTxt(Mpval(ConTxt), ctxt);
+/*
+ * Destroy context
+ */
+ MPI_Comm_free(&ctxt->pscp.comm);
+ MPI_Comm_free(&ctxt->ascp.comm);
+ MPI_Comm_free(&ctxt->rscp.comm);
+ MPI_Comm_free(&ctxt->cscp.comm);
+ free(ctxt);
+ BI_MyContxts[Mpval(ConTxt)] = NULL;
+}
diff --git a/BLACS/SRC/blacs_info_.c b/BLACS/SRC/blacs_info_.c
new file mode 100644
index 0000000..961c27b
--- /dev/null
+++ b/BLACS/SRC/blacs_info_.c
@@ -0,0 +1,32 @@
+#include "Bdef.h"
+
+#if (INTFACE == C_CALL)
+void Cblacs_gridinfo(int ConTxt, int *nprow, int *npcol, int *myrow, int *mycol)
+#else
+F_VOID_FUNC blacs_gridinfo_(int *ConTxt, int *nprow, int *npcol,
+ int *myrow, int *mycol)
+#endif
+{
+ extern BLACSCONTEXT **BI_MyContxts;
+ extern int BI_MaxNCtxt;
+ BLACSCONTEXT *ctxt;
+/*
+ * Make sure context handle is in range
+ */
+ if ( (Mpval(ConTxt) >= 0) && (Mpval(ConTxt) < BI_MaxNCtxt) )
+ {
+/*
+ * Make sure context is still defined
+ */
+ ctxt = BI_MyContxts[Mpval(ConTxt)];
+ if (ctxt != NULL)
+ {
+ *nprow = ctxt->cscp.Np;
+ *npcol = ctxt->rscp.Np;
+ *myrow = ctxt->cscp.Iam;
+ *mycol = ctxt->rscp.Iam;
+ }
+ else *nprow = *npcol = *myrow = *mycol = -1;
+ }
+ else *nprow = *npcol = *myrow = *mycol = -1;
+}
diff --git a/BLACS/SRC/blacs_init_.c b/BLACS/SRC/blacs_init_.c
new file mode 100644
index 0000000..0594504
--- /dev/null
+++ b/BLACS/SRC/blacs_init_.c
@@ -0,0 +1,38 @@
+#include "Bdef.h"
+
+#if (INTFACE == C_CALL)
+void Cblacs_gridinit(int *ConTxt, char *order, int nprow, int npcol)
+#else
+F_VOID_FUNC blacs_gridinit_(int *ConTxt, F_CHAR order, int *nprow, int *npcol)
+#endif
+{
+ void Cblacs_gridmap(int *, int *, int, int, int);
+ int *tmpgrid, *iptr;
+ int i, j;
+
+/*
+ * Grid can be row- or column-major natural ordering when blacs_gridinit is
+ * called. Define a tmpgrid to reflect this, and call blacs_gridmap to
+ * set it up
+ */
+ iptr = tmpgrid = (int*) malloc( Mpval(nprow)*Mpval(npcol)*sizeof(*tmpgrid) );
+ if (Mlowcase(F2C_CharTrans(order)) == 'c')
+ {
+ i = Mpval(npcol) * Mpval(nprow);
+ for (j=0; j < i; j++) iptr[j] = j;
+ }
+ else
+ {
+ for (j=0; j < Mpval(npcol); j++)
+ {
+ for (i=0; i < Mpval(nprow); i++) iptr[i] = i * Mpval(npcol) + j;
+ iptr += Mpval(nprow);
+ }
+ }
+#if (INTFACE == C_CALL)
+ Cblacs_gridmap(ConTxt, tmpgrid, nprow, nprow, npcol);
+#else
+ blacs_gridmap_(ConTxt, tmpgrid, nprow, nprow, npcol);
+#endif
+ free(tmpgrid);
+}
diff --git a/BLACS/SRC/blacs_map_.c b/BLACS/SRC/blacs_map_.c
new file mode 100644
index 0000000..8224c8e
--- /dev/null
+++ b/BLACS/SRC/blacs_map_.c
@@ -0,0 +1,140 @@
+#include "Bdef.h"
+
+#if (INTFACE == C_CALL)
+void Cblacs_gridmap(int *ConTxt, int *usermap, int ldup, int nprow0, int npcol0)
+#else
+F_VOID_FUNC blacs_gridmap_(int *ConTxt, int *usermap, int *ldup, int *nprow0,
+ int *npcol0)
+#endif
+{
+ void Cblacs_pinfo(int *, int *);
+ void Cblacs_get(int, int, int *);
+
+ MPI_Comm BI_TransUserComm(int, int, int *);
+
+ MPI_Comm Cblacs2sys_handle(int);
+
+ int info, i, j, Iam, *iptr;
+ int myrow, mycol, nprow, npcol, Ng;
+ BLACSCONTEXT *ctxt, **tCTxts;
+ MPI_Comm comm, tcomm;
+ MPI_Group grp, tgrp;
+
+ extern BLACSCONTEXT **BI_MyContxts;
+ extern BLACBUFF BI_AuxBuff;
+ extern int BI_Iam, BI_Np, BI_MaxNCtxt;
+ extern MPI_Status *BI_Stats;
+
+/*
+ * If first call to blacs_gridmap
+ */
+ if (BI_MaxNCtxt == 0)
+ {
+ Cblacs_pinfo(&BI_Iam, &BI_Np);
+ BI_AuxBuff.nAops = 0;
+ BI_AuxBuff.Aops = (MPI_Request*)malloc(BI_Np*sizeof(*BI_AuxBuff.Aops));
+ BI_Stats = (MPI_Status *) malloc(BI_Np * sizeof(MPI_Status));
+ }
+
+ nprow = Mpval(nprow0);
+ npcol = Mpval(npcol0);
+ Ng = nprow * npcol;
+ if ( (Ng > BI_Np) || (nprow < 1) || (npcol < 1) )
+ BI_BlacsErr(-1, -1, "BLACS_GRIDINIT/BLACS_GRIDMAP",
+ "Illegal grid (%d x %d), #procs=%d", nprow, npcol, BI_Np);
+/*
+ * Form MPI communicator for scope = 'all'
+ */
+ if (Ng > 2) i = Ng;
+ else i = 2;
+ iptr = (int *) malloc(i*sizeof(int));
+ for (j=0; j < npcol; j++)
+ {
+ for (i=0; i < nprow; i++) iptr[i*npcol+j] = usermap[j*Mpval(ldup)+i];
+ }
+#if (INTFACE == C_CALL)
+ tcomm = Cblacs2sys_handle(*ConTxt);
+ MPI_Comm_group(tcomm, &grp); /* find input comm's group */
+ MPI_Group_incl(grp, Ng, iptr, &tgrp); /* form new group */
+ MPI_Comm_create(tcomm, tgrp, &comm); /* create new comm */
+ MPI_Group_free(&tgrp);
+ MPI_Group_free(&grp);
+#else /* gridmap called from fortran */
+ comm = BI_TransUserComm(*ConTxt, Ng, iptr);
+#endif
+
+/*
+ * Weed out callers who are not participating in present grid
+ */
+ if (comm == MPI_COMM_NULL)
+ {
+ *ConTxt = NOTINCONTEXT;
+ free(iptr);
+ return;
+ }
+
+/*
+ * ==================================================
+ * Get new context and add it to my array of contexts
+ * ==================================================
+ */
+ ctxt = (BLACSCONTEXT *) malloc(sizeof(BLACSCONTEXT));
+/*
+ * Find free slot in my context array
+ */
+ for (i=0; i < BI_MaxNCtxt; i++) if (BI_MyContxts[i] == NULL) break;
+/*
+ * Get bigger context pointer array, if needed
+ */
+ if (i == BI_MaxNCtxt)
+ {
+ j = BI_MaxNCtxt + MAXNCTXT;
+ tCTxts = (BLACSCONTEXT **) malloc(j * sizeof(*tCTxts));
+ for (i=0; i < BI_MaxNCtxt; i++) tCTxts[i] = BI_MyContxts[i];
+ BI_MaxNCtxt = j;
+ for(j=i; j < BI_MaxNCtxt; j++) tCTxts[j] = NULL;
+ if (BI_MyContxts) free(BI_MyContxts);
+ BI_MyContxts = tCTxts;
+ }
+ BI_MyContxts[i] = ctxt;
+ *ConTxt = i;
+
+ ctxt->ascp.comm = comm;
+ MPI_Comm_dup(comm, &ctxt->pscp.comm); /* copy acomm for pcomm */
+ MPI_Comm_rank(comm, &Iam); /* find my rank in new comm */
+ myrow = Iam / npcol;
+ mycol = Iam % npcol;
+
+/*
+ * Form MPI communicators for scope = 'row'
+ */
+ MPI_Comm_split(comm, myrow, mycol, &ctxt->rscp.comm);
+/*
+ * Form MPI communicators for scope = 'Column'
+ */
+ MPI_Comm_split(comm, mycol, myrow, &ctxt->cscp.comm);
+
+ ctxt->rscp.Np = npcol;
+ ctxt->rscp.Iam = mycol;
+ ctxt->cscp.Np = nprow;
+ ctxt->cscp.Iam = myrow;
+ ctxt->pscp.Np = ctxt->ascp.Np = Ng;
+ ctxt->pscp.Iam = ctxt->ascp.Iam = Iam;
+ ctxt->Nr_bs = ctxt->Nr_co = 1;
+ ctxt->Nb_bs = ctxt->Nb_co = 2;
+ ctxt->TopsRepeat = ctxt->TopsCohrnt = 0;
+
+/*
+ * ===========================
+ * Set up the message id stuff
+ * ===========================
+ */
+ Cblacs_get(-1, 1, iptr);
+ ctxt->pscp.MinId = ctxt->rscp.MinId = ctxt->cscp.MinId =
+ ctxt->ascp.MinId = ctxt->pscp.ScpId = ctxt->rscp.ScpId =
+ ctxt->cscp.ScpId = ctxt->ascp.ScpId = iptr[0];
+ ctxt->pscp.MaxId = ctxt->rscp.MaxId = ctxt->cscp.MaxId =
+ ctxt->ascp.MaxId = iptr[1];
+ free(iptr);
+
+}
diff --git a/BLACS/SRC/blacs_pcoord_.c b/BLACS/SRC/blacs_pcoord_.c
new file mode 100644
index 0000000..875aaf1
--- /dev/null
+++ b/BLACS/SRC/blacs_pcoord_.c
@@ -0,0 +1,17 @@
+#include "Bdef.h"
+
+#if (INTFACE == C_CALL)
+void Cblacs_pcoord(int ConTxt, int nodenum, int *prow, int *pcol)
+#else
+F_VOID_FUNC blacs_pcoord_(int *ConTxt, int *nodenum, int *prow, int *pcol)
+#endif
+{
+ BLACSCONTEXT *ctxt;
+
+ MGetConTxt(Mpval(ConTxt), ctxt);
+ if ( (Mpval(nodenum) >= 0) && (Mpval(nodenum) < ctxt->ascp.Np) )
+ {
+ Mpcoord(ctxt, Mpval(nodenum), *prow, *pcol);
+ }
+ else *prow = *pcol = -1;
+}
diff --git a/BLACS/SRC/blacs_pinfo_.c b/BLACS/SRC/blacs_pinfo_.c
new file mode 100644
index 0000000..f015c71
--- /dev/null
+++ b/BLACS/SRC/blacs_pinfo_.c
@@ -0,0 +1,27 @@
+#include "Bdef.h"
+
+#if (INTFACE == C_CALL)
+void Cblacs_pinfo(int *mypnum, int *nprocs)
+#else
+F_VOID_FUNC blacs_pinfo_(int *mypnum, int *nprocs)
+#endif
+{
+ int ierr;
+ extern int BI_Iam, BI_Np;
+ int argc=0;
+ char **argv=NULL;
+ if (BI_COMM_WORLD == NULL)
+ {
+ MPI_Initialized(nprocs);
+
+ if (!(*nprocs))
+ ierr = MPI_Init(&argc,&argv); // call Init and ignore argc and argv
+
+ BI_COMM_WORLD = (int *) malloc(sizeof(int));
+ *BI_COMM_WORLD = MPI_Comm_c2f(MPI_COMM_WORLD);
+ MPI_Comm_size(MPI_COMM_WORLD, &BI_Np);
+ MPI_Comm_rank(MPI_COMM_WORLD, &BI_Iam);
+ }
+ *mypnum = BI_Iam;
+ *nprocs = BI_Np;
+}
diff --git a/BLACS/SRC/blacs_pnum_.c b/BLACS/SRC/blacs_pnum_.c
new file mode 100644
index 0000000..53daf65
--- /dev/null
+++ b/BLACS/SRC/blacs_pnum_.c
@@ -0,0 +1,16 @@
+#include "Bdef.h"
+
+#if (INTFACE == C_CALL)
+int Cblacs_pnum(int ConTxt, int prow, int pcol)
+#else
+F_INT_FUNC blacs_pnum_(int *ConTxt, int *prow, int *pcol)
+#endif
+{
+ BLACSCONTEXT *ctxt;
+
+ MGetConTxt(Mpval(ConTxt), ctxt);
+ if ( (Mpval(prow) >= 0) && (Mpval(prow) < ctxt->cscp.Np) &&
+ (Mpval(pcol) >= 0) && (Mpval(pcol) < ctxt->rscp.Np) )
+ return( Mkpnum(ctxt, Mpval(prow), Mpval(pcol)) );
+ else return(-1);
+}
diff --git a/BLACS/SRC/blacs_set_.c b/BLACS/SRC/blacs_set_.c
new file mode 100644
index 0000000..4e12597
--- /dev/null
+++ b/BLACS/SRC/blacs_set_.c
@@ -0,0 +1,67 @@
+#include "Bdef.h"
+
+#if (INTFACE == C_CALL)
+void Cblacs_set(int ConTxt, int what, int *val)
+#else
+F_VOID_FUNC blacs_set_(int *ConTxt, int *what, int *val)
+#endif
+{
+ BLACSCONTEXT *ctxt;
+
+ switch( Mpval(what) )
+ {
+ case SGET_SYSCONTXT:
+ BI_BlacsWarn(Mpval(ConTxt), __LINE__, __FILE__,
+ "Cannot set BLACS system context, can only BLACS_GET");
+ break;
+ case SGET_MSGIDS:
+ BI_BlacsWarn(Mpval(ConTxt), __LINE__, __FILE__,
+ "No need to set message ID range due to MPI communicator.");
+ break;
+ case SGET_DEBUGLVL:
+ BI_BlacsWarn(Mpval(ConTxt), __LINE__, __FILE__,
+ "Cannot set BLACS debug level; must recompile to change");
+ break;
+ case SGET_BLACSCONTXT:
+ BI_BlacsWarn(Mpval(ConTxt), __LINE__, __FILE__,
+ "Cannot set BLACS context, can only BLACS_GET");
+ break;
+ case SGET_NR_BS:
+ MGetConTxt(Mpval(ConTxt), ctxt);
+ if (*val) ctxt->Nr_bs = *val;
+ else BI_BlacsWarn(Mpval(ConTxt), __LINE__, __FILE__,
+ "BSBR nrings cannot be set to zero");
+ break;
+ case SGET_NB_BS:
+ MGetConTxt(Mpval(ConTxt), ctxt);
+ if (*val > 0) ctxt->Nb_bs = *val + 1;
+ else BI_BlacsWarn(Mpval(ConTxt), __LINE__, __FILE__,
+ "Illegal BSBR nbranches (%d); must be strictly positive",
+ *val);
+ break;
+ case SGET_NR_CO:
+ MGetConTxt(Mpval(ConTxt), ctxt);
+ if (*val) ctxt->Nr_co = *val;
+ else BI_BlacsWarn(Mpval(ConTxt), __LINE__, __FILE__,
+ "COMB nrings cannot be set to zero");
+ break;
+ case SGET_NB_CO:
+ MGetConTxt(Mpval(ConTxt), ctxt);
+ if (*val > 0) ctxt->Nb_co = *val + 1;
+ else BI_BlacsWarn(Mpval(ConTxt), __LINE__, __FILE__,
+ "Illegal COMB nbranches (%d); must be strictly positive",
+ *val);
+ break;
+ case SGET_TOPSREPEAT:
+ MGetConTxt(Mpval(ConTxt), ctxt);
+ ctxt->TopsRepeat = *val;
+ break;
+ case SGET_TOPSCOHRNT:
+ MGetConTxt(Mpval(ConTxt), ctxt);
+ ctxt->TopsCohrnt = *val;
+ break;
+ default:
+ BI_BlacsWarn(Mpval(ConTxt), __LINE__, __FILE__, "Unknown WHAT (%d)",
+ Mpval(what));
+ }
+}
diff --git a/BLACS/SRC/blacs_setup_.c b/BLACS/SRC/blacs_setup_.c
new file mode 100644
index 0000000..e303afd
--- /dev/null
+++ b/BLACS/SRC/blacs_setup_.c
@@ -0,0 +1,15 @@
+#include "Bdef.h"
+
+
+#if (INTFACE == C_CALL)
+void Cblacs_setup(int *mypnum, int *nprocs)
+#else
+F_VOID_FUNC blacs_setup_(int *mypnum, int *nprocs)
+#endif
+{
+/*
+ * blacs_setup same as blacs_pinfo for non-PVM versions of the BLACS
+ */
+ void Cblacs_pinfo(int *, int *);
+ Cblacs_pinfo(mypnum, nprocs);
+}
diff --git a/BLACS/SRC/cgamn2d_.c b/BLACS/SRC/cgamn2d_.c
new file mode 100644
index 0000000..2db6ccb
--- /dev/null
+++ b/BLACS/SRC/cgamn2d_.c
@@ -0,0 +1,373 @@
+#include "Bdef.h"
+
+
+
+#if (INTFACE == C_CALL)
+void Ccgamn2d(int ConTxt, char *scope, char *top, int m, int n, float *A,
+ int lda, int *rA, int *cA, int ldia, int rdest, int cdest)
+#else
+F_VOID_FUNC cgamn2d_(int *ConTxt, F_CHAR scope, F_CHAR top, int *m, int *n,
+ float *A, int *lda, int *rA, int *cA, int *ldia,
+ int *rdest, int *cdest)
+#endif
+/*
+ * -- V1.1 BLACS routine --
+ * University of Tennessee, May 1, 1996
+ * Written by Clint Whaley.
+ *
+ * Purpose
+ * =======
+ * Combine amn operation for complex rectangular matrices.
+ *
+ * Arguments
+ * =========
+ *
+ * ConTxt (input) Ptr to int
+ * Index into MyConTxts00 (my contexts array).
+ *
+ * SCOPE (input) Ptr to char
+ * Limit the scope of the operation.
+ * = 'R' : Operation is performed by a process row.
+ * = 'C' : Operation is performed by a process column.
+ * = 'A' : Operation is performed by all processes in grid.
+ *
+ * TOP (input) Ptr to char
+ * Controls fashion in which messages flow within the operation.
+ *
+ * M (input) Ptr to int
+ * The number of rows of the matrix A. M >= 0.
+ *
+ * N (input) Ptr to int
+ * The number of columns of the matrix A. N >= 0.
+ *
+ * A (output) Ptr to complex two dimensional array
+ * The m by n matrix A. Fortran77 (column-major) storage
+ * assumed.
+ *
+ * LDA (input) Ptr to int
+ * The leading dimension of the array A. LDA >= M.
+ *
+ * RA (output) Integer Array, dimension (LDIA, N)
+ * Contains process row that the amn of each element
+ * of A was found on: i.e., rA(1,2) contains the process
+ * row that the amn of A(1,2) was found on.
+ * Values are left on process {rdest, cdest} only, others
+ * may be modified, but not left with interesting data.
+ * If rdest == -1, then result is left on all processes in scope.
+ * If LDIA == -1, this array is not accessed, and need not exist.
+ *
+ * CA (output) Integer Array, dimension (LDIA, N)
+ * Contains process column that the amn of each element
+ * of A was found on: i.e., cA(1,2) contains the process
+ * column that the max/min of A(1,2) was found on.
+ * Values are left on process {rdest, cdest} only, others
+ * may be modified, but not left with interesting data.
+ * If rdest == -1, then result is left on all processes in scope.
+ * If LDIA == -1, this array is not accessed, and need not exist.
+ *
+ * LDIA (input) Ptr to int
+ * If (LDIA == -1), then the arrays RA and CA are not accessed.
+ * ELSE leading dimension of the arrays RA and CA. LDIA >= M.
+ *
+ * RDEST (input) Ptr to int
+ * The process row of the destination of the amn.
+ * If rdest == -1, then result is left on all processes in scope.
+ *
+ * CDEST (input) Ptr to int
+ * The process column of the destination of the amn.
+ * If rdest == -1, then CDEST ignored.
+ *
+ * ------------------------------------------------------------------------
+ */
+{
+ void BI_ArgCheck(int, int, char *, char, char, char, int, int, int, int,
+ int *, int *);
+ void BI_UpdateBuffs(BLACBUFF *);
+ BLACBUFF *BI_GetBuff(int);
+ int BI_BuffIsFree(BLACBUFF *, int);
+ MPI_Datatype BI_GetMpiGeType(BLACSCONTEXT *, int, int, int,
+ MPI_Datatype, int *);
+ BLACBUFF *BI_Pack(BLACSCONTEXT *, BVOID *, BLACBUFF *, MPI_Datatype);
+ MPI_Datatype BI_GetMpiGeType(BLACSCONTEXT *, int, int, int,
+ MPI_Datatype, int *);
+ void BI_Unpack(BLACSCONTEXT *, BVOID *, BLACBUFF *, MPI_Datatype);
+ void BI_MringComb(BLACSCONTEXT *, BLACBUFF *, BLACBUFF *, int, VVFUNPTR,
+ int, int);
+ void BI_TreeComb(BLACSCONTEXT *, BLACBUFF *, BLACBUFF *, int, VVFUNPTR,
+ int, int);
+ void BI_BeComb(BLACSCONTEXT *, BLACBUFF *, BLACBUFF *, int, VVFUNPTR);
+ void BI_cvvamn(int, char *, char *);
+ void BI_cvvamn2(int, char *, char *);
+ void BI_cMPI_amn(void *, void *, int *, MPI_Datatype *);
+ void BI_cMPI_amn2(void *, void *, int *, MPI_Datatype *);
+/*
+ * Variable Declarations
+ */
+ VVFUNPTR vvop;
+ BLACBUFF *bp, *bp2;
+ BLACSCONTEXT *ctxt;
+ char ttop, tscope;
+ int i, j, N, dest, idist, length, tlda, tldia, trdest, ierr;
+ int len[2];
+ MPI_Aint disp[2];
+ MPI_Datatype dtypes[2];
+ MPI_Op BlacComb;
+ MPI_Datatype MyType;
+ BI_DistType *dist, mydist;
+ extern BLACBUFF *BI_ActiveQ;
+ extern BLACBUFF BI_AuxBuff;
+
+ MGetConTxt(Mpval(ConTxt), ctxt);
+ ttop = F2C_CharTrans(top);
+ ttop = Mlowcase(ttop);
+ tscope = F2C_CharTrans(scope);
+ tscope = Mlowcase(tscope);
+/*
+ * If the user has set the default combine topology, use it instead of
+ * BLACS default
+ */
+#ifdef DefCombTop
+ if (ttop == ' ') ttop = DefCombTop;
+#endif
+ if (Mpval(cdest) == -1) trdest = -1;
+ else trdest = Mpval(rdest);
+#if (BlacsDebugLvl > 0)
+ BI_ArgCheck(Mpval(ConTxt), RT_COMB, __FILE__, tscope, 'u', 'u', Mpval(m),
+ Mpval(n), Mpval(lda), 1, &trdest, Mpaddress(cdest));
+ if (Mpval(ldia) < Mpval(m))
+ {
+ if (Mpval(ldia) != -1)
+ BI_BlacsWarn(Mpval(ConTxt), __LINE__, __FILE__,
+ "LDIA too small (LDIA=%d, but M=%d)", Mpval(ldia),
+ Mpval(m));
+ }
+#endif
+ if (Mpval(lda) >= Mpval(m)) tlda = Mpval(lda);
+ else tlda = Mpval(m);
+ if (Mpval(ldia) < Mpval(m)) tldia = Mpval(m);
+ else tldia = Mpval(ldia);
+ switch(tscope)
+ {
+ case 'r':
+ ctxt->scp = &ctxt->rscp;
+ if (trdest == -1) dest = -1;
+ else dest = Mpval(cdest);
+ break;
+ case 'c':
+ ctxt->scp = &ctxt->cscp;
+ dest = trdest;
+ break;
+ case 'a':
+ ctxt->scp = &ctxt->ascp;
+ if (trdest == -1) dest = -1;
+ else dest = Mvkpnum(ctxt, trdest, Mpval(cdest));
+ break;
+ default:
+ BI_BlacsErr(Mpval(ConTxt), __LINE__, __FILE__, "Unknown scope '%c'",
+ tscope);
+ }
+
+
+/*
+ * It's not defined how MPI reacts to 0 element reductions, so use BLACS 1-tree
+ * topology if we've got one
+ */
+ if (ttop == ' ')
+ if ( (Mpval(m) < 1) || (Mpval(n) < 1) || (ctxt->TopsRepeat) ) ttop = '1';
+ N = Mpval(m) * Mpval(n);
+/*
+ * If process who has amn is to be communicated, must set up distance
+ * vector after value vector
+ */
+ if (Mpval(ldia) != -1)
+ {
+ vvop = BI_cvvamn;
+ length = N * sizeof(SCOMPLEX);
+ i = length % sizeof(BI_DistType); /* ensure dist vec aligned correctly */
+ if (i) length += sizeof(BI_DistType) - i;
+ idist = length;
+ length += N * sizeof(BI_DistType);
+/*
+ * For performance, insist second buffer is at least 8-byte aligned
+ */
+ j = 8;
+ if (sizeof(SCOMPLEX) > j) j = sizeof(SCOMPLEX);
+ i = length % j;
+ if (i) length += j - i;
+ i = 2 * length;
+
+ bp = BI_GetBuff(i);
+ bp2 = &BI_AuxBuff;
+ bp2->Buff = &bp->Buff[length];
+ BI_cmvcopy(Mpval(m), Mpval(n), A, tlda, bp->Buff);
+/*
+ * Fill in distance vector
+ */
+ if (dest == -1) mydist = ctxt->scp->Iam;
+ else mydist = (ctxt->scp->Np + ctxt->scp->Iam - dest) % ctxt->scp->Np;
+ dist = (BI_DistType *) &bp->Buff[idist];
+ for (i=0; i < N; i++) dist[i] = mydist;
+
+/*
+ * Create the MPI datatype holding both user's buffer and distance vector
+ */
+ len[0] = len[1] = N;
+ disp[0] = 0;
+ disp[1] = idist;
+ dtypes[0] = MPI_COMPLEX;
+ dtypes[1] = BI_MpiDistType;
+#ifdef ZeroByteTypeBug
+ if (N > 0)
+ {
+#endif
+ i = 2;
+ ierr=MPI_Type_struct(i, len, disp, dtypes, &MyType);
+ ierr=MPI_Type_commit(&MyType);
+ bp->N = bp2->N = 1;
+ bp->dtype = bp2->dtype = MyType;
+#ifdef ZeroByteTypeBug
+ }
+ else
+ {
+ bp->N = bp2->N = 0;
+ bp->dtype = bp2->dtype = MPI_INT;
+ }
+#endif
+ }
+ else
+ {
+ vvop = BI_cvvamn2;
+ length = N * sizeof(SCOMPLEX);
+/*
+ * If A is contiguous, we can use it as one of our buffers
+ */
+ if ( (Mpval(m) == tlda) || (Mpval(n) == 1) )
+ {
+ bp = &BI_AuxBuff;
+ bp->Buff = (char *) A;
+ bp2 = BI_GetBuff(length);
+ }
+ else
+ {
+ bp = BI_GetBuff(length*2);
+ bp2 = &BI_AuxBuff;
+ bp2->Buff = &bp->Buff[length];
+ BI_cmvcopy(Mpval(m), Mpval(n), A, tlda, bp->Buff);
+ }
+ bp->N = bp2->N = N;
+ bp->dtype = bp2->dtype = MPI_COMPLEX;
+ }
+
+ switch(ttop)
+ {
+ case ' ': /* use MPI's reduction by default */
+ i = 1;
+ if (Mpval(ldia) == -1)
+ {
+ ierr=MPI_Op_create(BI_cMPI_amn2, i, &BlacComb);
+ }
+ else
+ {
+ ierr=MPI_Op_create(BI_cMPI_amn, i, &BlacComb);
+ BI_AuxBuff.Len = N; /* set this up for the MPI OP wrappers */
+ }
+
+ if (trdest != -1)
+ {
+ ierr=MPI_Reduce(bp->Buff, bp2->Buff, bp->N, bp->dtype, BlacComb, dest,
+ ctxt->scp->comm);
+ if (ctxt->scp->Iam == dest)
+ {
+ BI_cvmcopy(Mpval(m), Mpval(n), A, tlda, bp2->Buff);
+ if (Mpval(ldia) != -1)
+ BI_TransDist(ctxt, tscope, Mpval(m), Mpval(n), rA, cA, tldia,
+ (BI_DistType *) &bp2->Buff[idist],
+ trdest, Mpval(cdest));
+ }
+ }
+ else
+ {
+ ierr=MPI_Allreduce(bp->Buff, bp2->Buff, bp->N, bp->dtype, BlacComb,
+ ctxt->scp->comm);
+ BI_cvmcopy(Mpval(m), Mpval(n), A, tlda, bp2->Buff);
+ if (Mpval(ldia) != -1)
+ BI_TransDist(ctxt, tscope, Mpval(m), Mpval(n), rA, cA, tldia,
+ (BI_DistType *) &bp2->Buff[idist],
+ trdest, Mpval(cdest));
+ }
+ ierr=MPI_Op_free(&BlacComb);
+ if (Mpval(ldia) != -1)
+#ifdef ZeroByteTypeBug
+ if (N > 0)
+#endif
+ ierr=BI_MPI_TYPE_FREE(&MyType);
+ if (BI_ActiveQ) BI_UpdateBuffs(NULL);
+ return;
+ break;
+ case 'i':
+ BI_MringComb(ctxt, bp, bp2, N, vvop, dest, 1);
+ break;
+ case 'd':
+ BI_MringComb(ctxt, bp, bp2, N, vvop, dest, -1);
+ break;
+ case 's':
+ BI_MringComb(ctxt, bp, bp2, N, vvop, dest, 2);
+ break;
+ case 'm':
+ BI_MringComb(ctxt, bp, bp2, N, vvop, dest, ctxt->Nr_co);
+ break;
+ case '1':
+ case '2':
+ case '3':
+ case '4':
+ case '5':
+ case '6':
+ case '7':
+ case '8':
+ case '9':
+ BI_TreeComb(ctxt, bp, bp2, N, vvop, dest, ttop-47);
+ break;
+ case 'f':
+ BI_TreeComb(ctxt, bp, bp2, N, vvop, dest, FULLCON);
+ break;
+ case 't':
+ BI_TreeComb(ctxt, bp, bp2, N, vvop, dest, ctxt->Nb_co);
+ break;
+ case 'h':
+/*
+ * Use bidirectional exchange if everyone wants answer
+ */
+ if ( (trdest == -1) && !(ctxt->TopsCohrnt) )
+ BI_BeComb(ctxt, bp, bp2, N, vvop);
+ else
+ BI_TreeComb(ctxt, bp, bp2, N, vvop, dest, 2);
+ break;
+ default :
+ BI_BlacsErr(Mpval(ConTxt), __LINE__, __FILE__, "Unknown topology '%c'",
+ ttop);
+ }
+
+ if (Mpval(ldia) != -1)
+#ifdef ZeroByteTypeBug
+ if (N > 0)
+#endif
+ ierr=BI_MPI_TYPE_FREE(&MyType);
+/*
+ * If I am selected to receive answer
+ */
+ if ( (ctxt->scp->Iam == dest) || (dest == -1) )
+ {
+/*
+ * Translate the distances stored in the latter part of bp->Buff into
+ * process grid coordinates, and output these coordinates in the
+ * arrays rA and cA.
+ */
+ if (Mpval(ldia) != -1)
+ BI_TransDist(ctxt, tscope, Mpval(m), Mpval(n), rA, cA, tldia,
+ dist, trdest, Mpval(cdest));
+/*
+ * Unpack the amn array
+ */
+ if (bp != &BI_AuxBuff) BI_cvmcopy(Mpval(m), Mpval(n), A, tlda, bp->Buff);
+ }
+}
diff --git a/BLACS/SRC/cgamx2d_.c b/BLACS/SRC/cgamx2d_.c
new file mode 100644
index 0000000..707c0b6
--- /dev/null
+++ b/BLACS/SRC/cgamx2d_.c
@@ -0,0 +1,373 @@
+#include "Bdef.h"
+
+
+
+#if (INTFACE == C_CALL)
+void Ccgamx2d(int ConTxt, char *scope, char *top, int m, int n, float *A,
+ int lda, int *rA, int *cA, int ldia, int rdest, int cdest)
+#else
+F_VOID_FUNC cgamx2d_(int *ConTxt, F_CHAR scope, F_CHAR top, int *m, int *n,
+ float *A, int *lda, int *rA, int *cA, int *ldia,
+ int *rdest, int *cdest)
+#endif
+/*
+ * -- V1.1 BLACS routine --
+ * University of Tennessee, May 1, 1996
+ * Written by Clint Whaley.
+ *
+ * Purpose
+ * =======
+ * Combine amx operation for complex rectangular matrices.
+ *
+ * Arguments
+ * =========
+ *
+ * ConTxt (input) Ptr to int
+ * Index into MyConTxts00 (my contexts array).
+ *
+ * SCOPE (input) Ptr to char
+ * Limit the scope of the operation.
+ * = 'R' : Operation is performed by a process row.
+ * = 'C' : Operation is performed by a process column.
+ * = 'A' : Operation is performed by all processes in grid.
+ *
+ * TOP (input) Ptr to char
+ * Controls fashion in which messages flow within the operation.
+ *
+ * M (input) Ptr to int
+ * The number of rows of the matrix A. M >= 0.
+ *
+ * N (input) Ptr to int
+ * The number of columns of the matrix A. N >= 0.
+ *
+ * A (output) Ptr to complex two dimensional array
+ * The m by n matrix A. Fortran77 (column-major) storage
+ * assumed.
+ *
+ * LDA (input) Ptr to int
+ * The leading dimension of the array A. LDA >= M.
+ *
+ * RA (output) Integer Array, dimension (LDIA, N)
+ * Contains process row that the amx of each element
+ * of A was found on: i.e., rA(1,2) contains the process
+ * row that the amx of A(1,2) was found on.
+ * Values are left on process {rdest, cdest} only, others
+ * may be modified, but not left with interesting data.
+ * If rdest == -1, then result is left on all processes in scope.
+ * If LDIA == -1, this array is not accessed, and need not exist.
+ *
+ * CA (output) Integer Array, dimension (LDIA, N)
+ * Contains process column that the amx of each element
+ * of A was found on: i.e., cA(1,2) contains the process
+ * column that the max/min of A(1,2) was found on.
+ * Values are left on process {rdest, cdest} only, others
+ * may be modified, but not left with interesting data.
+ * If rdest == -1, then result is left on all processes in scope.
+ * If LDIA == -1, this array is not accessed, and need not exist.
+ *
+ * LDIA (input) Ptr to int
+ * If (LDIA == -1), then the arrays RA and CA are not accessed.
+ * ELSE leading dimension of the arrays RA and CA. LDIA >= M.
+ *
+ * RDEST (input) Ptr to int
+ * The process row of the destination of the amx.
+ * If rdest == -1, then result is left on all processes in scope.
+ *
+ * CDEST (input) Ptr to int
+ * The process column of the destination of the amx.
+ * If rdest == -1, then CDEST ignored.
+ *
+ * ------------------------------------------------------------------------
+ */
+{
+ void BI_ArgCheck(int, int, char *, char, char, char, int, int, int, int,
+ int *, int *);
+ void BI_UpdateBuffs(BLACBUFF *);
+ BLACBUFF *BI_GetBuff(int);
+ int BI_BuffIsFree(BLACBUFF *, int);
+ MPI_Datatype BI_GetMpiGeType(BLACSCONTEXT *, int, int, int,
+ MPI_Datatype, int *);
+ BLACBUFF *BI_Pack(BLACSCONTEXT *, BVOID *, BLACBUFF *, MPI_Datatype);
+ MPI_Datatype BI_GetMpiGeType(BLACSCONTEXT *, int, int, int,
+ MPI_Datatype, int *);
+ void BI_Unpack(BLACSCONTEXT *, BVOID *, BLACBUFF *, MPI_Datatype);
+ void BI_MringComb(BLACSCONTEXT *, BLACBUFF *, BLACBUFF *, int, VVFUNPTR,
+ int, int);
+ void BI_TreeComb(BLACSCONTEXT *, BLACBUFF *, BLACBUFF *, int, VVFUNPTR,
+ int, int);
+ void BI_BeComb(BLACSCONTEXT *, BLACBUFF *, BLACBUFF *, int, VVFUNPTR);
+ void BI_cvvamx(int, char *, char *);
+ void BI_cvvamx2(int, char *, char *);
+ void BI_cMPI_amx(void *, void *, int *, MPI_Datatype *);
+ void BI_cMPI_amx2(void *, void *, int *, MPI_Datatype *);
+/*
+ * Variable Declarations
+ */
+ VVFUNPTR vvop;
+ BLACBUFF *bp, *bp2;
+ BLACSCONTEXT *ctxt;
+ char ttop, tscope;
+ int i, j, N, dest, idist, length, tlda, tldia, trdest, ierr;
+ int len[2];
+ MPI_Aint disp[2];
+ MPI_Datatype dtypes[2];
+ MPI_Op BlacComb;
+ MPI_Datatype MyType;
+ BI_DistType *dist, mydist;
+ extern BLACBUFF *BI_ActiveQ;
+ extern BLACBUFF BI_AuxBuff;
+
+ MGetConTxt(Mpval(ConTxt), ctxt);
+ ttop = F2C_CharTrans(top);
+ ttop = Mlowcase(ttop);
+ tscope = F2C_CharTrans(scope);
+ tscope = Mlowcase(tscope);
+/*
+ * If the user has set the default combine topology, use it instead of
+ * BLACS default
+ */
+#ifdef DefCombTop
+ if (ttop == ' ') ttop = DefCombTop;
+#endif
+ if (Mpval(cdest) == -1) trdest = -1;
+ else trdest = Mpval(rdest);
+#if (BlacsDebugLvl > 0)
+ BI_ArgCheck(Mpval(ConTxt), RT_COMB, __FILE__, tscope, 'u', 'u', Mpval(m),
+ Mpval(n), Mpval(lda), 1, &trdest, Mpaddress(cdest));
+ if (Mpval(ldia) < Mpval(m))
+ {
+ if (Mpval(ldia) != -1)
+ BI_BlacsWarn(Mpval(ConTxt), __LINE__, __FILE__,
+ "LDIA too small (LDIA=%d, but M=%d)", Mpval(ldia),
+ Mpval(m));
+ }
+#endif
+ if (Mpval(lda) >= Mpval(m)) tlda = Mpval(lda);
+ else tlda = Mpval(m);
+ if (Mpval(ldia) < Mpval(m)) tldia = Mpval(m);
+ else tldia = Mpval(ldia);
+ switch(tscope)
+ {
+ case 'r':
+ ctxt->scp = &ctxt->rscp;
+ if (trdest == -1) dest = -1;
+ else dest = Mpval(cdest);
+ break;
+ case 'c':
+ ctxt->scp = &ctxt->cscp;
+ dest = trdest;
+ break;
+ case 'a':
+ ctxt->scp = &ctxt->ascp;
+ if (trdest == -1) dest = -1;
+ else dest = Mvkpnum(ctxt, trdest, Mpval(cdest));
+ break;
+ default:
+ BI_BlacsErr(Mpval(ConTxt), __LINE__, __FILE__, "Unknown scope '%c'",
+ tscope);
+ }
+
+
+/*
+ * It's not defined how MPI reacts to 0 element reductions, so use BLACS 1-tree
+ * topology if we've got one
+ */
+ if (ttop == ' ')
+ if ( (Mpval(m) < 1) || (Mpval(n) < 1) || (ctxt->TopsRepeat) ) ttop = '1';
+ N = Mpval(m) * Mpval(n);
+/*
+ * If process who has amx is to be communicated, must set up distance
+ * vector after value vector
+ */
+ if (Mpval(ldia) != -1)
+ {
+ vvop = BI_cvvamx;
+ length = N * sizeof(SCOMPLEX);
+ i = length % sizeof(BI_DistType); /* ensure dist vec aligned correctly */
+ if (i) length += sizeof(BI_DistType) - i;
+ idist = length;
+ length += N * sizeof(BI_DistType);
+/*
+ * For performance, insist second buffer is at least 8-byte aligned
+ */
+ j = 8;
+ if (sizeof(SCOMPLEX) > j) j = sizeof(SCOMPLEX);
+ i = length % j;
+ if (i) length += j - i;
+ i = 2 * length;
+
+ bp = BI_GetBuff(i);
+ bp2 = &BI_AuxBuff;
+ bp2->Buff = &bp->Buff[length];
+ BI_cmvcopy(Mpval(m), Mpval(n), A, tlda, bp->Buff);
+/*
+ * Fill in distance vector
+ */
+ if (dest == -1) mydist = ctxt->scp->Iam;
+ else mydist = (ctxt->scp->Np + ctxt->scp->Iam - dest) % ctxt->scp->Np;
+ dist = (BI_DistType *) &bp->Buff[idist];
+ for (i=0; i < N; i++) dist[i] = mydist;
+
+/*
+ * Create the MPI datatype holding both user's buffer and distance vector
+ */
+ len[0] = len[1] = N;
+ disp[0] = 0;
+ disp[1] = idist;
+ dtypes[0] = MPI_COMPLEX;
+ dtypes[1] = BI_MpiDistType;
+#ifdef ZeroByteTypeBug
+ if (N > 0)
+ {
+#endif
+ i = 2;
+ ierr=MPI_Type_struct(i, len, disp, dtypes, &MyType);
+ ierr=MPI_Type_commit(&MyType);
+ bp->N = bp2->N = 1;
+ bp->dtype = bp2->dtype = MyType;
+#ifdef ZeroByteTypeBug
+ }
+ else
+ {
+ bp->N = bp2->N = 0;
+ bp->dtype = bp2->dtype = MPI_INT;
+ }
+#endif
+ }
+ else
+ {
+ vvop = BI_cvvamx2;
+ length = N * sizeof(SCOMPLEX);
+/*
+ * If A is contiguous, we can use it as one of our buffers
+ */
+ if ( (Mpval(m) == tlda) || (Mpval(n) == 1) )
+ {
+ bp = &BI_AuxBuff;
+ bp->Buff = (char *) A;
+ bp2 = BI_GetBuff(length);
+ }
+ else
+ {
+ bp = BI_GetBuff(length*2);
+ bp2 = &BI_AuxBuff;
+ bp2->Buff = &bp->Buff[length];
+ BI_cmvcopy(Mpval(m), Mpval(n), A, tlda, bp->Buff);
+ }
+ bp->N = bp2->N = N;
+ bp->dtype = bp2->dtype = MPI_COMPLEX;
+ }
+
+ switch(ttop)
+ {
+ case ' ': /* use MPI's reduction by default */
+ i = 1;
+ if (Mpval(ldia) == -1)
+ {
+ ierr=MPI_Op_create(BI_cMPI_amx2, i, &BlacComb);
+ }
+ else
+ {
+ ierr=MPI_Op_create(BI_cMPI_amx, i, &BlacComb);
+ BI_AuxBuff.Len = N; /* set this up for the MPI OP wrappers */
+ }
+
+ if (trdest != -1)
+ {
+ ierr=MPI_Reduce(bp->Buff, bp2->Buff, bp->N, bp->dtype, BlacComb, dest,
+ ctxt->scp->comm);
+ if (ctxt->scp->Iam == dest)
+ {
+ BI_cvmcopy(Mpval(m), Mpval(n), A, tlda, bp2->Buff);
+ if (Mpval(ldia) != -1)
+ BI_TransDist(ctxt, tscope, Mpval(m), Mpval(n), rA, cA, tldia,
+ (BI_DistType *) &bp2->Buff[idist],
+ trdest, Mpval(cdest));
+ }
+ }
+ else
+ {
+ ierr=MPI_Allreduce(bp->Buff, bp2->Buff, bp->N, bp->dtype, BlacComb,
+ ctxt->scp->comm);
+ BI_cvmcopy(Mpval(m), Mpval(n), A, tlda, bp2->Buff);
+ if (Mpval(ldia) != -1)
+ BI_TransDist(ctxt, tscope, Mpval(m), Mpval(n), rA, cA, tldia,
+ (BI_DistType *) &bp2->Buff[idist],
+ trdest, Mpval(cdest));
+ }
+ ierr=MPI_Op_free(&BlacComb);
+ if (Mpval(ldia) != -1)
+#ifdef ZeroByteTypeBug
+ if (N > 0)
+#endif
+ ierr=BI_MPI_TYPE_FREE(&MyType);
+ if (BI_ActiveQ) BI_UpdateBuffs(NULL);
+ return;
+ break;
+ case 'i':
+ BI_MringComb(ctxt, bp, bp2, N, vvop, dest, 1);
+ break;
+ case 'd':
+ BI_MringComb(ctxt, bp, bp2, N, vvop, dest, -1);
+ break;
+ case 's':
+ BI_MringComb(ctxt, bp, bp2, N, vvop, dest, 2);
+ break;
+ case 'm':
+ BI_MringComb(ctxt, bp, bp2, N, vvop, dest, ctxt->Nr_co);
+ break;
+ case '1':
+ case '2':
+ case '3':
+ case '4':
+ case '5':
+ case '6':
+ case '7':
+ case '8':
+ case '9':
+ BI_TreeComb(ctxt, bp, bp2, N, vvop, dest, ttop-47);
+ break;
+ case 'f':
+ BI_TreeComb(ctxt, bp, bp2, N, vvop, dest, FULLCON);
+ break;
+ case 't':
+ BI_TreeComb(ctxt, bp, bp2, N, vvop, dest, ctxt->Nb_co);
+ break;
+ case 'h':
+/*
+ * Use bidirectional exchange if everyone wants answer
+ */
+ if ( (trdest == -1) && !(ctxt->TopsCohrnt) )
+ BI_BeComb(ctxt, bp, bp2, N, vvop);
+ else
+ BI_TreeComb(ctxt, bp, bp2, N, vvop, dest, 2);
+ break;
+ default :
+ BI_BlacsErr(Mpval(ConTxt), __LINE__, __FILE__, "Unknown topology '%c'",
+ ttop);
+ }
+
+ if (Mpval(ldia) != -1)
+#ifdef ZeroByteTypeBug
+ if (N > 0)
+#endif
+ ierr=BI_MPI_TYPE_FREE(&MyType);
+/*
+ * If I am selected to receive answer
+ */
+ if ( (ctxt->scp->Iam == dest) || (dest == -1) )
+ {
+/*
+ * Translate the distances stored in the latter part of bp->Buff into
+ * process grid coordinates, and output these coordinates in the
+ * arrays rA and cA.
+ */
+ if (Mpval(ldia) != -1)
+ BI_TransDist(ctxt, tscope, Mpval(m), Mpval(n), rA, cA, tldia,
+ dist, trdest, Mpval(cdest));
+/*
+ * Unpack the amx array
+ */
+ if (bp != &BI_AuxBuff) BI_cvmcopy(Mpval(m), Mpval(n), A, tlda, bp->Buff);
+ }
+}
diff --git a/BLACS/SRC/cgebr2d_.c b/BLACS/SRC/cgebr2d_.c
new file mode 100644
index 0000000..541cfd5
--- /dev/null
+++ b/BLACS/SRC/cgebr2d_.c
@@ -0,0 +1,226 @@
+#include "Bdef.h"
+
+#if (INTFACE == C_CALL)
+void Ccgebr2d(int ConTxt, char *scope, char *top, int m, int n, float *A,
+ int lda, int rsrc, int csrc)
+#else
+F_VOID_FUNC cgebr2d_(int *ConTxt, F_CHAR scope, F_CHAR top, int *m, int *n,
+ float *A, int *lda, int *rsrc, int *csrc)
+#endif
+/*
+ * -- V1.1 BLACS routine --
+ * University of Tennessee, May 1, 1996
+ * Written by Clint Whaley.
+ *
+ * Purpose
+ * =======
+ * Broadcast/receive for general complex arrays.
+ *
+ * Arguments
+ * =========
+ *
+ * ConTxt (input) Ptr to int
+ * Index into MyConTxts00 (my contexts array).
+ *
+ * SCOPE (input) Ptr to char
+ * Limit the scope of the operation.
+ * = 'R' : Operation is performed by a process row.
+ * = 'C' : Operation is performed by a process column.
+ * = 'A' : Operation is performed by all processes in grid.
+ *
+ * TOP (input) Ptr to char
+ * Controls fashion in which messages flow within the operation.
+ *
+ * M (input) Ptr to int
+ * The number of rows of the matrix A. M >= 0.
+ *
+ * N (input) Ptr to int
+ * The number of columns of the matrix A. N >= 0.
+ *
+ * A (output) Ptr to complex two dimensional array
+ * The m by n matrix A. Fortran77 (column-major) storage
+ * assumed.
+ *
+ * LDA (input) Ptr to int
+ * The leading dimension of the array A. LDA >= M.
+ *
+ *
+ * RSRC (input) Ptr to int
+ * The process row of the source of the matrix.
+ *
+ * CSRC (input) Ptr to int
+ * The process column of the source of the matrix.
+ *
+ *
+ * ------------------------------------------------------------------------
+ */
+{
+ void BI_ArgCheck(int, int, char *, char, char, char, int, int, int, int,
+ int *, int *);
+ int BI_HypBR(BLACSCONTEXT *, BLACBUFF *, SDRVPTR, int);
+ void BI_IdringBR(BLACSCONTEXT *, BLACBUFF *, SDRVPTR, int, int);
+ void BI_SringBR(BLACSCONTEXT *, BLACBUFF *, SDRVPTR, int);
+ void BI_MpathBR(BLACSCONTEXT *, BLACBUFF *, SDRVPTR, int, int);
+ void BI_TreeBR(BLACSCONTEXT *, BLACBUFF *, SDRVPTR, int, int);
+ void BI_UpdateBuffs(BLACBUFF *);
+ BLACBUFF *BI_GetBuff(int);
+ int BI_BuffIsFree(BLACBUFF *, int);
+ MPI_Datatype BI_GetMpiGeType(BLACSCONTEXT *, int, int, int,
+ MPI_Datatype, int *);
+ void BI_Unpack(BLACSCONTEXT *, BVOID *, BLACBUFF *, MPI_Datatype);
+ void BI_Ssend(BLACSCONTEXT *, int, int, BLACBUFF *);
+ void BI_Asend(BLACSCONTEXT *, int, int, BLACBUFF *);
+
+ BLACSCONTEXT *ctxt;
+ BLACBUFF *bp=NULL;
+ SDRVPTR send;
+ MPI_Datatype MatTyp;
+ int length, src, tlda, error, one=1;
+ char ttop, tscope;
+ extern BLACBUFF BI_AuxBuff, *BI_ActiveQ;
+
+ MGetConTxt(Mpval(ConTxt), ctxt);
+ ttop = F2C_CharTrans(top);
+ ttop = Mlowcase(ttop);
+ tscope = F2C_CharTrans(scope);
+ tscope = Mlowcase(tscope);
+#if (BlacsDebugLvl > 0)
+ BI_ArgCheck(Mpval(ConTxt), RT_BR, __FILE__, tscope, 'u', 'u', Mpval(m),
+ Mpval(n), Mpval(lda), 1, Mpaddress(rsrc), Mpaddress(csrc));
+#endif
+/*
+ * If the user has set the default broadcast topology, use it instead of
+ * BLACS default
+ */
+#ifdef DefBSTop
+ if (ttop == ' ') ttop = DefBSTop;
+#endif
+ if (Mpval(m) <= Mpval(lda)) tlda = Mpval(lda);
+ else tlda = Mpval(m);
+
+ switch(tscope)
+ {
+ case 'r':
+ ctxt->scp = &ctxt->rscp;
+ src = Mpval(csrc);
+ break;
+ case 'c':
+ ctxt->scp = &ctxt->cscp;
+ src = Mpval(rsrc);
+ break;
+ case 'a':
+ ctxt->scp = &ctxt->ascp;
+ src = Mvkpnum(ctxt, Mpval(rsrc), Mpval(csrc));
+ break;
+ default:
+ BI_BlacsErr(Mpval(ConTxt), __LINE__, __FILE__, "Unknown scope '%c'",
+ tscope);
+ }
+
+ MatTyp = BI_GetMpiGeType(ctxt, Mpval(m), Mpval(n), tlda,
+ MPI_COMPLEX, &BI_AuxBuff.N);
+/*
+ * If using default topology, use MPI native broadcast
+ */
+ if (ttop == ' ')
+ {
+ error=MPI_Bcast(A, BI_AuxBuff.N, MatTyp, src, ctxt->scp->comm);
+ error=BI_MPI_TYPE_FREE(&MatTyp);
+ if (BI_ActiveQ) BI_UpdateBuffs(NULL);
+ return;
+ }
+/*
+ * If MPI handles non-contiguous buffering well, always use MPI data types
+ * instead of packing
+ */
+#ifndef MpiBuffGood
+/*
+ * If A is contiguous, receive and send directly to/from it
+ */
+ else if ( (tlda == Mpval(m)) || (Mpval(n) == 1) )
+ {
+#endif
+ send = BI_Ssend;
+ BI_AuxBuff.Buff = (char *) A;
+ BI_AuxBuff.dtype = MatTyp;
+ bp = &BI_AuxBuff;
+#ifndef MpiBuffGood
+ }
+/*
+ * If A is not contiguous, we receive message as packed so it can be
+ * forwarded without further system intervention
+ */
+ else
+ {
+ send = BI_Asend;
+ MPI_Pack_size(one, MatTyp, ctxt->scp->comm, &length, error);
+ bp = BI_GetBuff(length);
+ bp->N = length;
+ bp->dtype = MPI_PACKED;
+#if ZeroByteTypeBug
+ if (MatTyp == MPI_BYTE)
+ {
+ send = BI_Ssend;
+ bp->N = 0;
+ bp->dtype = MPI_BYTE;
+ }
+#endif
+ }
+#endif
+
+ switch(ttop)
+ {
+ case 'h':
+ error = BI_HypBR(ctxt, bp, send, src);
+ if (error == NPOW2) BI_TreeBR(ctxt, bp, send, src, 2);
+ break;
+ case '1':
+ case '2':
+ case '3':
+ case '4':
+ case '5':
+ case '6':
+ case '7':
+ case '8':
+ case '9':
+ BI_TreeBR(ctxt, bp, send, src, ttop-47);
+ break;
+ case 't':
+ BI_TreeBR(ctxt, bp, send, src, ctxt->Nb_bs);
+ break;
+ case 'i':
+ BI_IdringBR(ctxt, bp, send, src, 1);
+ break;
+ case 'd':
+ BI_IdringBR(ctxt, bp, send, src, -1);
+ break;
+ case 's':
+ BI_SringBR(ctxt, bp, send, src);
+ break;
+ case 'm':
+ BI_MpathBR(ctxt, bp, send, src, ctxt->Nr_bs);
+ break;
+ case 'f':
+ BI_MpathBR(ctxt, bp, send, src, FULLCON);
+ break;
+ default :
+ BI_BlacsErr(Mpval(ConTxt), __LINE__, __FILE__, "Unknown topology '%c'",
+ ttop);
+ }
+
+/*
+ * If we buffered, unpack.
+ */
+#ifndef MpiBuffGood
+ if (bp != &BI_AuxBuff)
+ {
+ BI_Unpack(ctxt, (BVOID *) A, bp, MatTyp);
+ BI_UpdateBuffs(bp);
+ }
+ else
+#endif
+ {
+ error=BI_MPI_TYPE_FREE(&MatTyp);
+ if (BI_ActiveQ) BI_UpdateBuffs(NULL);
+ }
+}
diff --git a/BLACS/SRC/cgebs2d_.c b/BLACS/SRC/cgebs2d_.c
new file mode 100644
index 0000000..00212f0
--- /dev/null
+++ b/BLACS/SRC/cgebs2d_.c
@@ -0,0 +1,195 @@
+#include "Bdef.h"
+
+#if (INTFACE == C_CALL)
+void Ccgebs2d(int ConTxt, char *scope, char *top, int m, int n, float *A, int lda)
+#else
+F_VOID_FUNC cgebs2d_(int *ConTxt, F_CHAR scope, F_CHAR top, int *m, int *n,
+ float *A, int *lda)
+#endif
+/*
+ * -- V1.1 BLACS routine --
+ * University of Tennessee, May 1, 1996
+ * Written by Clint Whaley.
+ *
+ * Purpose
+ * =======
+ * Broadcast/send for general complex arrays.
+ *
+ * Arguments
+ * =========
+ *
+ * ConTxt (input) Ptr to int
+ * Index into MyConTxts00 (my contexts array).
+ *
+ * SCOPE (input) Ptr to char
+ * Limit the scope of the operation.
+ * = 'R' : Operation is performed by a process row.
+ * = 'C' : Operation is performed by a process column.
+ * = 'A' : Operation is performed by all processes in grid.
+ *
+ * TOP (input) Ptr to char
+ * Controls fashion in which messages flow within the operation.
+ *
+ * M (input) Ptr to int
+ * The number of rows of the matrix A. M >= 0.
+ *
+ * N (input) Ptr to int
+ * The number of columns of the matrix A. N >= 0.
+ *
+ * A (input) Ptr to complex two dimensional array
+ * The m by n matrix A. Fortran77 (column-major) storage
+ * assumed.
+ *
+ * LDA (input) Ptr to int
+ * The leading dimension of the array A. LDA >= M.
+ *
+ * ------------------------------------------------------------------------
+ */
+{
+ void BI_ArgCheck(int, int, char *, char, char, char, int, int, int, int,
+ int *, int *);
+ int BI_HypBS(BLACSCONTEXT *, BLACBUFF *, SDRVPTR);
+ void BI_IdringBS(BLACSCONTEXT *, BLACBUFF *, SDRVPTR, int);
+ void BI_SringBS(BLACSCONTEXT *, BLACBUFF *, SDRVPTR);
+ void BI_MpathBS(BLACSCONTEXT *, BLACBUFF *, SDRVPTR, int);
+ void BI_TreeBS(BLACSCONTEXT *, BLACBUFF *, SDRVPTR, int);
+ void BI_UpdateBuffs(BLACBUFF *);
+ BLACBUFF *BI_GetBuff(int);
+ int BI_BuffIsFree(BLACBUFF *, int);
+ MPI_Datatype BI_GetMpiGeType(BLACSCONTEXT *, int, int, int,
+ MPI_Datatype, int *);
+ BLACBUFF *BI_Pack(BLACSCONTEXT *, BVOID *, BLACBUFF *, MPI_Datatype);
+ void BI_Ssend(BLACSCONTEXT *, int, int, BLACBUFF *);
+ void BI_Asend(BLACSCONTEXT *, int, int, BLACBUFF *);
+
+ char ttop, tscope;
+ int error, tlda;
+ MPI_Datatype MatTyp;
+ SDRVPTR send;
+ BLACBUFF *bp;
+ BLACSCONTEXT *ctxt;
+ extern BLACBUFF BI_AuxBuff, *BI_ActiveQ;
+/*
+ * get context, lowcase char variables, and perform parameter checking
+ */
+ MGetConTxt(Mpval(ConTxt), ctxt);
+ ttop = F2C_CharTrans(top);
+ ttop = Mlowcase(ttop);
+ tscope = F2C_CharTrans(scope);
+ tscope = Mlowcase(tscope);
+#if (BlacsDebugLvl > 0)
+ BI_ArgCheck(Mpval(ConTxt), RT_BS, __FILE__, 'a', 'u', 'u', Mpval(m),
+ Mpval(n), Mpval(lda), 0, NULL, NULL);
+#endif
+/*
+ * If the user has set the default broadcast topology, use it instead of
+ * BLACS default
+ */
+#ifdef DefBSTop
+ if (ttop == ' ') ttop = DefBSTop;
+#endif
+ if (Mpval(lda) < Mpval(m)) tlda = Mpval(m);
+ else tlda = Mpval(lda);
+
+ switch(tscope)
+ {
+ case 'r':
+ ctxt->scp = &ctxt->rscp;
+ break;
+ case 'c':
+ ctxt->scp = &ctxt->cscp;
+ break;
+ case 'a':
+ ctxt->scp = &ctxt->ascp;
+ break;
+ default:
+ BI_BlacsErr(Mpval(ConTxt), __LINE__, __FILE__, "Unknown scope '%c'",
+ tscope);
+ }
+
+ MatTyp = BI_GetMpiGeType(ctxt, Mpval(m), Mpval(n), tlda,
+ MPI_COMPLEX, &BI_AuxBuff.N);
+/*
+ * If using default topology, use MPI native broadcast
+ */
+ if (ttop == ' ')
+ {
+ error=MPI_Bcast(A, BI_AuxBuff.N, MatTyp, ctxt->scp->Iam, ctxt->scp->comm);
+ error=BI_MPI_TYPE_FREE(&MatTyp);
+ if (BI_ActiveQ) BI_UpdateBuffs(NULL);
+ return;
+ }
+/*
+ * If MPI handles non-contiguous buffering well, always use MPI data types
+ * instead of packing
+ */
+#ifndef MpiBuffGood
+/*
+ * If A is contiguous, send directly from it
+ */
+ else if ( (tlda == Mpval(m)) || (Mpval(n) == 1) )
+ {
+#endif
+ send = BI_Ssend;
+ BI_AuxBuff.Buff = (char *) A;
+ BI_AuxBuff.dtype = MatTyp;
+ bp = &BI_AuxBuff;
+#ifndef MpiBuffGood
+ }
+ else
+ {
+ send = BI_Asend;
+ bp = BI_Pack(ctxt, (BVOID *) A, NULL, MatTyp);
+ }
+#endif
+
+/*
+ * Call correct topology for BS/BR
+ */
+ switch(ttop)
+ {
+ case 'h':
+ error = BI_HypBS(ctxt, bp, send);
+ if (error == NPOW2) BI_TreeBS(ctxt, bp, send, 2);
+ break;
+ case '1':
+ case '2':
+ case '3':
+ case '4':
+ case '5':
+ case '6':
+ case '7':
+ case '8':
+ case '9':
+ BI_TreeBS(ctxt, bp, send, ttop-47);
+ break;
+ case 't':
+ BI_TreeBS(ctxt, bp, send, ctxt->Nb_bs);
+ break;
+ case 'i':
+ BI_IdringBS(ctxt, bp, send, 1);
+ break;
+ case 'd':
+ BI_IdringBS(ctxt, bp, send, -1);
+ break;
+ case 's':
+ BI_SringBS(ctxt, bp, send);
+ break;
+ case 'f':
+ BI_MpathBS(ctxt, bp, send, FULLCON);
+ break;
+ case 'm':
+ BI_MpathBS(ctxt, bp, send, ctxt->Nr_bs);
+ break;
+ default :
+ BI_BlacsErr(Mpval(ConTxt), __LINE__, __FILE__, "Unknown topology '%c'",
+ ttop);
+ }
+
+ error=BI_MPI_TYPE_FREE(&MatTyp);
+ if (bp == &BI_AuxBuff)
+ {
+ if (BI_ActiveQ) BI_UpdateBuffs(NULL);
+ }
+ else BI_UpdateBuffs(bp);
+} /* end cgebs2d_ */
diff --git a/BLACS/SRC/cgerv2d_.c b/BLACS/SRC/cgerv2d_.c
new file mode 100644
index 0000000..3b440bb
--- /dev/null
+++ b/BLACS/SRC/cgerv2d_.c
@@ -0,0 +1,82 @@
+#include "Bdef.h"
+
+#if (INTFACE == C_CALL)
+void Ccgerv2d(int ConTxt, int m, int n, float *A, int lda, int rsrc, int csrc)
+#else
+F_VOID_FUNC cgerv2d_(int *ConTxt, int *m, int *n, float *A, int *lda,
+ int *rsrc, int *csrc)
+#endif
+/*
+ * -- V1.1 BLACS routine --
+ * University of Tennessee, May 1, 1996
+ * Written by Clint Whaley.
+ *
+ * Purpose
+ * =======
+ * Globally-blocking point to point general complex receive.
+ *
+ * Arguments
+ * =========
+ *
+ * ConTxt (input) Ptr to int
+ * Index into MyConTxts00 (my contexts array).
+ *
+ * M (input) Ptr to int
+ * The number of rows of the matrix A. M >= 0.
+ *
+ * N (input) Ptr to int
+ * The number of columns of the matrix A. N >= 0.
+ *
+ * A (output) Ptr to complex two dimensional array
+ * The m by n matrix A. Fortran77 (column-major) storage
+ * assumed.
+ *
+ * LDA (input) Ptr to int
+ * The leading dimension of the array A. LDA >= M.
+ *
+ *
+ * RSRC (input) Ptr to int
+ * The process row of the source of the matrix.
+ *
+ * CSRC (input) Ptr to int
+ * The process column of the source of the matrix.
+ *
+ *
+ * ------------------------------------------------------------------------
+ */
+{
+/*
+ * Prototypes and variable declarations
+ */
+ void BI_ArgCheck(int, int, char *, char, char, char, int, int, int, int,
+ int *, int *);
+ MPI_Datatype BI_GetMpiGeType(BLACSCONTEXT *, int, int, int,
+ MPI_Datatype, int *);
+ void BI_Unpack(BLACSCONTEXT *, BVOID *, BLACBUFF *, MPI_Datatype);
+ void BI_Srecv(BLACSCONTEXT *, int, int, BLACBUFF *);
+ void BI_UpdateBuffs(BLACBUFF *);
+ BLACBUFF *BI_GetBuff(int);
+ int BI_BuffIsFree(BLACBUFF *, int);
+ int tlda;
+ int ierr;
+ MPI_Datatype MatTyp;
+ BLACSCONTEXT *ctxt;
+ extern BLACBUFF BI_AuxBuff, *BI_ActiveQ;
+
+ MGetConTxt(Mpval(ConTxt), ctxt);
+#if (BlacsDebugLvl > 0)
+ BI_ArgCheck(Mpval(ConTxt), RT_RV, __FILE__, 'a', 'u', 'u', Mpval(m),
+ Mpval(n), Mpval(lda), 1, Mpaddress(rsrc), Mpaddress(csrc));
+#endif
+ if (Mpval(lda) < Mpval(m)) tlda = Mpval(m);
+ else tlda = Mpval(lda);
+ ctxt->scp = &ctxt->pscp;
+
+ MatTyp = BI_GetMpiGeType(ctxt, Mpval(m), Mpval(n), tlda,
+ MPI_COMPLEX, &BI_AuxBuff.N);
+ BI_AuxBuff.Buff = (char *) A;
+ BI_AuxBuff.dtype = MatTyp;
+ BI_Srecv(ctxt, Mkpnum(ctxt, Mpval(rsrc), Mpval(csrc)), PT2PTID, &BI_AuxBuff);
+ ierr=BI_MPI_TYPE_FREE(&MatTyp);
+ if (BI_ActiveQ) BI_UpdateBuffs(NULL);
+}
diff --git a/BLACS/SRC/cgesd2d_.c b/BLACS/SRC/cgesd2d_.c
new file mode 100644
index 0000000..0c9bb57
--- /dev/null
+++ b/BLACS/SRC/cgesd2d_.c
@@ -0,0 +1,95 @@
+#include "Bdef.h"
+
+#if (INTFACE == C_CALL)
+void Ccgesd2d(int ConTxt, int m, int n, float *A, int lda,
+ int rdest, int cdest)
+#else
+F_VOID_FUNC cgesd2d_(int *ConTxt, int *m, int *n, float *A, int *lda,
+ int *rdest, int *cdest)
+#endif
+/*
+ * -- V1.1 BLACS routine --
+ * University of Tennessee, May 1, 1996
+ * Written by Clint Whaley.
+ *
+ * Purpose
+ * =======
+ * Locally-blocking point-to-point general complex send.
+ *
+ * Arguments
+ * =========
+ *
+ * ConTxt (input) Ptr to int
+ * Index into MyConTxts00 (my contexts array).
+ *
+ * M (input) Ptr to int
+ * The number of rows of the matrix A. M >= 0.
+ *
+ * N (input) Ptr to int
+ * The number of columns of the matrix A. N >= 0.
+ *
+ * A (input) Ptr to complex two dimensional array
+ * The m by n matrix A. Fortran77 (column-major) storage
+ * assumed.
+ *
+ * LDA (input) Ptr to int
+ * The leading dimension of the array A. LDA >= M.
+ *
+ * RDEST (input) Ptr to int
+ * The process row of the destination process.
+ *
+ * CDEST (input) Ptr to int
+ * The process column of the destination process.
+ *
+ * ------------------------------------------------------------------------
+ */
+{
+ void BI_ArgCheck(int, int, char *, char, char, char, int, int, int, int,
+ int *, int *);
+ MPI_Datatype BI_GetMpiGeType(BLACSCONTEXT *, int, int, int,
+ MPI_Datatype, int *);
+ BLACBUFF *BI_Pack(BLACSCONTEXT *, BVOID *, BLACBUFF *, MPI_Datatype);
+ void BI_Ssend(BLACSCONTEXT *, int, int, BLACBUFF *);
+ void BI_Asend(BLACSCONTEXT *, int, int, BLACBUFF *);
+ void BI_UpdateBuffs(BLACBUFF *);
+ BLACBUFF *BI_GetBuff(int);
+ int BI_BuffIsFree(BLACBUFF *, int);
+
+ int dest, tlda, ierr;
+ BLACBUFF *bp;
+ BLACSCONTEXT *ctxt;
+ MPI_Datatype MatTyp;
+ extern BLACBUFF BI_AuxBuff, *BI_ActiveQ;
+
+ MGetConTxt(Mpval(ConTxt), ctxt);
+#if (BlacsDebugLvl > 0)
+ BI_ArgCheck(Mpval(ConTxt), RT_SD, "CGESD2D", 'a', 'u', 'u', Mpval(m),
+ Mpval(n), Mpval(lda), 1, Mpaddress(rdest), Mpaddress(cdest));
+#endif
+ if (Mpval(lda) < Mpval(m)) tlda = Mpval(m);
+ else tlda = Mpval(lda);
+ dest = Mvkpnum(ctxt, Mpval(rdest), Mpval(cdest));
+ ctxt->scp = &ctxt->pscp;
+
+ MatTyp = BI_GetMpiGeType(ctxt, Mpval(m), Mpval(n), tlda,
+ MPI_COMPLEX, &BI_AuxBuff.N);
+#ifdef SndIsLocBlk
+ BI_AuxBuff.Buff = (char *) A;
+ BI_AuxBuff.dtype = MatTyp;
+ BI_Ssend(ctxt, dest, PT2PTID, &BI_AuxBuff);
+#else
+ bp = BI_Pack(ctxt, (BVOID *) A, NULL, MatTyp);
+ BI_Asend(ctxt, Mkpnum(ctxt, Mpval(rdest), Mpval(cdest)), PT2PTID, bp);
+#endif
+ ierr=BI_MPI_TYPE_FREE(&MatTyp);
+
+/*
+ * Having started the async send, update the buffers (reform links, check if
+ * active buffers have become inactive, etc.)
+ */
+#ifdef SndIsLocBlk
+ if (BI_ActiveQ) BI_UpdateBuffs(NULL);
+#else
+ BI_UpdateBuffs(bp);
+#endif
+} /* end of cgesd2d */
diff --git a/BLACS/SRC/cgsum2d_.c b/BLACS/SRC/cgsum2d_.c
new file mode 100644
index 0000000..348ede5
--- /dev/null
+++ b/BLACS/SRC/cgsum2d_.c
@@ -0,0 +1,238 @@
+#include "Bdef.h"
+
+
+#if (INTFACE == C_CALL)
+void Ccgsum2d(int ConTxt, char *scope, char *top, int m, int n, float *A,
+ int lda, int rdest, int cdest)
+#else
+F_VOID_FUNC cgsum2d_(int *ConTxt, F_CHAR scope, F_CHAR top, int *m, int *n,
+ float *A, int *lda, int *rdest, int *cdest)
+#endif
+/*
+ * -- V1.1 BLACS routine --
+ * University of Tennessee, May 1, 1996
+ * Written by Clint Whaley.
+ *
+ * Purpose
+ * =======
+ * Combine sum operation for complex rectangular matrices.
+ *
+ * Arguments
+ * =========
+ *
+ * ConTxt (input) Ptr to int
+ * Index into MyConTxts00 (my contexts array).
+ *
+ * SCOPE (input) Ptr to char
+ * Limit the scope of the operation.
+ * = 'R' : Operation is performed by a process row.
+ * = 'C' : Operation is performed by a process column.
+ * = 'A' : Operation is performed by all processes in grid.
+ *
+ * TOP (input) Ptr to char
+ * Controls fashion in which messages flow within the operation.
+ *
+ * M (input) Ptr to int
+ * The number of rows of the matrix A. M >= 0.
+ *
+ * N (input) Ptr to int
+ * The number of columns of the matrix A. N >= 0.
+ *
+ * A (output) Ptr to complex two dimensional array
+ * The m by n matrix A. Fortran77 (column-major) storage
+ * assumed.
+ *
+ * LDA (input) Ptr to int
+ * The leading dimension of the array A. LDA >= M.
+ *
+ * RDEST (input) Ptr to int
+ * The process row of the destination of the sum.
+ * If rdest == -1, then result is left on all processes in scope.
+ *
+ * CDEST (input) Ptr to int
+ * The process column of the destination of the sum.
+ * If rdest == -1, then CDEST ignored.
+ *
+ * ------------------------------------------------------------------------
+ */
+{
+ void BI_ArgCheck(int, int, char *, char, char, char, int, int, int, int,
+ int *, int *);
+ void BI_UpdateBuffs(BLACBUFF *);
+ BLACBUFF *BI_GetBuff(int);
+ int BI_BuffIsFree(BLACBUFF *, int);
+ MPI_Datatype BI_GetMpiGeType(BLACSCONTEXT *, int, int, int,
+ MPI_Datatype, int *);
+ BLACBUFF *BI_Pack(BLACSCONTEXT *, BVOID *, BLACBUFF *, MPI_Datatype);
+ MPI_Datatype BI_GetMpiGeType(BLACSCONTEXT *, int, int, int,
+ MPI_Datatype, int *);
+ void BI_Unpack(BLACSCONTEXT *, BVOID *, BLACBUFF *, MPI_Datatype);
+ void BI_MringComb(BLACSCONTEXT *, BLACBUFF *, BLACBUFF *, int, VVFUNPTR,
+ int, int);
+ void BI_TreeComb(BLACSCONTEXT *, BLACBUFF *, BLACBUFF *, int, VVFUNPTR,
+ int, int);
+ void BI_BeComb(BLACSCONTEXT *, BLACBUFF *, BLACBUFF *, int, VVFUNPTR);
+ void BI_cvvsum(int, char *, char *);
+ void BI_cMPI_sum(void *, void *, int *, MPI_Datatype *);
+/*
+ * Variable Declarations
+ */
+ BLACBUFF *bp, *bp2;
+ BLACSCONTEXT *ctxt;
+ char ttop, tscope;
+ int N, length, dest, tlda, trdest, ierr;
+ MPI_Op BlacComb;
+ extern BLACBUFF *BI_ActiveQ;
+ extern BLACBUFF BI_AuxBuff;
+
+ MGetConTxt(Mpval(ConTxt), ctxt);
+ ttop = F2C_CharTrans(top);
+ ttop = Mlowcase(ttop);
+ tscope = F2C_CharTrans(scope);
+ tscope = Mlowcase(tscope);
+/*
+ * If the user has set the default combine topology, use it instead of
+ * BLACS default
+ */
+#ifdef DefCombTop
+ if (ttop == ' ') ttop = DefCombTop;
+#endif
+ if (Mpval(cdest) == -1) trdest = -1;
+ else trdest = Mpval(rdest);
+#if (BlacsDebugLvl > 0)
+ BI_ArgCheck(Mpval(ConTxt), RT_COMB, __FILE__, tscope, 'u', 'u', Mpval(m),
+ Mpval(n), Mpval(lda), 1, &trdest, Mpaddress(cdest));
+#endif
+ if (Mpval(lda) >= Mpval(m)) tlda = Mpval(lda);
+ else tlda = Mpval(m);
+ switch(tscope)
+ {
+ case 'r':
+ ctxt->scp = &ctxt->rscp;
+ if (trdest == -1) dest = -1;
+ else dest = Mpval(cdest);
+ break;
+ case 'c':
+ ctxt->scp = &ctxt->cscp;
+ dest = trdest;
+ break;
+ case 'a':
+ ctxt->scp = &ctxt->ascp;
+ if (trdest == -1) dest = -1;
+ else dest = Mvkpnum(ctxt, trdest, Mpval(cdest));
+ break;
+ default:
+ BI_BlacsErr(Mpval(ConTxt), __LINE__, __FILE__, "Unknown scope '%c'",
+ tscope);
+ }
+/*
+ * It's not defined how MPI reacts to 0 element reductions, so use BLACS 1-tree
+ * topology if we've got one. Also, we can't use MPI functions if we need to
+ * guarantee repeatability.
+ */
+ if (ttop == ' ')
+ if ( (Mpval(m) < 1) || (Mpval(n) < 1) || (ctxt->TopsRepeat) ) ttop = '1';
+ N = Mpval(m) * Mpval(n);
+ length = N * sizeof(SCOMPLEX);
+/*
+ * If A is contiguous, we can use it as one of the buffers
+ */
+ if ( (Mpval(m) == tlda) || (Mpval(n) == 1) )
+ {
+ bp = &BI_AuxBuff;
+ bp->Buff = (char *) A;
+ bp2 = BI_GetBuff(length);
+ }
+/*
+ * Otherwise, we must allocate both buffers
+ */
+ else
+ {
+ bp = BI_GetBuff(length*2);
+ bp2 = &BI_AuxBuff;
+ bp2->Buff = &bp->Buff[length];
+ BI_cmvcopy(Mpval(m), Mpval(n), A, tlda, bp->Buff);
+ }
+ bp->dtype = bp2->dtype = MPI_COMPLEX;
+ bp->N = bp2->N = N;
+
+ switch(ttop)
+ {
+ case ' ': /* use MPI's reduction by default */
+ length = 1;
+ ierr=MPI_Op_create(BI_cMPI_sum, length, &BlacComb);
+ if (dest != -1)
+ {
+ ierr=MPI_Reduce(bp->Buff, bp2->Buff, bp->N, bp->dtype, BlacComb,
+ dest, ctxt->scp->comm);
+ if (ctxt->scp->Iam == dest)
+ BI_cvmcopy(Mpval(m), Mpval(n), A, tlda, bp2->Buff);
+ }
+ else
+ {
+ ierr=MPI_Allreduce(bp->Buff, bp2->Buff, bp->N, bp->dtype, BlacComb,
+ ctxt->scp->comm);
+ BI_cvmcopy(Mpval(m), Mpval(n), A, tlda, bp2->Buff);
+ }
+ ierr=MPI_Op_free(&BlacComb);
+ if (BI_ActiveQ) BI_UpdateBuffs(NULL);
+ return;
+ break;
+ case 'i':
+ BI_MringComb(ctxt, bp, bp2, N, BI_cvvsum, dest, 1);
+ break;
+ case 'd':
+ BI_MringComb(ctxt, bp, bp2, N, BI_cvvsum, dest, -1);
+ break;
+ case 's':
+ BI_MringComb(ctxt, bp, bp2, N, BI_cvvsum, dest, 2);
+ break;
+ case 'm':
+ BI_MringComb(ctxt, bp, bp2, N, BI_cvvsum, dest, ctxt->Nr_co);
+ break;
+ case '1':
+ case '2':
+ case '3':
+ case '4':
+ case '5':
+ case '6':
+ case '7':
+ case '8':
+ case '9':
+ BI_TreeComb(ctxt, bp, bp2, N, BI_cvvsum, dest, ttop-47);
+ break;
+ case 'f':
+ BI_TreeComb(ctxt, bp, bp2, N, BI_cvvsum, dest, FULLCON);
+ break;
+ case 't':
+ BI_TreeComb(ctxt, bp, bp2, N, BI_cvvsum, dest, ctxt->Nb_co);
+ break;
+ case 'h':
+/*
+ * Use bidirectional exchange if everyone wants answer
+ */
+ if ( (trdest == -1) && !(ctxt->TopsCohrnt) )
+ BI_BeComb(ctxt, bp, bp2, N, BI_cvvsum);
+ else
+ BI_TreeComb(ctxt, bp, bp2, N, BI_cvvsum, dest, 2);
+ break;
+ default :
+ BI_BlacsErr(Mpval(ConTxt), __LINE__, __FILE__, "Unknown topology '%c'",
+ ttop);
+ }
+
+/*
+ * If I am selected to receive answer
+ */
+ if (bp != &BI_AuxBuff)
+ {
+ if ( (ctxt->scp->Iam == dest) || (dest == -1) )
+ BI_cvmcopy(Mpval(m), Mpval(n), A, tlda, bp->Buff);
+ BI_UpdateBuffs(bp);
+ }
+ else
+ {
+ if (BI_ActiveQ) BI_UpdateBuffs(NULL);
+ BI_BuffIsFree(bp, 1);
+ }
+}
diff --git a/BLACS/SRC/ctrbr2d_.c b/BLACS/SRC/ctrbr2d_.c
new file mode 100644
index 0000000..850b066
--- /dev/null
+++ b/BLACS/SRC/ctrbr2d_.c
@@ -0,0 +1,224 @@
+#include "Bdef.h"
+
+#if (INTFACE == C_CALL)
+void Cctrbr2d(int ConTxt, char *scope, char *top, char *uplo, char *diag,
+ int m, int n, float *A, int lda, int rsrc, int csrc)
+#else
+F_VOID_FUNC ctrbr2d_(int *ConTxt, F_CHAR scope, F_CHAR top, F_CHAR uplo,
+ F_CHAR diag, int *m, int *n, float *A, int *lda,
+ int *rsrc, int *csrc)
+#endif
+/*
+ * -- V1.1 BLACS routine --
+ * University of Tennessee, May 1, 1996
+ * Written by Clint Whaley.
+ *
+ * Purpose
+ * =======
+ * Broadcast/receive for trapezoidal complex arrays.
+ *
+ * Arguments
+ * =========
+ *
+ * ConTxt (input) Ptr to int
+ * Index into MyConTxts00 (my contexts array).
+ *
+ * SCOPE (input) Ptr to char
+ * Limit the scope of the operation.
+ * = 'R' : Operation is performed by a process row.
+ * = 'C' : Operation is performed by a process column.
+ * = 'A' : Operation is performed by all processes in grid.
+ *
+ * TOP (input) Ptr to char
+ * Controls fashion in which messages flow within the operation.
+ *
+ * UPLO (input) Ptr to char
+ * Specifies the part of the matrix to be sent.
+ * = 'U': Upper trapezoidal part
+ * ELSE : Lower trapezoidal part
+ *
+ * DIAG (input) Ptr to char
+ * Specifies whether the matrix is unit diagonal or not.
+ * = 'U': Matrix is unit diagonal, diagonal not communicated.
+ * ELSE : Matrix is not unit diagonal, diagonal is communicated.
+ *
+ * M (input) Ptr to int
+ * The number of rows of the matrix A. M >= 0.
+ *
+ * N (input) Ptr to int
+ * The number of columns of the matrix A. N >= 0.
+ *
+ * A (output) Ptr to complex two dimensional array
+ * The m by n matrix A. Fortran77 (column-major) storage
+ * assumed.
+ * If UPLO = 'U', only the upper trapezoid is accessed;
+ * if UPLO = 'L', only the lower trapezoid is accessed.
+ *
+ * LDA (input) Ptr to int
+ * The leading dimension of the array A. LDA >= M.
+ *
+ *
+ * RSRC (input) Ptr to int
+ * The process row of the source of the matrix.
+ *
+ * CSRC (input) Ptr to int
+ * The process column of the source of the matrix.
+ *
+ *
+ * ------------------------------------------------------------------------
+ */
+{
+ void BI_ArgCheck(int, int, char *, char, char, char, int, int, int, int,
+ int *, int *);
+ int BI_HypBR(BLACSCONTEXT *, BLACBUFF *, SDRVPTR, int);
+ void BI_IdringBR(BLACSCONTEXT *, BLACBUFF *, SDRVPTR, int, int);
+ void BI_SringBR(BLACSCONTEXT *, BLACBUFF *, SDRVPTR, int);
+ void BI_MpathBR(BLACSCONTEXT *, BLACBUFF *, SDRVPTR, int, int);
+ void BI_TreeBR(BLACSCONTEXT *, BLACBUFF *, SDRVPTR, int, int);
+ void BI_UpdateBuffs(BLACBUFF *);
+ BLACBUFF *BI_GetBuff(int);
+ int BI_BuffIsFree(BLACBUFF *, int);
+ MPI_Datatype BI_GetMpiTrType(BLACSCONTEXT *, char, char, int, int, int,
+ MPI_Datatype, int *);
+ void BI_Unpack(BLACSCONTEXT *, BVOID *, BLACBUFF *, MPI_Datatype);
+ void BI_Ssend(BLACSCONTEXT *, int, int, BLACBUFF *);
+ void BI_Asend(BLACSCONTEXT *, int, int, BLACBUFF *);
+
+ BLACSCONTEXT *ctxt;
+ BLACBUFF *bp=NULL;
+ SDRVPTR send;
+ MPI_Datatype MatTyp;
+ int length, src, tlda, error, one=1;
+ char ttop, tscope, tuplo, tdiag;
+ extern BLACBUFF BI_AuxBuff, *BI_ActiveQ;
+
+ MGetConTxt(Mpval(ConTxt), ctxt);
+ ttop = F2C_CharTrans(top);
+ ttop = Mlowcase(ttop);
+ tscope = F2C_CharTrans(scope);
+ tscope = Mlowcase(tscope);
+ tdiag = F2C_CharTrans(diag);
+ tdiag = Mlowcase(tdiag);
+ tuplo = F2C_CharTrans(uplo);
+ tuplo = Mlowcase(tuplo);
+#if (BlacsDebugLvl > 0)
+ BI_ArgCheck(Mpval(ConTxt), RT_BR, __FILE__, tscope, tuplo, tdiag, Mpval(m),
+ Mpval(n), Mpval(lda), 1, Mpaddress(rsrc), Mpaddress(csrc));
+#endif
+/*
+ * If the user has set the default broadcast topology, use it instead of
+ * BLACS default
+ */
+#ifdef DefBSTop
+ if (ttop == ' ') ttop = DefBSTop;
+#endif
+ if (Mpval(m) <= Mpval(lda)) tlda = Mpval(lda);
+ else tlda = Mpval(m);
+
+ switch(tscope)
+ {
+ case 'r':
+ ctxt->scp = &ctxt->rscp;
+ src = Mpval(csrc);
+ break;
+ case 'c':
+ ctxt->scp = &ctxt->cscp;
+ src = Mpval(rsrc);
+ break;
+ case 'a':
+ ctxt->scp = &ctxt->ascp;
+ src = Mvkpnum(ctxt, Mpval(rsrc), Mpval(csrc));
+ break;
+ default:
+ BI_BlacsErr(Mpval(ConTxt), __LINE__, __FILE__, "Unknown scope '%c'",
+ tscope);
+ }
+
+ MatTyp = BI_GetMpiTrType(ctxt, tuplo, tdiag, Mpval(m), Mpval(n), tlda,
+ MPI_COMPLEX, &BI_AuxBuff.N);
+/*
+ * If using default topology, use MPI native broadcast
+ */
+ if (ttop == ' ')
+ {
+ error=MPI_Bcast(A, BI_AuxBuff.N, MatTyp, src, ctxt->scp->comm);
+ error=BI_MPI_TYPE_FREE(&MatTyp);
+ if (BI_ActiveQ) BI_UpdateBuffs(NULL);
+ return;
+ }
+/*
+ * If MPI handles non-contiguous buffering well, always use MPI data types
+ * instead of packing
+ */
+#ifdef MpiBuffGood
+ send = BI_Ssend;
+ BI_AuxBuff.Buff = (char *) A;
+ BI_AuxBuff.dtype = MatTyp;
+ bp = &BI_AuxBuff;
+#else
+
+ send = BI_Asend;
+ MPI_Pack_size(one, MatTyp, ctxt->scp->comm, &length, error);
+ bp = BI_GetBuff(length);
+ bp->N = length;
+ bp->dtype = MPI_PACKED;
+#if ZeroByteTypeBug
+ if (MatTyp == MPI_BYTE)
+ {
+ send = BI_Ssend;
+ bp->N = 0;
+ bp->dtype = MPI_BYTE;
+ }
+#endif
+
+#endif
+
+ switch(ttop)
+ {
+ case 'h':
+ error = BI_HypBR(ctxt, bp, send, src);
+ if (error == NPOW2) BI_TreeBR(ctxt, bp, send, src, 2);
+ break;
+ case '1':
+ case '2':
+ case '3':
+ case '4':
+ case '5':
+ case '6':
+ case '7':
+ case '8':
+ case '9':
+ BI_TreeBR(ctxt, bp, send, src, ttop-47);
+ break;
+ case 't':
+ BI_TreeBR(ctxt, bp, send, src, ctxt->Nb_bs);
+ break;
+ case 'i':
+ BI_IdringBR(ctxt, bp, send, src, 1);
+ break;
+ case 'd':
+ BI_IdringBR(ctxt, bp, send, src, -1);
+ break;
+ case 's':
+ BI_SringBR(ctxt, bp, send, src);
+ break;
+ case 'm':
+ BI_MpathBR(ctxt, bp, send, src, ctxt->Nr_bs);
+ break;
+ case 'f':
+ BI_MpathBR(ctxt, bp, send, src, FULLCON);
+ break;
+ default :
+ BI_BlacsErr(Mpval(ConTxt), __LINE__, __FILE__, "Unknown topology '%c'",
+ ttop);
+ }
+
+#ifdef MpiBuffGood
+ error=BI_MPI_TYPE_FREE(&MatTyp);
+ if (BI_ActiveQ) BI_UpdateBuffs(NULL);
+#endif
+#ifndef MpiBuffGood
+ BI_Unpack(ctxt, (BVOID *) A, bp, MatTyp);
+ BI_UpdateBuffs(bp);
+#endif
+}
diff --git a/BLACS/SRC/ctrbs2d_.c b/BLACS/SRC/ctrbs2d_.c
new file mode 100644
index 0000000..ef87fae
--- /dev/null
+++ b/BLACS/SRC/ctrbs2d_.c
@@ -0,0 +1,206 @@
+#include "Bdef.h"
+
+#if (INTFACE == C_CALL)
+void Cctrbs2d(int ConTxt, char *scope, char *top, char *uplo, char *diag,
+ int m, int n, float *A, int lda)
+#else
+F_VOID_FUNC ctrbs2d_(int *ConTxt, F_CHAR scope, F_CHAR top, F_CHAR uplo,
+ F_CHAR diag, int *m, int *n, float *A, int *lda)
+#endif
+/*
+ * -- V1.1 BLACS routine --
+ * University of Tennessee, May 1, 1996
+ * Written by Clint Whaley.
+ *
+ * Purpose
+ * =======
+ * Broadcast/send for trapezoidal complex arrays.
+ *
+ * Arguments
+ * =========
+ *
+ * ConTxt (input) Ptr to int
+ * Index into MyConTxts00 (my contexts array).
+ *
+ * SCOPE (input) Ptr to char
+ * Limit the scope of the operation.
+ * = 'R' : Operation is performed by a process row.
+ * = 'C' : Operation is performed by a process column.
+ * = 'A' : Operation is performed by all processes in grid.
+ *
+ * TOP (input) Ptr to char
+ * Controls fashion in which messages flow within the operation.
+ *
+ * UPLO (input) Ptr to char
+ * Specifies the part of the matrix to be sent.
+ * = 'U': Upper trapezoidal part
+ * ELSE : Lower trapezoidal part
+ *
+ * DIAG (input) Ptr to char
+ * Specifies whether the matrix is unit diagonal or not.
+ * = 'U': Matrix is unit diagonal, diagonal not communicated.
+ * ELSE : Matrix is not unit diagonal, diagonal is communicated.
+ *
+ * M (input) Ptr to int
+ * The number of rows of the matrix A. M >= 0.
+ *
+ * N (input) Ptr to int
+ * The number of columns of the matrix A. N >= 0.
+ *
+ * A (input) Ptr to complex two dimensional array
+ * The m by n matrix A. Fortran77 (column-major) storage
+ * assumed.
+ * If UPLO = 'U', only the upper trapezoid is accessed;
+ * if UPLO = 'L', only the lower trapezoid is accessed.
+ *
+ * LDA (input) Ptr to int
+ * The leading dimension of the array A. LDA >= M.
+ *
+ * ------------------------------------------------------------------------
+ */
+{
+ void BI_ArgCheck(int, int, char *, char, char, char, int, int, int, int,
+ int *, int *);
+ int BI_HypBS(BLACSCONTEXT *, BLACBUFF *, SDRVPTR);
+ void BI_IdringBS(BLACSCONTEXT *, BLACBUFF *, SDRVPTR, int);
+ void BI_SringBS(BLACSCONTEXT *, BLACBUFF *, SDRVPTR);
+ void BI_MpathBS(BLACSCONTEXT *, BLACBUFF *, SDRVPTR, int);
+ void BI_TreeBS(BLACSCONTEXT *, BLACBUFF *, SDRVPTR, int);
+ void BI_UpdateBuffs(BLACBUFF *);
+ BLACBUFF *BI_GetBuff(int);
+ int BI_BuffIsFree(BLACBUFF *, int);
+ MPI_Datatype BI_GetMpiTrType(BLACSCONTEXT *, char, char, int, int, int,
+ MPI_Datatype, int *);
+ BLACBUFF *BI_Pack(BLACSCONTEXT *, BVOID *, BLACBUFF *, MPI_Datatype);
+ void BI_Ssend(BLACSCONTEXT *, int, int, BLACBUFF *);
+ void BI_Asend(BLACSCONTEXT *, int, int, BLACBUFF *);
+
+ char ttop, tscope, tuplo, tdiag;
+ int error, tlda;
+ MPI_Datatype MatTyp;
+ SDRVPTR send;
+ BLACBUFF *bp;
+ BLACSCONTEXT *ctxt;
+ extern BLACBUFF BI_AuxBuff, *BI_ActiveQ;
+/*
+ * get context, lowcase char variables, and perform parameter checking
+ */
+ MGetConTxt(Mpval(ConTxt), ctxt);
+ ttop = F2C_CharTrans(top);
+ ttop = Mlowcase(ttop);
+ tscope = F2C_CharTrans(scope);
+ tscope = Mlowcase(tscope);
+ tuplo = F2C_CharTrans(uplo);
+ tuplo = Mlowcase(tuplo);
+ tdiag = F2C_CharTrans(diag);
+ tdiag = Mlowcase(tdiag);
+#if (BlacsDebugLvl > 0)
+ BI_ArgCheck(Mpval(ConTxt), RT_BS, __FILE__, 'a', tuplo, tdiag, Mpval(m),
+ Mpval(n), Mpval(lda), 0, NULL, NULL);
+#endif
+/*
+ * If the user has set the default broadcast topology, use it instead of
+ * BLACS default
+ */
+#ifdef DefBSTop
+ if (ttop == ' ') ttop = DefBSTop;
+#endif
+ if (Mpval(lda) < Mpval(m)) tlda = Mpval(m);
+ else tlda = Mpval(lda);
+
+ switch(tscope)
+ {
+ case 'r':
+ ctxt->scp = &ctxt->rscp;
+ break;
+ case 'c':
+ ctxt->scp = &ctxt->cscp;
+ break;
+ case 'a':
+ ctxt->scp = &ctxt->ascp;
+ break;
+ default:
+ BI_BlacsErr(Mpval(ConTxt), __LINE__, __FILE__, "Unknown scope '%c'",
+ tscope);
+ }
+ MatTyp = BI_GetMpiTrType(ctxt, tuplo, tdiag, Mpval(m), Mpval(n), tlda,
+ MPI_COMPLEX, &BI_AuxBuff.N);
+/*
+ * If using default topology, use MPI native broadcast
+ */
+ if (ttop == ' ')
+ {
+ error=MPI_Bcast(A, BI_AuxBuff.N, MatTyp, ctxt->scp->Iam, ctxt->scp->comm);
+ error=BI_MPI_TYPE_FREE(&MatTyp);
+ if (BI_ActiveQ) BI_UpdateBuffs(NULL);
+ return;
+ }
+/*
+ * If MPI handles non-contiguous buffering well, always use MPI data types
+ * instead of packing
+ */
+#ifdef MpiBuffGood
+ send = BI_Ssend;
+ BI_AuxBuff.Buff = (char *) A;
+ BI_AuxBuff.dtype = MatTyp;
+ bp = &BI_AuxBuff;
+#endif
+/*
+ * Pack and use non-blocking sends for broadcast if MPI's data types aren't
+ * more efficient
+ */
+#ifndef MpiBuffGood
+ send = BI_Asend;
+ bp = BI_Pack(ctxt, (BVOID *) A, NULL, MatTyp);
+#endif
+
+/*
+ * Call correct topology for BS/BR
+ */
+ switch(ttop)
+ {
+ case 'h':
+ error = BI_HypBS(ctxt, bp, send);
+ if (error == NPOW2) BI_TreeBS(ctxt, bp, send, 2);
+ break;
+ case '1':
+ case '2':
+ case '3':
+ case '4':
+ case '5':
+ case '6':
+ case '7':
+ case '8':
+ case '9':
+ BI_TreeBS(ctxt, bp, send, ttop-47);
+ break;
+ case 't':
+ BI_TreeBS(ctxt, bp, send, ctxt->Nb_bs);
+ break;
+ case 'i':
+ BI_IdringBS(ctxt, bp, send, 1);
+ break;
+ case 'd':
+ BI_IdringBS(ctxt, bp, send, -1);
+ break;
+ case 's':
+ BI_SringBS(ctxt, bp, send);
+ break;
+ case 'f':
+ BI_MpathBS(ctxt, bp, send, FULLCON);
+ break;
+ case 'm':
+ BI_MpathBS(ctxt, bp, send, ctxt->Nr_bs);
+ break;
+ default :
+ BI_BlacsErr(Mpval(ConTxt), __LINE__, __FILE__, "Unknown topology '%c'",
+ ttop);
+ }
+
+ error=BI_MPI_TYPE_FREE(&MatTyp);
+ if (bp == &BI_AuxBuff)
+ {
+ if (BI_ActiveQ) BI_UpdateBuffs(NULL);
+ }
+ else BI_UpdateBuffs(bp);
+} /* end ctrbs2d_ */
diff --git a/BLACS/SRC/ctrrv2d_.c b/BLACS/SRC/ctrrv2d_.c
new file mode 100644
index 0000000..3f99eac
--- /dev/null
+++ b/BLACS/SRC/ctrrv2d_.c
@@ -0,0 +1,101 @@
+#include "Bdef.h"
+
+#if (INTFACE == C_CALL)
+void Cctrrv2d(int ConTxt, char *uplo, char *diag, int m, int n, float *A,
+ int lda, int rsrc, int csrc)
+#else
+F_VOID_FUNC ctrrv2d_(int *ConTxt, F_CHAR uplo, F_CHAR diag, int *m, int *n,
+ float *A, int *lda, int *rsrc, int *csrc)
+#endif
+/*
+ * -- V1.1 BLACS routine --
+ * University of Tennessee, May 1, 1996
+ * Written by Clint Whaley.
+ *
+ * Purpose
+ * =======
+ * Globally-blocking point to point trapezoidal complex receive.
+ *
+ * Arguments
+ * =========
+ *
+ * ConTxt (input) Ptr to int
+ * Index into MyConTxts00 (my contexts array).
+ *
+ * UPLO (input) Ptr to char
+ * Specifies the part of the matrix to be sent.
+ * = 'U': Upper trapezoidal part
+ * ELSE : Lower trapezoidal part
+ *
+ * DIAG (input) Ptr to char
+ * Specifies whether the matrix is unit diagonal or not.
+ * = 'U': Matrix is unit diagonal, diagonal not communicated.
+ * ELSE : Matrix is not unit diagonal, diagonal is communicated.
+ *
+ * M (input) Ptr to int
+ * The number of rows of the matrix A. M >= 0.
+ *
+ * N (input) Ptr to int
+ * The number of columns of the matrix A. N >= 0.
+ *
+ * A (output) Ptr to complex two dimensional array
+ * The m by n matrix A. Fortran77 (column-major) storage
+ * assumed.
+ * If UPLO = 'U', only the upper trapezoid is accessed;
+ * if UPLO = 'L', only the lower trapezoid is accessed.
+ *
+ * LDA (input) Ptr to int
+ * The leading dimension of the array A. LDA >= M.
+ *
+ *
+ * RSRC (input) Ptr to int
+ * The process row of the source of the matrix.
+ *
+ * CSRC (input) Ptr to int
+ * The process column of the source of the matrix.
+ *
+ *
+ * ------------------------------------------------------------------------
+ */
+{
+/*
+ * Prototypes and variable declarations
+ */
+ void BI_ArgCheck(int, int, char *, char, char, char, int, int, int, int,
+ int *, int *);
+ MPI_Datatype BI_GetMpiTrType(BLACSCONTEXT *, char, char, int, int, int,
+ MPI_Datatype, int *);
+ void BI_Unpack(BLACSCONTEXT *, BVOID *, BLACBUFF *, MPI_Datatype);
+ void BI_Srecv(BLACSCONTEXT *, int, int, BLACBUFF *);
+ void BI_UpdateBuffs(BLACBUFF *);
+ BLACBUFF *BI_GetBuff(int);
+ int BI_BuffIsFree(BLACBUFF *, int);
+ int tuplo, tdiag, tlda;
+ int ierr, length;
+ BLACBUFF *bp;
+ MPI_Datatype MatTyp;
+ BLACSCONTEXT *ctxt;
+ extern BLACBUFF BI_AuxBuff, *BI_ActiveQ;
+
+ MGetConTxt(Mpval(ConTxt), ctxt);
+ tdiag = F2C_CharTrans(diag);
+ tuplo = F2C_CharTrans(uplo);
+ tdiag = Mlowcase(tdiag);
+ tuplo = Mlowcase(tuplo);
+
+#if (BlacsDebugLvl > 0)
+ BI_ArgCheck(Mpval(ConTxt), RT_RV, __FILE__, 'a', tuplo, tdiag, Mpval(m),
+ Mpval(n), Mpval(lda), 1, Mpaddress(rsrc), Mpaddress(csrc));
+#endif
+ if (Mpval(lda) < Mpval(m)) tlda = Mpval(m);
+ else tlda = Mpval(lda);
+ ctxt->scp = &ctxt->pscp;
+
+ MatTyp = BI_GetMpiTrType(ctxt, tuplo, tdiag, Mpval(m), Mpval(n), tlda,
+ MPI_COMPLEX, &BI_AuxBuff.N);
+ BI_AuxBuff.Buff = (char *) A;
+ BI_AuxBuff.dtype = MatTyp;
+ BI_Srecv(ctxt, Mkpnum(ctxt, Mpval(rsrc), Mpval(csrc)), PT2PTID, &BI_AuxBuff);
+ ierr=BI_MPI_TYPE_FREE(&MatTyp);
+ if (BI_ActiveQ) BI_UpdateBuffs(NULL);
+}
diff --git a/BLACS/SRC/ctrsd2d_.c b/BLACS/SRC/ctrsd2d_.c
new file mode 100644
index 0000000..c40c01e
--- /dev/null
+++ b/BLACS/SRC/ctrsd2d_.c
@@ -0,0 +1,113 @@
+#include "Bdef.h"
+
+#if (INTFACE == C_CALL)
+void Cctrsd2d(int ConTxt, char *uplo, char *diag, int m, int n, float *A,
+ int lda, int rdest, int cdest)
+#else
+F_VOID_FUNC ctrsd2d_(int *ConTxt, F_CHAR uplo, F_CHAR diag, int *m, int *n,
+ float *A, int *lda, int *rdest, int *cdest)
+#endif
+/*
+ * -- V1.1 BLACS routine --
+ * University of Tennessee, May 1, 1996
+ * Written by Clint Whaley.
+ *
+ * Purpose
+ * =======
+ * Locally-blocking point-to-point trapezoidal complex send.
+ *
+ * Arguments
+ * =========
+ *
+ * ConTxt (input) Ptr to int
+ * Index into MyConTxts00 (my contexts array).
+ *
+ * UPLO (input) Ptr to char
+ * Specifies the part of the matrix to be sent.
+ * = 'U': Upper trapezoidal part
+ * ELSE : Lower trapezoidal part
+ *
+ * DIAG (input) Ptr to char
+ * Specifies whether the matrix is unit diagonal or not.
+ * = 'U': Matrix is unit diagonal, diagonal not communicated.
+ * ELSE : Matrix is not unit diagonal, diagonal is communicated.
+ *
+ * M (input) Ptr to int
+ * The number of rows of the matrix A. M >= 0.
+ *
+ * N (input) Ptr to int
+ * The number of columns of the matrix A. N >= 0.
+ *
+ * A (input) Ptr to complex two dimensional array
+ * The m by n matrix A. Fortran77 (column-major) storage
+ * assumed.
+ * If UPLO = 'U', only the upper trapezoid is accessed;
+ * if UPLO = 'L', only the lower trapezoid is accessed.
+ *
+ * LDA (input) Ptr to int
+ * The leading dimension of the array A. LDA >= M.
+ *
+ * RDEST (input) Ptr to int
+ * The process row of the destination process.
+ *
+ * CDEST (input) Ptr to int
+ * The process column of the destination process.
+ *
+ * ------------------------------------------------------------------------
+ */
+{
+ void BI_ArgCheck(int, int, char *, char, char, char, int, int, int, int,
+ int *, int *);
+ MPI_Datatype BI_GetMpiTrType(BLACSCONTEXT *, char, char, int, int, int,
+ MPI_Datatype, int *);
+ BLACBUFF *BI_Pack(BLACSCONTEXT *, BVOID *, BLACBUFF *, MPI_Datatype);
+ void BI_Ssend(BLACSCONTEXT *, int, int, BLACBUFF *);
+ void BI_Asend(BLACSCONTEXT *, int, int, BLACBUFF *);
+ void BI_UpdateBuffs(BLACBUFF *);
+ BLACBUFF *BI_GetBuff(int);
+ int BI_BuffIsFree(BLACBUFF *, int);
+
+ char tuplo, tdiag;
+ int dest, length, tlda, ierr;
+ BLACBUFF *bp;
+ BLACSCONTEXT *ctxt;
+ MPI_Datatype MatTyp;
+ extern BLACBUFF BI_AuxBuff, *BI_ActiveQ;
+
+ MGetConTxt(Mpval(ConTxt), ctxt);
+ tuplo = F2C_CharTrans(uplo);
+ tdiag = F2C_CharTrans(diag);
+ tuplo = Mlowcase(tuplo);
+ tdiag = Mlowcase(tdiag);
+
+#if (BlacsDebugLvl > 0)
+ BI_ArgCheck(Mpval(ConTxt), RT_SD, "CTRSD2D", 'a', tuplo, tdiag, Mpval(m),
+ Mpval(n), Mpval(lda), 1, Mpaddress(rdest), Mpaddress(cdest));
+#endif
+ if (Mpval(lda) < Mpval(m)) tlda = Mpval(m);
+ else tlda = Mpval(lda);
+ dest = Mvkpnum(ctxt, Mpval(rdest), Mpval(cdest));
+ ctxt->scp = &ctxt->pscp;
+
+ MatTyp = BI_GetMpiTrType(ctxt, tuplo, tdiag, Mpval(m), Mpval(n), tlda,
+ MPI_COMPLEX, &BI_AuxBuff.N);
+#ifdef SndIsLocBlk
+ BI_AuxBuff.Buff = (char *) A;
+ BI_AuxBuff.dtype = MatTyp;
+ BI_Ssend(ctxt, dest, PT2PTID, &BI_AuxBuff);
+#else
+ bp = BI_Pack(ctxt, (BVOID *) A, NULL, MatTyp);
+ BI_Asend(ctxt, Mkpnum(ctxt, Mpval(rdest), Mpval(cdest)), PT2PTID, bp);
+#endif
+ ierr=BI_MPI_TYPE_FREE(&MatTyp);
+
+/*
+ * Having started the async send, update the buffers (reform links, check if
+ * active buffers have become inactive, etc.)
+ */
+#ifdef SndIsLocBlk
+ if (BI_ActiveQ) BI_UpdateBuffs(NULL);
+#else
+ BI_UpdateBuffs(bp);
+#endif
+} /* end of ctrsd2d */
diff --git a/BLACS/SRC/dcputime00_.c b/BLACS/SRC/dcputime00_.c
new file mode 100644
index 0000000..fa51b1c
--- /dev/null
+++ b/BLACS/SRC/dcputime00_.c
@@ -0,0 +1,10 @@
+#include "Bdef.h"
+
+#if (INTFACE == C_CALL)
+double Cdcputime00(void)
+#else
+F_DOUBLE_FUNC dcputime00_(void)
+#endif
+{
+ return(-1.0);
+}
diff --git a/BLACS/SRC/dgamn2d_.c b/BLACS/SRC/dgamn2d_.c
new file mode 100644
index 0000000..dff23b4
--- /dev/null
+++ b/BLACS/SRC/dgamn2d_.c
@@ -0,0 +1,373 @@
+#include "Bdef.h"
+
+
+
+#if (INTFACE == C_CALL)
+void Cdgamn2d(int ConTxt, char *scope, char *top, int m, int n, double *A,
+ int lda, int *rA, int *cA, int ldia, int rdest, int cdest)
+#else
+F_VOID_FUNC dgamn2d_(int *ConTxt, F_CHAR scope, F_CHAR top, int *m, int *n,
+ double *A, int *lda, int *rA, int *cA, int *ldia,
+ int *rdest, int *cdest)
+#endif
+/*
+ * -- V1.1 BLACS routine --
+ * University of Tennessee, May 1, 1996
+ * Written by Clint Whaley.
+ *
+ * Purpose
+ * =======
+ * Combine amn operation for double precision rectangular matrices.
+ *
+ * Arguments
+ * =========
+ *
+ * ConTxt (input) Ptr to int
+ * Index into MyConTxts00 (my contexts array).
+ *
+ * SCOPE (input) Ptr to char
+ * Limit the scope of the operation.
+ * = 'R' : Operation is performed by a process row.
+ * = 'C' : Operation is performed by a process column.
+ * = 'A' : Operation is performed by all processes in grid.
+ *
+ * TOP (input) Ptr to char
+ * Controls fashion in which messages flow within the operation.
+ *
+ * M (input) Ptr to int
+ * The number of rows of the matrix A. M >= 0.
+ *
+ * N (input) Ptr to int
+ * The number of columns of the matrix A. N >= 0.
+ *
+ * A (output) Ptr to double precision two dimensional array
+ * The m by n matrix A. Fortran77 (column-major) storage
+ * assumed.
+ *
+ * LDA (input) Ptr to int
+ * The leading dimension of the array A. LDA >= M.
+ *
+ * RA (output) Integer Array, dimension (LDIA, N)
+ * Contains process row that the amn of each element
+ * of A was found on: i.e., rA(1,2) contains the process
+ * row that the amn of A(1,2) was found on.
+ * Values are left on process {rdest, cdest} only, others
+ * may be modified, but not left with interesting data.
+ * If rdest == -1, then result is left on all processes in scope.
+ * If LDIA == -1, this array is not accessed, and need not exist.
+ *
+ * CA (output) Integer Array, dimension (LDIA, N)
+ * Contains process column that the amn of each element
+ * of A was found on: i.e., cA(1,2) contains the process
+ * column that the max/min of A(1,2) was found on.
+ * Values are left on process {rdest, cdest} only, others
+ * may be modified, but not left with interesting data.
+ * If rdest == -1, then result is left on all processes in scope.
+ * If LDIA == -1, this array is not accessed, and need not exist.
+ *
+ * LDIA (input) Ptr to int
+ * If (LDIA == -1), then the arrays RA and CA are not accessed.
+ * ELSE leading dimension of the arrays RA and CA. LDIA >= M.
+ *
+ * RDEST (input) Ptr to int
+ * The process row of the destination of the amn.
+ * If rdest == -1, then result is left on all processes in scope.
+ *
+ * CDEST (input) Ptr to int
+ * The process column of the destination of the amn.
+ * If rdest == -1, then CDEST ignored.
+ *
+ * ------------------------------------------------------------------------
+ */
+{
+ void BI_ArgCheck(int, int, char *, char, char, char, int, int, int, int,
+ int *, int *);
+ void BI_UpdateBuffs(BLACBUFF *);
+ BLACBUFF *BI_GetBuff(int);
+ int BI_BuffIsFree(BLACBUFF *, int);
+ MPI_Datatype BI_GetMpiGeType(BLACSCONTEXT *, int, int, int,
+ MPI_Datatype, int *);
+ BLACBUFF *BI_Pack(BLACSCONTEXT *, BVOID *, BLACBUFF *, MPI_Datatype);
+ MPI_Datatype BI_GetMpiGeType(BLACSCONTEXT *, int, int, int,
+ MPI_Datatype, int *);
+ void BI_Unpack(BLACSCONTEXT *, BVOID *, BLACBUFF *, MPI_Datatype);
+ void BI_MringComb(BLACSCONTEXT *, BLACBUFF *, BLACBUFF *, int, VVFUNPTR,
+ int, int);
+ void BI_TreeComb(BLACSCONTEXT *, BLACBUFF *, BLACBUFF *, int, VVFUNPTR,
+ int, int);
+ void BI_BeComb(BLACSCONTEXT *, BLACBUFF *, BLACBUFF *, int, VVFUNPTR);
+ void BI_dvvamn(int, char *, char *);
+ void BI_dvvamn2(int, char *, char *);
+ void BI_dMPI_amn(void *, void *, int *, MPI_Datatype *);
+ void BI_dMPI_amn2(void *, void *, int *, MPI_Datatype *);
+/*
+ * Variable Declarations
+ */
+ VVFUNPTR vvop;
+ BLACBUFF *bp, *bp2;
+ BLACSCONTEXT *ctxt;
+ char ttop, tscope;
+ int i, j, N, dest, idist, length, tlda, tldia, trdest, ierr;
+ int len[2];
+ MPI_Aint disp[2];
+ MPI_Datatype dtypes[2];
+ MPI_Op BlacComb;
+ MPI_Datatype MyType;
+ BI_DistType *dist, mydist;
+ extern BLACBUFF *BI_ActiveQ;
+ extern BLACBUFF BI_AuxBuff;
+
+ MGetConTxt(Mpval(ConTxt), ctxt);
+ ttop = F2C_CharTrans(top);
+ ttop = Mlowcase(ttop);
+ tscope = F2C_CharTrans(scope);
+ tscope = Mlowcase(tscope);
+/*
+ * If the user has set the default combine topology, use it instead of
+ * BLACS default
+ */
+#ifdef DefCombTop
+ if (ttop == ' ') ttop = DefCombTop;
+#endif
+ if (Mpval(cdest) == -1) trdest = -1;
+ else trdest = Mpval(rdest);
+#if (BlacsDebugLvl > 0)
+ BI_ArgCheck(Mpval(ConTxt), RT_COMB, __FILE__, tscope, 'u', 'u', Mpval(m),
+ Mpval(n), Mpval(lda), 1, &trdest, Mpaddress(cdest));
+ if (Mpval(ldia) < Mpval(m))
+ {
+ if (Mpval(ldia) != -1)
+ BI_BlacsWarn(Mpval(ConTxt), __LINE__, __FILE__,
+ "LDIA too small (LDIA=%d, but M=%d)", Mpval(ldia),
+ Mpval(m));
+ }
+#endif
+ if (Mpval(lda) >= Mpval(m)) tlda = Mpval(lda);
+ else tlda = Mpval(m);
+ if (Mpval(ldia) < Mpval(m)) tldia = Mpval(m);
+ else tldia = Mpval(ldia);
+ switch(tscope)
+ {
+ case 'r':
+ ctxt->scp = &ctxt->rscp;
+ if (trdest == -1) dest = -1;
+ else dest = Mpval(cdest);
+ break;
+ case 'c':
+ ctxt->scp = &ctxt->cscp;
+ dest = trdest;
+ break;
+ case 'a':
+ ctxt->scp = &ctxt->ascp;
+ if (trdest == -1) dest = -1;
+ else dest = Mvkpnum(ctxt, trdest, Mpval(cdest));
+ break;
+ default:
+ BI_BlacsErr(Mpval(ConTxt), __LINE__, __FILE__, "Unknown scope '%c'",
+ tscope);
+ }
+
+
+/*
+ * It's not defined how MPI reacts to 0 element reductions, so use BLACS 1-tree
+ * topology if we've got one
+ */
+ if (ttop == ' ')
+ if ( (Mpval(m) < 1) || (Mpval(n) < 1) || (ctxt->TopsRepeat) ) ttop = '1';
+ N = Mpval(m) * Mpval(n);
+/*
+ * If process who has amn is to be communicated, must set up distance
+ * vector after value vector
+ */
+ if (Mpval(ldia) != -1)
+ {
+ vvop = BI_dvvamn;
+ length = N * sizeof(double);
+ i = length % sizeof(BI_DistType); /* ensure dist vec aligned correctly */
+ if (i) length += sizeof(BI_DistType) - i;
+ idist = length;
+ length += N * sizeof(BI_DistType);
+/*
+ * For performance, insist second buffer is at least 8-byte aligned
+ */
+ j = 8;
+ if (sizeof(double) > j) j = sizeof(double);
+ i = length % j;
+ if (i) length += j - i;
+ i = 2 * length;
+
+ bp = BI_GetBuff(i);
+ bp2 = &BI_AuxBuff;
+ bp2->Buff = &bp->Buff[length];
+ BI_dmvcopy(Mpval(m), Mpval(n), A, tlda, bp->Buff);
+/*
+ * Fill in distance vector
+ */
+ if (dest == -1) mydist = ctxt->scp->Iam;
+ else mydist = (ctxt->scp->Np + ctxt->scp->Iam - dest) % ctxt->scp->Np;
+ dist = (BI_DistType *) &bp->Buff[idist];
+ for (i=0; i < N; i++) dist[i] = mydist;
+
+/*
+ * Create the MPI datatype holding both user's buffer and distance vector
+ */
+ len[0] = len[1] = N;
+ disp[0] = 0;
+ disp[1] = idist;
+ dtypes[0] = MPI_DOUBLE;
+ dtypes[1] = BI_MpiDistType;
+#ifdef ZeroByteTypeBug
+ if (N > 0)
+ {
+#endif
+ i = 2;
+ ierr=MPI_Type_struct(i, len, disp, dtypes, &MyType);
+ ierr=MPI_Type_commit(&MyType);
+ bp->N = bp2->N = 1;
+ bp->dtype = bp2->dtype = MyType;
+#ifdef ZeroByteTypeBug
+ }
+ else
+ {
+ bp->N = bp2->N = 0;
+ bp->dtype = bp2->dtype = MPI_INT;
+ }
+#endif
+ }
+ else
+ {
+ vvop = BI_dvvamn2;
+ length = N * sizeof(double);
+/*
+ * If A is contiguous, we can use it as one of our buffers
+ */
+ if ( (Mpval(m) == tlda) || (Mpval(n) == 1) )
+ {
+ bp = &BI_AuxBuff;
+ bp->Buff = (char *) A;
+ bp2 = BI_GetBuff(length);
+ }
+ else
+ {
+ bp = BI_GetBuff(length*2);
+ bp2 = &BI_AuxBuff;
+ bp2->Buff = &bp->Buff[length];
+ BI_dmvcopy(Mpval(m), Mpval(n), A, tlda, bp->Buff);
+ }
+ bp->N = bp2->N = N;
+ bp->dtype = bp2->dtype = MPI_DOUBLE;
+ }
+
+ switch(ttop)
+ {
+ case ' ': /* use MPI's reduction by default */
+ i = 1;
+ if (Mpval(ldia) == -1)
+ {
+ ierr=MPI_Op_create(BI_dMPI_amn2, i, &BlacComb);
+ }
+ else
+ {
+ ierr=MPI_Op_create(BI_dMPI_amn, i, &BlacComb);
+ BI_AuxBuff.Len = N; /* set this up for the MPI OP wrappers */
+ }
+
+ if (trdest != -1)
+ {
+ ierr=MPI_Reduce(bp->Buff, bp2->Buff, bp->N, bp->dtype, BlacComb, dest,
+ ctxt->scp->comm);
+ if (ctxt->scp->Iam == dest)
+ {
+ BI_dvmcopy(Mpval(m), Mpval(n), A, tlda, bp2->Buff);
+ if (Mpval(ldia) != -1)
+ BI_TransDist(ctxt, tscope, Mpval(m), Mpval(n), rA, cA, tldia,
+ (BI_DistType *) &bp2->Buff[idist],
+ trdest, Mpval(cdest));
+ }
+ }
+ else
+ {
+ ierr=MPI_Allreduce(bp->Buff, bp2->Buff, bp->N, bp->dtype, BlacComb,
+ ctxt->scp->comm);
+ BI_dvmcopy(Mpval(m), Mpval(n), A, tlda, bp2->Buff);
+ if (Mpval(ldia) != -1)
+ BI_TransDist(ctxt, tscope, Mpval(m), Mpval(n), rA, cA, tldia,
+ (BI_DistType *) &bp2->Buff[idist],
+ trdest, Mpval(cdest));
+ }
+ ierr=MPI_Op_free(&BlacComb);
+ if (Mpval(ldia) != -1)
+#ifdef ZeroByteTypeBug
+ if (N > 0)
+#endif
+ ierr=BI_MPI_TYPE_FREE(&MyType);
+ if (BI_ActiveQ) BI_UpdateBuffs(NULL);
+ return;
+ break;
+ case 'i':
+ BI_MringComb(ctxt, bp, bp2, N, vvop, dest, 1);
+ break;
+ case 'd':
+ BI_MringComb(ctxt, bp, bp2, N, vvop, dest, -1);
+ break;
+ case 's':
+ BI_MringComb(ctxt, bp, bp2, N, vvop, dest, 2);
+ break;
+ case 'm':
+ BI_MringComb(ctxt, bp, bp2, N, vvop, dest, ctxt->Nr_co);
+ break;
+ case '1':
+ case '2':
+ case '3':
+ case '4':
+ case '5':
+ case '6':
+ case '7':
+ case '8':
+ case '9':
+ BI_TreeComb(ctxt, bp, bp2, N, vvop, dest, ttop-47);
+ break;
+ case 'f':
+ BI_TreeComb(ctxt, bp, bp2, N, vvop, dest, FULLCON);
+ break;
+ case 't':
+ BI_TreeComb(ctxt, bp, bp2, N, vvop, dest, ctxt->Nb_co);
+ break;
+ case 'h':
+/*
+ * Use bidirectional exchange if everyone wants answer
+ */
+ if ( (trdest == -1) && !(ctxt->TopsCohrnt) )
+ BI_BeComb(ctxt, bp, bp2, N, vvop);
+ else
+ BI_TreeComb(ctxt, bp, bp2, N, vvop, dest, 2);
+ break;
+ default :
+ BI_BlacsErr(Mpval(ConTxt), __LINE__, __FILE__, "Unknown topology '%c'",
+ ttop);
+ }
+
+ if (Mpval(ldia) != -1)
+#ifdef ZeroByteTypeBug
+ if (N > 0)
+#endif
+ ierr=BI_MPI_TYPE_FREE(&MyType);
+/*
+ * If I am selected to receive answer
+ */
+ if ( (ctxt->scp->Iam == dest) || (dest == -1) )
+ {
+/*
+ * Translate the distances stored in the latter part of bp->Buff into
+ * process grid coordinates, and output these coordinates in the
+ * arrays rA and cA.
+ */
+ if (Mpval(ldia) != -1)
+ BI_TransDist(ctxt, tscope, Mpval(m), Mpval(n), rA, cA, tldia,
+ dist, trdest, Mpval(cdest));
+/*
+ * Unpack the amn array
+ */
+ if (bp != &BI_AuxBuff) BI_dvmcopy(Mpval(m), Mpval(n), A, tlda, bp->Buff);
+ }
+}
diff --git a/BLACS/SRC/dgamx2d_.c b/BLACS/SRC/dgamx2d_.c
new file mode 100644
index 0000000..a51f731
--- /dev/null
+++ b/BLACS/SRC/dgamx2d_.c
@@ -0,0 +1,373 @@
+#include "Bdef.h"
+
+
+
+#if (INTFACE == C_CALL)
+void Cdgamx2d(int ConTxt, char *scope, char *top, int m, int n, double *A,
+ int lda, int *rA, int *cA, int ldia, int rdest, int cdest)
+#else
+F_VOID_FUNC dgamx2d_(int *ConTxt, F_CHAR scope, F_CHAR top, int *m, int *n,
+ double *A, int *lda, int *rA, int *cA, int *ldia,
+ int *rdest, int *cdest)
+#endif
+/*
+ * -- V1.1 BLACS routine --
+ * University of Tennessee, May 1, 1996
+ * Written by Clint Whaley.
+ *
+ * Purpose
+ * =======
+ * Combine amx operation for double precision rectangular matrices.
+ *
+ * Arguments
+ * =========
+ *
+ * ConTxt (input) Ptr to int
+ * Index into MyConTxts00 (my contexts array).
+ *
+ * SCOPE (input) Ptr to char
+ * Limit the scope of the operation.
+ * = 'R' : Operation is performed by a process row.
+ * = 'C' : Operation is performed by a process column.
+ * = 'A' : Operation is performed by all processes in grid.
+ *
+ * TOP (input) Ptr to char
+ * Controls fashion in which messages flow within the operation.
+ *
+ * M (input) Ptr to int
+ * The number of rows of the matrix A. M >= 0.
+ *
+ * N (input) Ptr to int
+ * The number of columns of the matrix A. N >= 0.
+ *
+ * A (output) Ptr to double precision two dimensional array
+ * The m by n matrix A. Fortran77 (column-major) storage
+ * assumed.
+ *
+ * LDA (input) Ptr to int
+ * The leading dimension of the array A. LDA >= M.
+ *
+ * RA (output) Integer Array, dimension (LDIA, N)
+ * Contains process row that the amx of each element
+ * of A was found on: i.e., rA(1,2) contains the process
+ * row that the amx of A(1,2) was found on.
+ * Values are left on process {rdest, cdest} only, others
+ * may be modified, but not left with interesting data.
+ * If rdest == -1, then result is left on all processes in scope.
+ * If LDIA == -1, this array is not accessed, and need not exist.
+ *
+ * CA (output) Integer Array, dimension (LDIA, N)
+ * Contains process column that the amx of each element
+ * of A was found on: i.e., cA(1,2) contains the process
+ * column that the max/min of A(1,2) was found on.
+ * Values are left on process {rdest, cdest} only, others
+ * may be modified, but not left with interesting data.
+ * If rdest == -1, then result is left on all processes in scope.
+ * If LDIA == -1, this array is not accessed, and need not exist.
+ *
+ * LDIA (input) Ptr to int
+ * If (LDIA == -1), then the arrays RA and CA are not accessed.
+ * ELSE leading dimension of the arrays RA and CA. LDIA >= M.
+ *
+ * RDEST (input) Ptr to int
+ * The process row of the destination of the amx.
+ * If rdest == -1, then result is left on all processes in scope.
+ *
+ * CDEST (input) Ptr to int
+ * The process column of the destination of the amx.
+ * If rdest == -1, then CDEST ignored.
+ *
+ * ------------------------------------------------------------------------
+ */
+{
+ void BI_ArgCheck(int, int, char *, char, char, char, int, int, int, int,
+ int *, int *);
+ void BI_UpdateBuffs(BLACBUFF *);
+ BLACBUFF *BI_GetBuff(int);
+ int BI_BuffIsFree(BLACBUFF *, int);
+ MPI_Datatype BI_GetMpiGeType(BLACSCONTEXT *, int, int, int,
+ MPI_Datatype, int *);
+ BLACBUFF *BI_Pack(BLACSCONTEXT *, BVOID *, BLACBUFF *, MPI_Datatype);
+ MPI_Datatype BI_GetMpiGeType(BLACSCONTEXT *, int, int, int,
+ MPI_Datatype, int *);
+ void BI_Unpack(BLACSCONTEXT *, BVOID *, BLACBUFF *, MPI_Datatype);
+ void BI_MringComb(BLACSCONTEXT *, BLACBUFF *, BLACBUFF *, int, VVFUNPTR,
+ int, int);
+ void BI_TreeComb(BLACSCONTEXT *, BLACBUFF *, BLACBUFF *, int, VVFUNPTR,
+ int, int);
+ void BI_BeComb(BLACSCONTEXT *, BLACBUFF *, BLACBUFF *, int, VVFUNPTR);
+ void BI_dvvamx(int, char *, char *);
+ void BI_dvvamx2(int, char *, char *);
+ void BI_dMPI_amx(void *, void *, int *, MPI_Datatype *);
+ void BI_dMPI_amx2(void *, void *, int *, MPI_Datatype *);
+/*
+ * Variable Declarations
+ */
+ VVFUNPTR vvop;
+ BLACBUFF *bp, *bp2;
+ BLACSCONTEXT *ctxt;
+ char ttop, tscope;
+ int i, j, N, dest, idist, length, tlda, tldia, trdest, ierr;
+ int len[2];
+ MPI_Aint disp[2];
+ MPI_Datatype dtypes[2];
+ MPI_Op BlacComb;
+ MPI_Datatype MyType;
+ BI_DistType *dist, mydist;
+ extern BLACBUFF *BI_ActiveQ;
+ extern BLACBUFF BI_AuxBuff;
+
+ MGetConTxt(Mpval(ConTxt), ctxt);
+ ttop = F2C_CharTrans(top);
+ ttop = Mlowcase(ttop);
+ tscope = F2C_CharTrans(scope);
+ tscope = Mlowcase(tscope);
+/*
+ * If the user has set the default combine topology, use it instead of
+ * BLACS default
+ */
+#ifdef DefCombTop
+ if (ttop == ' ') ttop = DefCombTop;
+#endif
+ if (Mpval(cdest) == -1) trdest = -1;
+ else trdest = Mpval(rdest);
+#if (BlacsDebugLvl > 0)
+ BI_ArgCheck(Mpval(ConTxt), RT_COMB, __FILE__, tscope, 'u', 'u', Mpval(m),
+ Mpval(n), Mpval(lda), 1, &trdest, Mpaddress(cdest));
+ if (Mpval(ldia) < Mpval(m))
+ {
+ if (Mpval(ldia) != -1)
+ BI_BlacsWarn(Mpval(ConTxt), __LINE__, __FILE__,
+ "LDIA too small (LDIA=%d, but M=%d)", Mpval(ldia),
+ Mpval(m));
+ }
+#endif
+ if (Mpval(lda) >= Mpval(m)) tlda = Mpval(lda);
+ else tlda = Mpval(m);
+ if (Mpval(ldia) < Mpval(m)) tldia = Mpval(m);
+ else tldia = Mpval(ldia);
+ switch(tscope)
+ {
+ case 'r':
+ ctxt->scp = &ctxt->rscp;
+ if (trdest == -1) dest = -1;
+ else dest = Mpval(cdest);
+ break;
+ case 'c':
+ ctxt->scp = &ctxt->cscp;
+ dest = trdest;
+ break;
+ case 'a':
+ ctxt->scp = &ctxt->ascp;
+ if (trdest == -1) dest = -1;
+ else dest = Mvkpnum(ctxt, trdest, Mpval(cdest));
+ break;
+ default:
+ BI_BlacsErr(Mpval(ConTxt), __LINE__, __FILE__, "Unknown scope '%c'",
+ tscope);
+ }
+
+
+/*
+ * It's not defined how MPI reacts to 0 element reductions, so use BLACS 1-tree
+ * topology if we've got one
+ */
+ if (ttop == ' ')
+ if ( (Mpval(m) < 1) || (Mpval(n) < 1) || (ctxt->TopsRepeat) ) ttop = '1';
+ N = Mpval(m) * Mpval(n);
+/*
+ * If process who has amx is to be communicated, must set up distance
+ * vector after value vector
+ */
+ if (Mpval(ldia) != -1)
+ {
+ vvop = BI_dvvamx;
+ length = N * sizeof(double);
+ i = length % sizeof(BI_DistType); /* ensure dist vec aligned correctly */
+ if (i) length += sizeof(BI_DistType) - i;
+ idist = length;
+ length += N * sizeof(BI_DistType);
+/*
+ * For performance, insist second buffer is at least 8-byte aligned
+ */
+ j = 8;
+ if (sizeof(double) > j) j = sizeof(double);
+ i = length % j;
+ if (i) length += j - i;
+ i = 2 * length;
+
+ bp = BI_GetBuff(i);
+ bp2 = &BI_AuxBuff;
+ bp2->Buff = &bp->Buff[length];
+ BI_dmvcopy(Mpval(m), Mpval(n), A, tlda, bp->Buff);
+/*
+ * Fill in distance vector
+ */
+ if (dest == -1) mydist = ctxt->scp->Iam;
+ else mydist = (ctxt->scp->Np + ctxt->scp->Iam - dest) % ctxt->scp->Np;
+ dist = (BI_DistType *) &bp->Buff[idist];
+ for (i=0; i < N; i++) dist[i] = mydist;
+
+/*
+ * Create the MPI datatype holding both user's buffer and distance vector
+ */
+ len[0] = len[1] = N;
+ disp[0] = 0;
+ disp[1] = idist;
+ dtypes[0] = MPI_DOUBLE;
+ dtypes[1] = BI_MpiDistType;
+#ifdef ZeroByteTypeBug
+ if (N > 0)
+ {
+#endif
+ i = 2;
+ ierr=MPI_Type_struct(i, len, disp, dtypes, &MyType);
+ ierr=MPI_Type_commit(&MyType);
+ bp->N = bp2->N = 1;
+ bp->dtype = bp2->dtype = MyType;
+#ifdef ZeroByteTypeBug
+ }
+ else
+ {
+ bp->N = bp2->N = 0;
+ bp->dtype = bp2->dtype = MPI_INT;
+ }
+#endif
+ }
+ else
+ {
+ vvop = BI_dvvamx2;
+ length = N * sizeof(double);
+/*
+ * If A is contiguous, we can use it as one of our buffers
+ */
+ if ( (Mpval(m) == tlda) || (Mpval(n) == 1) )
+ {
+ bp = &BI_AuxBuff;
+ bp->Buff = (char *) A;
+ bp2 = BI_GetBuff(length);
+ }
+ else
+ {
+ bp = BI_GetBuff(length*2);
+ bp2 = &BI_AuxBuff;
+ bp2->Buff = &bp->Buff[length];
+ BI_dmvcopy(Mpval(m), Mpval(n), A, tlda, bp->Buff);
+ }
+ bp->N = bp2->N = N;
+ bp->dtype = bp2->dtype = MPI_DOUBLE;
+ }
+
+ switch(ttop)
+ {
+ case ' ': /* use MPI's reduction by default */
+ i = 1;
+ if (Mpval(ldia) == -1)
+ {
+ ierr=MPI_Op_create(BI_dMPI_amx2, i, &BlacComb);
+ }
+ else
+ {
+ ierr=MPI_Op_create(BI_dMPI_amx, i, &BlacComb);
+ BI_AuxBuff.Len = N; /* set this up for the MPI OP wrappers */
+ }
+
+ if (trdest != -1)
+ {
+ ierr=MPI_Reduce(bp->Buff, bp2->Buff, bp->N, bp->dtype, BlacComb, dest,
+ ctxt->scp->comm);
+ if (ctxt->scp->Iam == dest)
+ {
+ BI_dvmcopy(Mpval(m), Mpval(n), A, tlda, bp2->Buff);
+ if (Mpval(ldia) != -1)
+ BI_TransDist(ctxt, tscope, Mpval(m), Mpval(n), rA, cA, tldia,
+ (BI_DistType *) &bp2->Buff[idist],
+ trdest, Mpval(cdest));
+ }
+ }
+ else
+ {
+ ierr=MPI_Allreduce(bp->Buff, bp2->Buff, bp->N, bp->dtype, BlacComb,
+ ctxt->scp->comm);
+ BI_dvmcopy(Mpval(m), Mpval(n), A, tlda, bp2->Buff);
+ if (Mpval(ldia) != -1)
+ BI_TransDist(ctxt, tscope, Mpval(m), Mpval(n), rA, cA, tldia,
+ (BI_DistType *) &bp2->Buff[idist],
+ trdest, Mpval(cdest));
+ }
+ ierr=MPI_Op_free(&BlacComb);
+ if (Mpval(ldia) != -1)
+#ifdef ZeroByteTypeBug
+ if (N > 0)
+#endif
+ ierr=BI_MPI_TYPE_FREE(&MyType);
+ if (BI_ActiveQ) BI_UpdateBuffs(NULL);
+ return;
+ break;
+ case 'i':
+ BI_MringComb(ctxt, bp, bp2, N, vvop, dest, 1);
+ break;
+ case 'd':
+ BI_MringComb(ctxt, bp, bp2, N, vvop, dest, -1);
+ break;
+ case 's':
+ BI_MringComb(ctxt, bp, bp2, N, vvop, dest, 2);
+ break;
+ case 'm':
+ BI_MringComb(ctxt, bp, bp2, N, vvop, dest, ctxt->Nr_co);
+ break;
+ case '1':
+ case '2':
+ case '3':
+ case '4':
+ case '5':
+ case '6':
+ case '7':
+ case '8':
+ case '9':
+ BI_TreeComb(ctxt, bp, bp2, N, vvop, dest, ttop-47);
+ break;
+ case 'f':
+ BI_TreeComb(ctxt, bp, bp2, N, vvop, dest, FULLCON);
+ break;
+ case 't':
+ BI_TreeComb(ctxt, bp, bp2, N, vvop, dest, ctxt->Nb_co);
+ break;
+ case 'h':
+/*
+ * Use bidirectional exchange if everyone wants answer
+ */
+ if ( (trdest == -1) && !(ctxt->TopsCohrnt) )
+ BI_BeComb(ctxt, bp, bp2, N, vvop);
+ else
+ BI_TreeComb(ctxt, bp, bp2, N, vvop, dest, 2);
+ break;
+ default :
+ BI_BlacsErr(Mpval(ConTxt), __LINE__, __FILE__, "Unknown topology '%c'",
+ ttop);
+ }
+
+ if (Mpval(ldia) != -1)
+#ifdef ZeroByteTypeBug
+ if (N > 0)
+#endif
+ ierr=BI_MPI_TYPE_FREE(&MyType);
+/*
+ * If I am selected to receive answer
+ */
+ if ( (ctxt->scp->Iam == dest) || (dest == -1) )
+ {
+/*
+ * Translate the distances stored in the latter part of bp->Buff into
+ * process grid coordinates, and output these coordinates in the
+ * arrays rA and cA.
+ */
+ if (Mpval(ldia) != -1)
+ BI_TransDist(ctxt, tscope, Mpval(m), Mpval(n), rA, cA, tldia,
+ dist, trdest, Mpval(cdest));
+/*
+ * Unpack the amx array
+ */
+ if (bp != &BI_AuxBuff) BI_dvmcopy(Mpval(m), Mpval(n), A, tlda, bp->Buff);
+ }
+}
diff --git a/BLACS/SRC/dgebr2d_.c b/BLACS/SRC/dgebr2d_.c
new file mode 100644
index 0000000..012a94f
--- /dev/null
+++ b/BLACS/SRC/dgebr2d_.c
@@ -0,0 +1,226 @@
+#include "Bdef.h"
+
+#if (INTFACE == C_CALL)
+void Cdgebr2d(int ConTxt, char *scope, char *top, int m, int n, double *A,
+ int lda, int rsrc, int csrc)
+#else
+F_VOID_FUNC dgebr2d_(int *ConTxt, F_CHAR scope, F_CHAR top, int *m, int *n,
+ double *A, int *lda, int *rsrc, int *csrc)
+#endif
+/*
+ * -- V1.1 BLACS routine --
+ * University of Tennessee, May 1, 1996
+ * Written by Clint Whaley.
+ *
+ * Purpose
+ * =======
+ * Broadcast/receive for general double precision arrays.
+ *
+ * Arguments
+ * =========
+ *
+ * ConTxt (input) Ptr to int
+ * Index into MyConTxts00 (my contexts array).
+ *
+ * SCOPE (input) Ptr to char
+ * Limit the scope of the operation.
+ * = 'R' : Operation is performed by a process row.
+ * = 'C' : Operation is performed by a process column.
+ * = 'A' : Operation is performed by all processes in grid.
+ *
+ * TOP (input) Ptr to char
+ * Controls fashion in which messages flow within the operation.
+ *
+ * M (input) Ptr to int
+ * The number of rows of the matrix A. M >= 0.
+ *
+ * N (input) Ptr to int
+ * The number of columns of the matrix A. N >= 0.
+ *
+ * A (output) Ptr to double precision two dimensional array
+ * The m by n matrix A. Fortran77 (column-major) storage
+ * assumed.
+ *
+ * LDA (input) Ptr to int
+ * The leading dimension of the array A. LDA >= M.
+ *
+ *
+ * RSRC (input) Ptr to int
+ * The process row of the source of the matrix.
+ *
+ * CSRC (input) Ptr to int
+ * The process column of the source of the matrix.
+ *
+ *
+ * ------------------------------------------------------------------------
+ */
+{
+ void BI_ArgCheck(int, int, char *, char, char, char, int, int, int, int,
+ int *, int *);
+ int BI_HypBR(BLACSCONTEXT *, BLACBUFF *, SDRVPTR, int);
+ void BI_IdringBR(BLACSCONTEXT *, BLACBUFF *, SDRVPTR, int, int);
+ void BI_SringBR(BLACSCONTEXT *, BLACBUFF *, SDRVPTR, int);
+ void BI_MpathBR(BLACSCONTEXT *, BLACBUFF *, SDRVPTR, int, int);
+ void BI_TreeBR(BLACSCONTEXT *, BLACBUFF *, SDRVPTR, int, int);
+ void BI_UpdateBuffs(BLACBUFF *);
+ BLACBUFF *BI_GetBuff(int);
+ int BI_BuffIsFree(BLACBUFF *, int);
+ MPI_Datatype BI_GetMpiGeType(BLACSCONTEXT *, int, int, int,
+ MPI_Datatype, int *);
+ void BI_Unpack(BLACSCONTEXT *, BVOID *, BLACBUFF *, MPI_Datatype);
+ void BI_Ssend(BLACSCONTEXT *, int, int, BLACBUFF *);
+ void BI_Asend(BLACSCONTEXT *, int, int, BLACBUFF *);
+
+ BLACSCONTEXT *ctxt;
+ BLACBUFF *bp=NULL;
+ SDRVPTR send;
+ MPI_Datatype MatTyp;
+ int length, src, tlda, error, one=1;
+ char ttop, tscope;
+ extern BLACBUFF BI_AuxBuff, *BI_ActiveQ;
+
+ MGetConTxt(Mpval(ConTxt), ctxt);
+ ttop = F2C_CharTrans(top);
+ ttop = Mlowcase(ttop);
+ tscope = F2C_CharTrans(scope);
+ tscope = Mlowcase(tscope);
+#if (BlacsDebugLvl > 0)
+ BI_ArgCheck(Mpval(ConTxt), RT_BR, __FILE__, tscope, 'u', 'u', Mpval(m),
+ Mpval(n), Mpval(lda), 1, Mpaddress(rsrc), Mpaddress(csrc));
+#endif
+/*
+ * If the user has set the default broadcast topology, use it instead of
+ * BLACS default
+ */
+#ifdef DefBSTop
+ if (ttop == ' ') ttop = DefBSTop;
+#endif
+ if (Mpval(m) <= Mpval(lda)) tlda = Mpval(lda);
+ else tlda = Mpval(m);
+
+ switch(tscope)
+ {
+ case 'r':
+ ctxt->scp = &ctxt->rscp;
+ src = Mpval(csrc);
+ break;
+ case 'c':
+ ctxt->scp = &ctxt->cscp;
+ src = Mpval(rsrc);
+ break;
+ case 'a':
+ ctxt->scp = &ctxt->ascp;
+ src = Mvkpnum(ctxt, Mpval(rsrc), Mpval(csrc));
+ break;
+ default:
+ BI_BlacsErr(Mpval(ConTxt), __LINE__, __FILE__, "Unknown scope '%c'",
+ tscope);
+ }
+
+ MatTyp = BI_GetMpiGeType(ctxt, Mpval(m), Mpval(n), tlda,
+ MPI_DOUBLE, &BI_AuxBuff.N);
+/*
+ * If using default topology, use MPI native broadcast
+ */
+ if (ttop == ' ')
+ {
+ error=MPI_Bcast(A, BI_AuxBuff.N, MatTyp, src, ctxt->scp->comm);
+ error=BI_MPI_TYPE_FREE(&MatTyp);
+ if (BI_ActiveQ) BI_UpdateBuffs(NULL);
+ return;
+ }
+/*
+ * If MPI handles non-contiguous buffering well, always use MPI data types
+ * instead of packing
+ */
+#ifndef MpiBuffGood
+/*
+ * If A is contiguous, receive and send directly to/from it
+ */
+ else if ( (tlda == Mpval(m)) || (Mpval(n) == 1) )
+ {
+#endif
+ send = BI_Ssend;
+ BI_AuxBuff.Buff = (char *) A;
+ BI_AuxBuff.dtype = MatTyp;
+ bp = &BI_AuxBuff;
+#ifndef MpiBuffGood
+ }
+/*
+ * If A is not contiguous, we receive message as packed so it can be
+ * forwarded without further system intervention
+ */
+ else
+ {
+ send = BI_Asend;
+ error=MPI_Pack_size(one, MatTyp, ctxt->scp->comm, &length);
+ bp = BI_GetBuff(length);
+ bp->N = length;
+ bp->dtype = MPI_PACKED;
+#if ZeroByteTypeBug
+ if (MatTyp == MPI_BYTE)
+ {
+ send = BI_Ssend;
+ bp->N = 0;
+ bp->dtype = MPI_BYTE;
+ }
+#endif
+ }
+#endif
+
+ switch(ttop)
+ {
+ case 'h':
+ error = BI_HypBR(ctxt, bp, send, src);
+ if (error == NPOW2) BI_TreeBR(ctxt, bp, send, src, 2);
+ break;
+ case '1':
+ case '2':
+ case '3':
+ case '4':
+ case '5':
+ case '6':
+ case '7':
+ case '8':
+ case '9':
+ BI_TreeBR(ctxt, bp, send, src, ttop-47);
+ break;
+ case 't':
+ BI_TreeBR(ctxt, bp, send, src, ctxt->Nb_bs);
+ break;
+ case 'i':
+ BI_IdringBR(ctxt, bp, send, src, 1);
+ break;
+ case 'd':
+ BI_IdringBR(ctxt, bp, send, src, -1);
+ break;
+ case 's':
+ BI_SringBR(ctxt, bp, send, src);
+ break;
+ case 'm':
+ BI_MpathBR(ctxt, bp, send, src, ctxt->Nr_bs);
+ break;
+ case 'f':
+ BI_MpathBR(ctxt, bp, send, src, FULLCON);
+ break;
+ default :
+ BI_BlacsErr(Mpval(ConTxt), __LINE__, __FILE__, "Unknown topology '%c'",
+ ttop);
+ }
+
+/*
+ * If we buffered, unpack.
+ */
+#ifndef MpiBuffGood
+ if (bp != &BI_AuxBuff)
+ {
+ BI_Unpack(ctxt, (BVOID *) A, bp, MatTyp);
+ BI_UpdateBuffs(bp);
+ }
+ else
+#endif
+ {
+ error=BI_MPI_TYPE_FREE(&MatTyp);
+ if (BI_ActiveQ) BI_UpdateBuffs(NULL);
+ }
+}
diff --git a/BLACS/SRC/dgebs2d_.c b/BLACS/SRC/dgebs2d_.c
new file mode 100644
index 0000000..08a9190
--- /dev/null
+++ b/BLACS/SRC/dgebs2d_.c
@@ -0,0 +1,195 @@
+#include "Bdef.h"
+
+#if (INTFACE == C_CALL)
+void Cdgebs2d(int ConTxt, char *scope, char *top, int m, int n, double *A, int lda)
+#else
+F_VOID_FUNC dgebs2d_(int *ConTxt, F_CHAR scope, F_CHAR top, int *m, int *n,
+ double *A, int *lda)
+#endif
+/*
+ * -- V1.1 BLACS routine --
+ * University of Tennessee, May 1, 1996
+ * Written by Clint Whaley.
+ *
+ * Purpose
+ * =======
+ * Broadcast/send for general double precision arrays.
+ *
+ * Arguments
+ * =========
+ *
+ * ConTxt (input) Ptr to int
+ * Index into MyConTxts00 (my contexts array).
+ *
+ * SCOPE (input) Ptr to char
+ * Limit the scope of the operation.
+ * = 'R' : Operation is performed by a process row.
+ * = 'C' : Operation is performed by a process column.
+ * = 'A' : Operation is performed by all processes in grid.
+ *
+ * TOP (input) Ptr to char
+ * Controls fashion in which messages flow within the operation.
+ *
+ * M (input) Ptr to int
+ * The number of rows of the matrix A. M >= 0.
+ *
+ * N (input) Ptr to int
+ * The number of columns of the matrix A. N >= 0.
+ *
+ * A (input) Ptr to double precision two dimensional array
+ * The m by n matrix A. Fortran77 (column-major) storage
+ * assumed.
+ *
+ * LDA (input) Ptr to int
+ * The leading dimension of the array A. LDA >= M.
+ *
+ * ------------------------------------------------------------------------
+ */
+{
+ void BI_ArgCheck(int, int, char *, char, char, char, int, int, int, int,
+ int *, int *);
+ int BI_HypBS(BLACSCONTEXT *, BLACBUFF *, SDRVPTR);
+ void BI_IdringBS(BLACSCONTEXT *, BLACBUFF *, SDRVPTR, int);
+ void BI_SringBS(BLACSCONTEXT *, BLACBUFF *, SDRVPTR);
+ void BI_MpathBS(BLACSCONTEXT *, BLACBUFF *, SDRVPTR, int);
+ void BI_TreeBS(BLACSCONTEXT *, BLACBUFF *, SDRVPTR, int);
+ void BI_UpdateBuffs(BLACBUFF *);
+ BLACBUFF *BI_GetBuff(int);
+ int BI_BuffIsFree(BLACBUFF *, int);
+ MPI_Datatype BI_GetMpiGeType(BLACSCONTEXT *, int, int, int,
+ MPI_Datatype, int *);
+ BLACBUFF *BI_Pack(BLACSCONTEXT *, BVOID *, BLACBUFF *, MPI_Datatype);
+ void BI_Ssend(BLACSCONTEXT *, int, int, BLACBUFF *);
+ void BI_Asend(BLACSCONTEXT *, int, int, BLACBUFF *);
+
+ char ttop, tscope;
+ int error, tlda;
+ MPI_Datatype MatTyp;
+ SDRVPTR send;
+ BLACBUFF *bp;
+ BLACSCONTEXT *ctxt;
+ extern BLACBUFF BI_AuxBuff, *BI_ActiveQ;
+/*
+ * get context, lowcase char variables, and perform parameter checking
+ */
+ MGetConTxt(Mpval(ConTxt), ctxt);
+ ttop = F2C_CharTrans(top);
+ ttop = Mlowcase(ttop);
+ tscope = F2C_CharTrans(scope);
+ tscope = Mlowcase(tscope);
+#if (BlacsDebugLvl > 0)
+ BI_ArgCheck(Mpval(ConTxt), RT_BS, __FILE__, 'a', 'u', 'u', Mpval(m),
+ Mpval(n), Mpval(lda), 0, NULL, NULL);
+#endif
+/*
+ * If the user has set the default broadcast topology, use it instead of
+ * BLACS default
+ */
+#ifdef DefBSTop
+ if (ttop == ' ') ttop = DefBSTop;
+#endif
+ if (Mpval(lda) < Mpval(m)) tlda = Mpval(m);
+ else tlda = Mpval(lda);
+
+ switch(tscope)
+ {
+ case 'r':
+ ctxt->scp = &ctxt->rscp;
+ break;
+ case 'c':
+ ctxt->scp = &ctxt->cscp;
+ break;
+ case 'a':
+ ctxt->scp = &ctxt->ascp;
+ break;
+ default:
+ BI_BlacsErr(Mpval(ConTxt), __LINE__, __FILE__, "Unknown scope '%c'",
+ tscope);
+ }
+
+ MatTyp = BI_GetMpiGeType(ctxt, Mpval(m), Mpval(n), tlda,
+ MPI_DOUBLE, &BI_AuxBuff.N);
+/*
+ * If using default topology, use MPI native broadcast
+ */
+ if (ttop == ' ')
+ {
+ error=MPI_Bcast(A, BI_AuxBuff.N, MatTyp, ctxt->scp->Iam, ctxt->scp->comm);
+ error=BI_MPI_TYPE_FREE(&MatTyp);
+ if (BI_ActiveQ) BI_UpdateBuffs(NULL);
+ return;
+ }
+/*
+ * If MPI handles non-contiguous buffering well, always use MPI data types
+ * instead of packing
+ */
+#ifndef MpiBuffGood
+/*
+ * If A is contiguous, send directly from it
+ */
+ else if ( (tlda == Mpval(m)) || (Mpval(n) == 1) )
+ {
+#endif
+ send = BI_Ssend;
+ BI_AuxBuff.Buff = (char *) A;
+ BI_AuxBuff.dtype = MatTyp;
+ bp = &BI_AuxBuff;
+#ifndef MpiBuffGood
+ }
+ else
+ {
+ send = BI_Asend;
+ bp = BI_Pack(ctxt, (BVOID *) A, NULL, MatTyp);
+ }
+#endif
+
+/*
+ * Call correct topology for BS/BR
+ */
+ switch(ttop)
+ {
+ case 'h':
+ error = BI_HypBS(ctxt, bp, send);
+ if (error == NPOW2) BI_TreeBS(ctxt, bp, send, 2);
+ break;
+ case '1':
+ case '2':
+ case '3':
+ case '4':
+ case '5':
+ case '6':
+ case '7':
+ case '8':
+ case '9':
+ BI_TreeBS(ctxt, bp, send, ttop-47);
+ break;
+ case 't':
+ BI_TreeBS(ctxt, bp, send, ctxt->Nb_bs);
+ break;
+ case 'i':
+ BI_IdringBS(ctxt, bp, send, 1);
+ break;
+ case 'd':
+ BI_IdringBS(ctxt, bp, send, -1);
+ break;
+ case 's':
+ BI_SringBS(ctxt, bp, send);
+ break;
+ case 'f':
+ BI_MpathBS(ctxt, bp, send, FULLCON);
+ break;
+ case 'm':
+ BI_MpathBS(ctxt, bp, send, ctxt->Nr_bs);
+ break;
+ default :
+ BI_BlacsErr(Mpval(ConTxt), __LINE__, __FILE__, "Unknown topology '%c'",
+ ttop);
+ }
+
+ error=BI_MPI_TYPE_FREE(&MatTyp);
+ if (bp == &BI_AuxBuff)
+ {
+ if (BI_ActiveQ) BI_UpdateBuffs(NULL);
+ }
+ else BI_UpdateBuffs(bp);
+} /* end dgebs2d_ */
diff --git a/BLACS/SRC/dgerv2d_.c b/BLACS/SRC/dgerv2d_.c
new file mode 100644
index 0000000..18f811b
--- /dev/null
+++ b/BLACS/SRC/dgerv2d_.c
@@ -0,0 +1,82 @@
+#include "Bdef.h"
+
+#if (INTFACE == C_CALL)
+void Cdgerv2d(int ConTxt, int m, int n, double *A, int lda, int rsrc, int csrc)
+#else
+F_VOID_FUNC dgerv2d_(int *ConTxt, int *m, int *n, double *A, int *lda,
+ int *rsrc, int *csrc)
+#endif
+/*
+ * -- V1.1 BLACS routine --
+ * University of Tennessee, May 1, 1996
+ * Written by Clint Whaley.
+ *
+ * Purpose
+ * =======
+ * Globally-blocking point to point general double precision receive.
+ *
+ * Arguments
+ * =========
+ *
+ * ConTxt (input) Ptr to int
+ * Index into MyConTxts00 (my contexts array).
+ *
+ * M (input) Ptr to int
+ * The number of rows of the matrix A. M >= 0.
+ *
+ * N (input) Ptr to int
+ * The number of columns of the matrix A. N >= 0.
+ *
+ * A (output) Ptr to double precision two dimensional array
+ * The m by n matrix A. Fortran77 (column-major) storage
+ * assumed.
+ *
+ * LDA (input) Ptr to int
+ * The leading dimension of the array A. LDA >= M.
+ *
+ *
+ * RSRC (input) Ptr to int
+ * The process row of the source of the matrix.
+ *
+ * CSRC (input) Ptr to int
+ * The process column of the source of the matrix.
+ *
+ *
+ * ------------------------------------------------------------------------
+ */
+{
+/*
+ * Prototypes and variable declarations
+ */
+ void BI_ArgCheck(int, int, char *, char, char, char, int, int, int, int,
+ int *, int *);
+ MPI_Datatype BI_GetMpiGeType(BLACSCONTEXT *, int, int, int,
+ MPI_Datatype, int *);
+ void BI_Unpack(BLACSCONTEXT *, BVOID *, BLACBUFF *, MPI_Datatype);
+ void BI_Srecv(BLACSCONTEXT *, int, int, BLACBUFF *);
+ void BI_UpdateBuffs(BLACBUFF *);
+ BLACBUFF *BI_GetBuff(int);
+ int BI_BuffIsFree(BLACBUFF *, int);
+ int tlda;
+ int ierr;
+ MPI_Datatype MatTyp;
+ BLACSCONTEXT *ctxt;
+ extern BLACBUFF BI_AuxBuff, *BI_ActiveQ;
+
+ MGetConTxt(Mpval(ConTxt), ctxt);
+#if (BlacsDebugLvl > 0)
+ BI_ArgCheck(Mpval(ConTxt), RT_RV, __FILE__, 'a', 'u', 'u', Mpval(m),
+ Mpval(n), Mpval(lda), 1, Mpaddress(rsrc), Mpaddress(csrc));
+#endif
+ if (Mpval(lda) < Mpval(m)) tlda = Mpval(m);
+ else tlda = Mpval(lda);
+ ctxt->scp = &ctxt->pscp;
+
+ MatTyp = BI_GetMpiGeType(ctxt, Mpval(m), Mpval(n), tlda,
+ MPI_DOUBLE, &BI_AuxBuff.N);
+ BI_AuxBuff.Buff = (char *) A;
+ BI_AuxBuff.dtype = MatTyp;
+ BI_Srecv(ctxt, Mkpnum(ctxt, Mpval(rsrc), Mpval(csrc)), PT2PTID, &BI_AuxBuff);
+ ierr=BI_MPI_TYPE_FREE(&MatTyp);
+ if (BI_ActiveQ) BI_UpdateBuffs(NULL);
+}
diff --git a/BLACS/SRC/dgesd2d_.c b/BLACS/SRC/dgesd2d_.c
new file mode 100644
index 0000000..2ace65b
--- /dev/null
+++ b/BLACS/SRC/dgesd2d_.c
@@ -0,0 +1,96 @@
+#include "Bdef.h"
+
+
+#if (INTFACE == C_CALL)
+void Cdgesd2d(int ConTxt, int m, int n, double *A, int lda,
+ int rdest, int cdest)
+#else
+F_VOID_FUNC dgesd2d_(int *ConTxt, int *m, int *n, double *A, int *lda,
+ int *rdest, int *cdest)
+#endif
+/*
+ * -- V1.1 BLACS routine --
+ * University of Tennessee, May 1, 1996
+ * Written by Clint Whaley.
+ *
+ * Purpose
+ * =======
+ * Locally-blocking point-to-point general double precision send.
+ *
+ * Arguments
+ * =========
+ *
+ * ConTxt (input) Ptr to int
+ * Index into MyConTxts00 (my contexts array).
+ *
+ * M (input) Ptr to int
+ * The number of rows of the matrix A. M >= 0.
+ *
+ * N (input) Ptr to int
+ * The number of columns of the matrix A. N >= 0.
+ *
+ * A (input) Ptr to double precision two dimensional array
+ * The m by n matrix A. Fortran77 (column-major) storage
+ * assumed.
+ *
+ * LDA (input) Ptr to int
+ * The leading dimension of the array A. LDA >= M.
+ *
+ * RDEST (input) Ptr to int
+ * The process row of the destination process.
+ *
+ * CDEST (input) Ptr to int
+ * The process column of the destination process.
+ *
+ * ------------------------------------------------------------------------
+ */
+{
+ void BI_ArgCheck(int, int, char *, char, char, char, int, int, int, int,
+ int *, int *);
+ MPI_Datatype BI_GetMpiGeType(BLACSCONTEXT *, int, int, int,
+ MPI_Datatype, int *);
+ BLACBUFF *BI_Pack(BLACSCONTEXT *, BVOID *, BLACBUFF *, MPI_Datatype);
+ void BI_Ssend(BLACSCONTEXT *, int, int, BLACBUFF *);
+ void BI_Asend(BLACSCONTEXT *, int, int, BLACBUFF *);
+ void BI_UpdateBuffs(BLACBUFF *);
+ BLACBUFF *BI_GetBuff(int);
+ int BI_BuffIsFree(BLACBUFF *, int);
+
+ int dest, tlda, ierr;
+ BLACBUFF *bp;
+ BLACSCONTEXT *ctxt;
+ MPI_Datatype MatTyp;
+ extern BLACBUFF BI_AuxBuff, *BI_ActiveQ;
+
+ MGetConTxt(Mpval(ConTxt), ctxt);
+#if (BlacsDebugLvl > 0)
+ BI_ArgCheck(Mpval(ConTxt), RT_SD, "DGESD2D", 'a', 'u', 'u', Mpval(m),
+ Mpval(n), Mpval(lda), 1, Mpaddress(rdest), Mpaddress(cdest));
+#endif
+ if (Mpval(lda) < Mpval(m)) tlda = Mpval(m);
+ else tlda = Mpval(lda);
+ dest = Mvkpnum(ctxt, Mpval(rdest), Mpval(cdest));
+ ctxt->scp = &ctxt->pscp;
+
+ MatTyp = BI_GetMpiGeType(ctxt, Mpval(m), Mpval(n), tlda,
+ MPI_DOUBLE, &BI_AuxBuff.N);
+#ifdef SndIsLocBlk
+ BI_AuxBuff.Buff = (char *) A;
+ BI_AuxBuff.dtype = MatTyp;
+ BI_Ssend(ctxt, dest, PT2PTID, &BI_AuxBuff);
+#else
+ bp = BI_Pack(ctxt, (BVOID *) A, NULL, MatTyp);
+ BI_Asend(ctxt, Mkpnum(ctxt, Mpval(rdest), Mpval(cdest)), PT2PTID, bp);
+#endif
+ ierr=BI_MPI_TYPE_FREE(&MatTyp);
+
+/*
+ * Having started the async send, update the buffers (reform links, check if
+ * active buffers have become inactive, etc.)
+ */
+#ifdef SndIsLocBlk
+ if (BI_ActiveQ) BI_UpdateBuffs(NULL);
+#else
+ BI_UpdateBuffs(bp);
+#endif
+} /* end of dgesd2d */
diff --git a/BLACS/SRC/dgsum2d_.c b/BLACS/SRC/dgsum2d_.c
new file mode 100644
index 0000000..d7aa2de
--- /dev/null
+++ b/BLACS/SRC/dgsum2d_.c
@@ -0,0 +1,235 @@
+#include "Bdef.h"
+
+
+#if (INTFACE == C_CALL)
+void Cdgsum2d(int ConTxt, char *scope, char *top, int m, int n, double *A,
+ int lda, int rdest, int cdest)
+#else
+F_VOID_FUNC dgsum2d_(int *ConTxt, F_CHAR scope, F_CHAR top, int *m, int *n,
+ double *A, int *lda, int *rdest, int *cdest)
+#endif
+/*
+ * -- V1.1 BLACS routine --
+ * University of Tennessee, May 1, 1996
+ * Written by Clint Whaley.
+ *
+ * Purpose
+ * =======
+ * Combine sum operation for double precision rectangular matrices.
+ *
+ * Arguments
+ * =========
+ *
+ * ConTxt (input) Ptr to int
+ * Index into MyConTxts00 (my contexts array).
+ *
+ * SCOPE (input) Ptr to char
+ * Limit the scope of the operation.
+ * = 'R' : Operation is performed by a process row.
+ * = 'C' : Operation is performed by a process column.
+ * = 'A' : Operation is performed by all processes in grid.
+ *
+ * TOP (input) Ptr to char
+ * Controls fashion in which messages flow within the operation.
+ *
+ * M (input) Ptr to int
+ * The number of rows of the matrix A. M >= 0.
+ *
+ * N (input) Ptr to int
+ * The number of columns of the matrix A. N >= 0.
+ *
+ * A (output) Ptr to double precision two dimensional array
+ * The m by n matrix A. Fortran77 (column-major) storage
+ * assumed.
+ *
+ * LDA (input) Ptr to int
+ * The leading dimension of the array A. LDA >= M.
+ *
+ * RDEST (input) Ptr to int
+ * The process row of the destination of the sum.
+ * If rdest == -1, then result is left on all processes in scope.
+ *
+ * CDEST (input) Ptr to int
+ * The process column of the destination of the sum.
+ * If rdest == -1, then CDEST ignored.
+ *
+ * ------------------------------------------------------------------------
+ */
+{
+ void BI_ArgCheck(int, int, char *, char, char, char, int, int, int, int,
+ int *, int *);
+ void BI_UpdateBuffs(BLACBUFF *);
+ BLACBUFF *BI_GetBuff(int);
+ int BI_BuffIsFree(BLACBUFF *, int);
+ MPI_Datatype BI_GetMpiGeType(BLACSCONTEXT *, int, int, int,
+ MPI_Datatype, int *);
+ BLACBUFF *BI_Pack(BLACSCONTEXT *, BVOID *, BLACBUFF *, MPI_Datatype);
+ MPI_Datatype BI_GetMpiGeType(BLACSCONTEXT *, int, int, int,
+ MPI_Datatype, int *);
+ void BI_Unpack(BLACSCONTEXT *, BVOID *, BLACBUFF *, MPI_Datatype);
+ void BI_MringComb(BLACSCONTEXT *, BLACBUFF *, BLACBUFF *, int, VVFUNPTR,
+ int, int);
+ void BI_TreeComb(BLACSCONTEXT *, BLACBUFF *, BLACBUFF *, int, VVFUNPTR,
+ int, int);
+ void BI_BeComb(BLACSCONTEXT *, BLACBUFF *, BLACBUFF *, int, VVFUNPTR);
+ void BI_dvvsum(int, char *, char *);
+/*
+ * Variable Declarations
+ */
+ BLACBUFF *bp, *bp2;
+ BLACSCONTEXT *ctxt;
+ char ttop, tscope;
+ int N, length, dest, tlda, trdest, ierr;
+ extern BLACBUFF *BI_ActiveQ;
+ extern BLACBUFF BI_AuxBuff;
+
+ MGetConTxt(Mpval(ConTxt), ctxt);
+ ttop = F2C_CharTrans(top);
+ ttop = Mlowcase(ttop);
+ tscope = F2C_CharTrans(scope);
+ tscope = Mlowcase(tscope);
+/*
+ * If the user has set the default combine topology, use it instead of
+ * BLACS default
+ */
+#ifdef DefCombTop
+ if (ttop == ' ') ttop = DefCombTop;
+#endif
+ if (Mpval(cdest) == -1) trdest = -1;
+ else trdest = Mpval(rdest);
+#if (BlacsDebugLvl > 0)
+ BI_ArgCheck(Mpval(ConTxt), RT_COMB, __FILE__, tscope, 'u', 'u', Mpval(m),
+ Mpval(n), Mpval(lda), 1, &trdest, Mpaddress(cdest));
+#endif
+ if (Mpval(lda) >= Mpval(m)) tlda = Mpval(lda);
+ else tlda = Mpval(m);
+ switch(tscope)
+ {
+ case 'r':
+ ctxt->scp = &ctxt->rscp;
+ if (trdest == -1) dest = -1;
+ else dest = Mpval(cdest);
+ break;
+ case 'c':
+ ctxt->scp = &ctxt->cscp;
+ dest = trdest;
+ break;
+ case 'a':
+ ctxt->scp = &ctxt->ascp;
+ if (trdest == -1) dest = -1;
+ else dest = Mvkpnum(ctxt, trdest, Mpval(cdest));
+ break;
+ default:
+ BI_BlacsErr(Mpval(ConTxt), __LINE__, __FILE__, "Unknown scope '%c'",
+ tscope);
+ }
+
+
+/*
+ * It's not defined how MPI reacts to 0 element reductions, so use BLACS 1-tree
+ * topology if we've got one. Also, we can't use MPI functions if we need to
+ * guarantee repeatability.
+ */
+ if (ttop == ' ')
+ if ( (Mpval(m) < 1) || (Mpval(n) < 1) || (ctxt->TopsRepeat) ) ttop = '1';
+ N = Mpval(m) * Mpval(n);
+ length = N * sizeof(double);
+/*
+ * If A is contiguous, we can use it as one of the buffers
+ */
+ if ( (Mpval(m) == tlda) || (Mpval(n) == 1) )
+ {
+ bp = &BI_AuxBuff;
+ bp->Buff = (char *) A;
+ bp2 = BI_GetBuff(length);
+ }
+/*
+ * Otherwise, we must allocate both buffers
+ */
+ else
+ {
+ bp = BI_GetBuff(length*2);
+ bp2 = &BI_AuxBuff;
+ bp2->Buff = &bp->Buff[length];
+ BI_dmvcopy(Mpval(m), Mpval(n), A, tlda, bp->Buff);
+ }
+ bp->dtype = bp2->dtype = MPI_DOUBLE;
+ bp->N = bp2->N = N;
+
+ switch(ttop)
+ {
+ case ' ': /* use MPI's reduction by default */
+ if (dest != -1)
+ {
+ ierr=MPI_Reduce(bp->Buff, bp2->Buff, bp->N, bp->dtype, MPI_SUM,
+ dest, ctxt->scp->comm);
+ if (ctxt->scp->Iam == dest)
+ BI_dvmcopy(Mpval(m), Mpval(n), A, tlda, bp2->Buff);
+ }
+ else
+ {
+ ierr=MPI_Allreduce(bp->Buff, bp2->Buff, bp->N, bp->dtype, MPI_SUM,
+ ctxt->scp->comm);
+ BI_dvmcopy(Mpval(m), Mpval(n), A, tlda, bp2->Buff);
+ }
+ if (BI_ActiveQ) BI_UpdateBuffs(NULL);
+ return;
+ break;
+ case 'i':
+ BI_MringComb(ctxt, bp, bp2, N, BI_dvvsum, dest, 1);
+ break;
+ case 'd':
+ BI_MringComb(ctxt, bp, bp2, N, BI_dvvsum, dest, -1);
+ break;
+ case 's':
+ BI_MringComb(ctxt, bp, bp2, N, BI_dvvsum, dest, 2);
+ break;
+ case 'm':
+ BI_MringComb(ctxt, bp, bp2, N, BI_dvvsum, dest, ctxt->Nr_co);
+ break;
+ case '1':
+ case '2':
+ case '3':
+ case '4':
+ case '5':
+ case '6':
+ case '7':
+ case '8':
+ case '9':
+ BI_TreeComb(ctxt, bp, bp2, N, BI_dvvsum, dest, ttop-47);
+ break;
+ case 'f':
+ BI_TreeComb(ctxt, bp, bp2, N, BI_dvvsum, dest, FULLCON);
+ break;
+ case 't':
+ BI_TreeComb(ctxt, bp, bp2, N, BI_dvvsum, dest, ctxt->Nb_co);
+ break;
+ case 'h':
+/*
+ * Use bidirectional exchange if everyone wants answer
+ */
+ if ( (trdest == -1) && !(ctxt->TopsCohrnt) )
+ BI_BeComb(ctxt, bp, bp2, N, BI_dvvsum);
+ else
+ BI_TreeComb(ctxt, bp, bp2, N, BI_dvvsum, dest, 2);
+ break;
+ default :
+ BI_BlacsErr(Mpval(ConTxt), __LINE__, __FILE__, "Unknown topology '%c'",
+ ttop);
+ }
+
+/*
+ * If I am selected to receive answer
+ */
+ if (bp != &BI_AuxBuff)
+ {
+ if ( (ctxt->scp->Iam == dest) || (dest == -1) )
+ BI_dvmcopy(Mpval(m), Mpval(n), A, tlda, bp->Buff);
+ BI_UpdateBuffs(bp);
+ }
+ else
+ {
+ if (BI_ActiveQ) BI_UpdateBuffs(NULL);
+ BI_BuffIsFree(bp, 1);
+ }
+}
diff --git a/BLACS/SRC/dtrbr2d_.c b/BLACS/SRC/dtrbr2d_.c
new file mode 100644
index 0000000..cb2635b
--- /dev/null
+++ b/BLACS/SRC/dtrbr2d_.c
@@ -0,0 +1,224 @@
+#include "Bdef.h"
+
+#if (INTFACE == C_CALL)
+void Cdtrbr2d(int ConTxt, char *scope, char *top, char *uplo, char *diag,
+ int m, int n, double *A, int lda, int rsrc, int csrc)
+#else
+F_VOID_FUNC dtrbr2d_(int *ConTxt, F_CHAR scope, F_CHAR top, F_CHAR uplo,
+ F_CHAR diag, int *m, int *n, double *A, int *lda,
+ int *rsrc, int *csrc)
+#endif
+/*
+ * -- V1.1 BLACS routine --
+ * University of Tennessee, May 1, 1996
+ * Written by Clint Whaley.
+ *
+ * Purpose
+ * =======
+ * Broadcast/receive for trapezoidal double precision arrays.
+ *
+ * Arguments
+ * =========
+ *
+ * ConTxt (input) Ptr to int
+ * Index into MyConTxts00 (my contexts array).
+ *
+ * SCOPE (input) Ptr to char
+ * Limit the scope of the operation.
+ * = 'R' : Operation is performed by a process row.
+ * = 'C' : Operation is performed by a process column.
+ * = 'A' : Operation is performed by all processes in grid.
+ *
+ * TOP (input) Ptr to char
+ * Controls fashion in which messages flow within the operation.
+ *
+ * UPLO (input) Ptr to char
+ * Specifies the part of the matrix to be sent.
+ * = 'U': Upper trapezoidal part
+ * ELSE : Lower trapezoidal part
+ *
+ * DIAG (input) Ptr to char
+ * Specifies whether the matrix is unit diagonal or not.
+ * = 'U': Matrix is unit diagonal, diagonal not communicated.
+ * ELSE : Matrix is not unit diagonal, diagonal is communicated.
+ *
+ * M (input) Ptr to int
+ * The number of rows of the matrix A. M >= 0.
+ *
+ * N (input) Ptr to int
+ * The number of columns of the matrix A. N >= 0.
+ *
+ * A (output) Ptr to double precision two dimensional array
+ * The m by n matrix A. Fortran77 (column-major) storage
+ * assumed.
+ * If UPLO = 'U', only the upper trapezoid is accessed;
+ * if UPLO = 'L', only the lower trapezoid is accessed.
+ *
+ * LDA (input) Ptr to int
+ * The leading dimension of the array A. LDA >= M.
+ *
+ *
+ * RSRC (input) Ptr to int
+ * The process row of the source of the matrix.
+ *
+ * CSRC (input) Ptr to int
+ * The process column of the source of the matrix.
+ *
+ *
+ * ------------------------------------------------------------------------
+ */
+{
+ void BI_ArgCheck(int, int, char *, char, char, char, int, int, int, int,
+ int *, int *);
+ int BI_HypBR(BLACSCONTEXT *, BLACBUFF *, SDRVPTR, int);
+ void BI_IdringBR(BLACSCONTEXT *, BLACBUFF *, SDRVPTR, int, int);
+ void BI_SringBR(BLACSCONTEXT *, BLACBUFF *, SDRVPTR, int);
+ void BI_MpathBR(BLACSCONTEXT *, BLACBUFF *, SDRVPTR, int, int);
+ void BI_TreeBR(BLACSCONTEXT *, BLACBUFF *, SDRVPTR, int, int);
+ void BI_UpdateBuffs(BLACBUFF *);
+ BLACBUFF *BI_GetBuff(int);
+ int BI_BuffIsFree(BLACBUFF *, int);
+ MPI_Datatype BI_GetMpiTrType(BLACSCONTEXT *, char, char, int, int, int,
+ MPI_Datatype, int *);
+ void BI_Unpack(BLACSCONTEXT *, BVOID *, BLACBUFF *, MPI_Datatype);
+ void BI_Ssend(BLACSCONTEXT *, int, int, BLACBUFF *);
+ void BI_Asend(BLACSCONTEXT *, int, int, BLACBUFF *);
+
+ BLACSCONTEXT *ctxt;
+ BLACBUFF *bp=NULL;
+ SDRVPTR send;
+ MPI_Datatype MatTyp;
+ int length, src, tlda, error, one=1;
+ char ttop, tscope, tuplo, tdiag;
+ extern BLACBUFF BI_AuxBuff, *BI_ActiveQ;
+
+ MGetConTxt(Mpval(ConTxt), ctxt);
+ ttop = F2C_CharTrans(top);
+ ttop = Mlowcase(ttop);
+ tscope = F2C_CharTrans(scope);
+ tscope = Mlowcase(tscope);
+ tdiag = F2C_CharTrans(diag);
+ tdiag = Mlowcase(tdiag);
+ tuplo = F2C_CharTrans(uplo);
+ tuplo = Mlowcase(tuplo);
+#if (BlacsDebugLvl > 0)
+ BI_ArgCheck(Mpval(ConTxt), RT_BR, __FILE__, tscope, tuplo, tdiag, Mpval(m),
+ Mpval(n), Mpval(lda), 1, Mpaddress(rsrc), Mpaddress(csrc));
+#endif
+/*
+ * If the user has set the default broadcast topology, use it instead of
+ * BLACS default
+ */
+#ifdef DefBSTop
+ if (ttop == ' ') ttop = DefBSTop;
+#endif
+ if (Mpval(m) <= Mpval(lda)) tlda = Mpval(lda);
+ else tlda = Mpval(m);
+
+ switch(tscope)
+ {
+ case 'r':
+ ctxt->scp = &ctxt->rscp;
+ src = Mpval(csrc);
+ break;
+ case 'c':
+ ctxt->scp = &ctxt->cscp;
+ src = Mpval(rsrc);
+ break;
+ case 'a':
+ ctxt->scp = &ctxt->ascp;
+ src = Mvkpnum(ctxt, Mpval(rsrc), Mpval(csrc));
+ break;
+ default:
+ BI_BlacsErr(Mpval(ConTxt), __LINE__, __FILE__, "Unknown scope '%c'",
+ tscope);
+ }
+
+ MatTyp = BI_GetMpiTrType(ctxt, tuplo, tdiag, Mpval(m), Mpval(n), tlda,
+ MPI_DOUBLE, &BI_AuxBuff.N);
+/*
+ * If using default topology, use MPI native broadcast
+ */
+ if (ttop == ' ')
+ {
+ error=MPI_Bcast(A, BI_AuxBuff.N, MatTyp, src, ctxt->scp->comm);
+ error=BI_MPI_TYPE_FREE(&MatTyp);
+ if (BI_ActiveQ) BI_UpdateBuffs(NULL);
+ return;
+ }
+/*
+ * If MPI handles non-contiguous buffering well, always use MPI data types
+ * instead of packing
+ */
+#ifdef MpiBuffGood
+ send = BI_Ssend;
+ BI_AuxBuff.Buff = (char *) A;
+ BI_AuxBuff.dtype = MatTyp;
+ bp = &BI_AuxBuff;
+#else
+
+ send = BI_Asend;
+ MPI_Pack_size(one, MatTyp, ctxt->scp->comm, &length, error);
+ bp = BI_GetBuff(length);
+ bp->N = length;
+ bp->dtype = MPI_PACKED;
+#if ZeroByteTypeBug
+ if (MatTyp == MPI_BYTE)
+ {
+ send = BI_Ssend;
+ bp->N = 0;
+ bp->dtype = MPI_BYTE;
+ }
+#endif
+
+#endif
+
+ switch(ttop)
+ {
+ case 'h':
+ error = BI_HypBR(ctxt, bp, send, src);
+ if (error == NPOW2) BI_TreeBR(ctxt, bp, send, src, 2);
+ break;
+ case '1':
+ case '2':
+ case '3':
+ case '4':
+ case '5':
+ case '6':
+ case '7':
+ case '8':
+ case '9':
+ BI_TreeBR(ctxt, bp, send, src, ttop-47);
+ break;
+ case 't':
+ BI_TreeBR(ctxt, bp, send, src, ctxt->Nb_bs);
+ break;
+ case 'i':
+ BI_IdringBR(ctxt, bp, send, src, 1);
+ break;
+ case 'd':
+ BI_IdringBR(ctxt, bp, send, src, -1);
+ break;
+ case 's':
+ BI_SringBR(ctxt, bp, send, src);
+ break;
+ case 'm':
+ BI_MpathBR(ctxt, bp, send, src, ctxt->Nr_bs);
+ break;
+ case 'f':
+ BI_MpathBR(ctxt, bp, send, src, FULLCON);
+ break;
+ default :
+ BI_BlacsErr(Mpval(ConTxt), __LINE__, __FILE__, "Unknown topology '%c'",
+ ttop);
+ }
+
+#ifdef MpiBuffGood
+ error=BI_MPI_TYPE_FREE(&MatTyp);
+ if (BI_ActiveQ) BI_UpdateBuffs(NULL);
+#endif
+#ifndef MpiBuffGood
+ BI_Unpack(ctxt, (BVOID *) A, bp, MatTyp);
+ BI_UpdateBuffs(bp);
+#endif
+}
diff --git a/BLACS/SRC/dtrbs2d_.c b/BLACS/SRC/dtrbs2d_.c
new file mode 100644
index 0000000..14a4379
--- /dev/null
+++ b/BLACS/SRC/dtrbs2d_.c
@@ -0,0 +1,206 @@
+#include "Bdef.h"
+
+#if (INTFACE == C_CALL)
+void Cdtrbs2d(int ConTxt, char *scope, char *top, char *uplo, char *diag,
+ int m, int n, double *A, int lda)
+#else
+F_VOID_FUNC dtrbs2d_(int *ConTxt, F_CHAR scope, F_CHAR top, F_CHAR uplo,
+ F_CHAR diag, int *m, int *n, double *A, int *lda)
+#endif
+/*
+ * -- V1.1 BLACS routine --
+ * University of Tennessee, May 1, 1996
+ * Written by Clint Whaley.
+ *
+ * Purpose
+ * =======
+ * Broadcast/send for trapezoidal double precision arrays.
+ *
+ * Arguments
+ * =========
+ *
+ * ConTxt (input) Ptr to int
+ * Index into MyConTxts00 (my contexts array).
+ *
+ * SCOPE (input) Ptr to char
+ * Limit the scope of the operation.
+ * = 'R' : Operation is performed by a process row.
+ * = 'C' : Operation is performed by a process column.
+ * = 'A' : Operation is performed by all processes in grid.
+ *
+ * TOP (input) Ptr to char
+ * Controls fashion in which messages flow within the operation.
+ *
+ * UPLO (input) Ptr to char
+ * Specifies the part of the matrix to be sent.
+ * = 'U': Upper trapezoidal part
+ * ELSE : Lower trapezoidal part
+ *
+ * DIAG (input) Ptr to char
+ * Specifies whether the matrix is unit diagonal or not.
+ * = 'U': Matrix is unit diagonal, diagonal not communicated.
+ * ELSE : Matrix is not unit diagonal, diagonal is communicated.
+ *
+ * M (input) Ptr to int
+ * The number of rows of the matrix A. M >= 0.
+ *
+ * N (input) Ptr to int
+ * The number of columns of the matrix A. N >= 0.
+ *
+ * A (input) Ptr to double precision two dimensional array
+ * The m by n matrix A. Fortran77 (column-major) storage
+ * assumed.
+ * If UPLO = 'U', only the upper trapezoid is accessed;
+ * if UPLO = 'L', only the lower trapezoid is accessed.
+ *
+ * LDA (input) Ptr to int
+ * The leading dimension of the array A. LDA >= M.
+ *
+ * ------------------------------------------------------------------------
+ */
+{
+ void BI_ArgCheck(int, int, char *, char, char, char, int, int, int, int,
+ int *, int *);
+ int BI_HypBS(BLACSCONTEXT *, BLACBUFF *, SDRVPTR);
+ void BI_IdringBS(BLACSCONTEXT *, BLACBUFF *, SDRVPTR, int);
+ void BI_SringBS(BLACSCONTEXT *, BLACBUFF *, SDRVPTR);
+ void BI_MpathBS(BLACSCONTEXT *, BLACBUFF *, SDRVPTR, int);
+ void BI_TreeBS(BLACSCONTEXT *, BLACBUFF *, SDRVPTR, int);
+ void BI_UpdateBuffs(BLACBUFF *);
+ BLACBUFF *BI_GetBuff(int);
+ int BI_BuffIsFree(BLACBUFF *, int);
+ MPI_Datatype BI_GetMpiTrType(BLACSCONTEXT *, char, char, int, int, int,
+ MPI_Datatype, int *);
+ BLACBUFF *BI_Pack(BLACSCONTEXT *, BVOID *, BLACBUFF *, MPI_Datatype);
+ void BI_Ssend(BLACSCONTEXT *, int, int, BLACBUFF *);
+ void BI_Asend(BLACSCONTEXT *, int, int, BLACBUFF *);
+
+ char ttop, tscope, tuplo, tdiag;
+ int error, tlda;
+ MPI_Datatype MatTyp;
+ SDRVPTR send;
+ BLACBUFF *bp;
+ BLACSCONTEXT *ctxt;
+ extern BLACBUFF BI_AuxBuff, *BI_ActiveQ;
+/*
+ * get context, lowcase char variables, and perform parameter checking
+ */
+ MGetConTxt(Mpval(ConTxt), ctxt);
+ ttop = F2C_CharTrans(top);
+ ttop = Mlowcase(ttop);
+ tscope = F2C_CharTrans(scope);
+ tscope = Mlowcase(tscope);
+ tuplo = F2C_CharTrans(uplo);
+ tuplo = Mlowcase(tuplo);
+ tdiag = F2C_CharTrans(diag);
+ tdiag = Mlowcase(tdiag);
+#if (BlacsDebugLvl > 0)
+ BI_ArgCheck(Mpval(ConTxt), RT_BS, __FILE__, 'a', tuplo, tdiag, Mpval(m),
+ Mpval(n), Mpval(lda), 0, NULL, NULL);
+#endif
+/*
+ * If the user has set the default broadcast topology, use it instead of
+ * BLACS default
+ */
+#ifdef DefBSTop
+ if (ttop == ' ') ttop = DefBSTop;
+#endif
+ if (Mpval(lda) < Mpval(m)) tlda = Mpval(m);
+ else tlda = Mpval(lda);
+
+ switch(tscope)
+ {
+ case 'r':
+ ctxt->scp = &ctxt->rscp;
+ break;
+ case 'c':
+ ctxt->scp = &ctxt->cscp;
+ break;
+ case 'a':
+ ctxt->scp = &ctxt->ascp;
+ break;
+ default:
+ BI_BlacsErr(Mpval(ConTxt), __LINE__, __FILE__, "Unknown scope '%c'",
+ tscope);
+ }
+ MatTyp = BI_GetMpiTrType(ctxt, tuplo, tdiag, Mpval(m), Mpval(n), tlda,
+ MPI_DOUBLE, &BI_AuxBuff.N);
+/*
+ * If using default topology, use MPI native broadcast
+ */
+ if (ttop == ' ')
+ {
+ error=MPI_Bcast(A, BI_AuxBuff.N, MatTyp, ctxt->scp->Iam, ctxt->scp->comm);
+ error=BI_MPI_TYPE_FREE(&MatTyp);
+ if (BI_ActiveQ) BI_UpdateBuffs(NULL);
+ return;
+ }
+/*
+ * If MPI handles non-contiguous buffering well, always use MPI data types
+ * instead of packing
+ */
+#ifdef MpiBuffGood
+ send = BI_Ssend;
+ BI_AuxBuff.Buff = (char *) A;
+ BI_AuxBuff.dtype = MatTyp;
+ bp = &BI_AuxBuff;
+#endif
+/*
+ * Pack and use non-blocking sends for broadcast if MPI's data types aren't
+ * more efficient
+ */
+#ifndef MpiBuffGood
+ send = BI_Asend;
+ bp = BI_Pack(ctxt, (BVOID *) A, NULL, MatTyp);
+#endif
+
+/*
+ * Call correct topology for BS/BR
+ */
+ switch(ttop)
+ {
+ case 'h':
+ error = BI_HypBS(ctxt, bp, send);
+ if (error == NPOW2) BI_TreeBS(ctxt, bp, send, 2);
+ break;
+ case '1':
+ case '2':
+ case '3':
+ case '4':
+ case '5':
+ case '6':
+ case '7':
+ case '8':
+ case '9':
+ BI_TreeBS(ctxt, bp, send, ttop-47);
+ break;
+ case 't':
+ BI_TreeBS(ctxt, bp, send, ctxt->Nb_bs);
+ break;
+ case 'i':
+ BI_IdringBS(ctxt, bp, send, 1);
+ break;
+ case 'd':
+ BI_IdringBS(ctxt, bp, send, -1);
+ break;
+ case 's':
+ BI_SringBS(ctxt, bp, send);
+ break;
+ case 'f':
+ BI_MpathBS(ctxt, bp, send, FULLCON);
+ break;
+ case 'm':
+ BI_MpathBS(ctxt, bp, send, ctxt->Nr_bs);
+ break;
+ default :
+ BI_BlacsErr(Mpval(ConTxt), __LINE__, __FILE__, "Unknown topology '%c'",
+ ttop);
+ }
+
+ error=BI_MPI_TYPE_FREE(&MatTyp);
+ if (bp == &BI_AuxBuff)
+ {
+ if (BI_ActiveQ) BI_UpdateBuffs(NULL);
+ }
+ else BI_UpdateBuffs(bp);
+} /* end dtrbs2d_ */
diff --git a/BLACS/SRC/dtrrv2d_.c b/BLACS/SRC/dtrrv2d_.c
new file mode 100644
index 0000000..d132fd4
--- /dev/null
+++ b/BLACS/SRC/dtrrv2d_.c
@@ -0,0 +1,101 @@
+#include "Bdef.h"
+
+#if (INTFACE == C_CALL)
+void Cdtrrv2d(int ConTxt, char *uplo, char *diag, int m, int n, double *A,
+ int lda, int rsrc, int csrc)
+#else
+F_VOID_FUNC dtrrv2d_(int *ConTxt, F_CHAR uplo, F_CHAR diag, int *m, int *n,
+ double *A, int *lda, int *rsrc, int *csrc)
+#endif
+/*
+ * -- V1.1 BLACS routine --
+ * University of Tennessee, May 1, 1996
+ * Written by Clint Whaley.
+ *
+ * Purpose
+ * =======
+ * Globally-blocking point to point trapezoidal double precision receive.
+ *
+ * Arguments
+ * =========
+ *
+ * ConTxt (input) Ptr to int
+ * Index into MyConTxts00 (my contexts array).
+ *
+ * UPLO (input) Ptr to char
+ * Specifies the part of the matrix to be sent.
+ * = 'U': Upper trapezoidal part
+ * ELSE : Lower trapezoidal part
+ *
+ * DIAG (input) Ptr to char
+ * Specifies whether the matrix is unit diagonal or not.
+ * = 'U': Matrix is unit diagonal, diagonal not communicated.
+ * ELSE : Matrix is not unit diagonal, diagonal is communicated.
+ *
+ * M (input) Ptr to int
+ * The number of rows of the matrix A. M >= 0.
+ *
+ * N (input) Ptr to int
+ * The number of columns of the matrix A. N >= 0.
+ *
+ * A (output) Ptr to double precision two dimensional array
+ * The m by n matrix A. Fortran77 (column-major) storage
+ * assumed.
+ * If UPLO = 'U', only the upper trapezoid is accessed;
+ * if UPLO = 'L', only the lower trapezoid is accessed.
+ *
+ * LDA (input) Ptr to int
+ * The leading dimension of the array A. LDA >= M.
+ *
+ *
+ * RSRC (input) Ptr to int
+ * The process row of the source of the matrix.
+ *
+ * CSRC (input) Ptr to int
+ * The process column of the source of the matrix.
+ *
+ *
+ * ------------------------------------------------------------------------
+ */
+{
+/*
+ * Prototypes and variable declarations
+ */
+ void BI_ArgCheck(int, int, char *, char, char, char, int, int, int, int,
+ int *, int *);
+ MPI_Datatype BI_GetMpiTrType(BLACSCONTEXT *, char, char, int, int, int,
+ MPI_Datatype, int *);
+ void BI_Unpack(BLACSCONTEXT *, BVOID *, BLACBUFF *, MPI_Datatype);
+ void BI_Srecv(BLACSCONTEXT *, int, int, BLACBUFF *);
+ void BI_UpdateBuffs(BLACBUFF *);
+ BLACBUFF *BI_GetBuff(int);
+ int BI_BuffIsFree(BLACBUFF *, int);
+ int tuplo, tdiag, tlda;
+ int ierr, length;
+ BLACBUFF *bp;
+ MPI_Datatype MatTyp;
+ BLACSCONTEXT *ctxt;
+ extern BLACBUFF BI_AuxBuff, *BI_ActiveQ;
+
+ MGetConTxt(Mpval(ConTxt), ctxt);
+ tdiag = F2C_CharTrans(diag);
+ tuplo = F2C_CharTrans(uplo);
+ tdiag = Mlowcase(tdiag);
+ tuplo = Mlowcase(tuplo);
+
+#if (BlacsDebugLvl > 0)
+ BI_ArgCheck(Mpval(ConTxt), RT_RV, __FILE__, 'a', tuplo, tdiag, Mpval(m),
+ Mpval(n), Mpval(lda), 1, Mpaddress(rsrc), Mpaddress(csrc));
+#endif
+ if (Mpval(lda) < Mpval(m)) tlda = Mpval(m);
+ else tlda = Mpval(lda);
+ ctxt->scp = &ctxt->pscp;
+
+ MatTyp = BI_GetMpiTrType(ctxt, tuplo, tdiag, Mpval(m), Mpval(n), tlda,
+ MPI_DOUBLE, &BI_AuxBuff.N);
+ BI_AuxBuff.Buff = (char *) A;
+ BI_AuxBuff.dtype = MatTyp;
+ BI_Srecv(ctxt, Mkpnum(ctxt, Mpval(rsrc), Mpval(csrc)), PT2PTID, &BI_AuxBuff);
+ ierr=BI_MPI_TYPE_FREE(&MatTyp);
+ if (BI_ActiveQ) BI_UpdateBuffs(NULL);
+}
diff --git a/BLACS/SRC/dtrsd2d_.c b/BLACS/SRC/dtrsd2d_.c
new file mode 100644
index 0000000..c90e669
--- /dev/null
+++ b/BLACS/SRC/dtrsd2d_.c
@@ -0,0 +1,113 @@
+#include "Bdef.h"
+
+#if (INTFACE == C_CALL)
+void Cdtrsd2d(int ConTxt, char *uplo, char *diag, int m, int n, double *A,
+ int lda, int rdest, int cdest)
+#else
+F_VOID_FUNC dtrsd2d_(int *ConTxt, F_CHAR uplo, F_CHAR diag, int *m, int *n,
+ double *A, int *lda, int *rdest, int *cdest)
+#endif
+/*
+ * -- V1.1 BLACS routine --
+ * University of Tennessee, May 1, 1996
+ * Written by Clint Whaley.
+ *
+ * Purpose
+ * =======
+ * Locally-blocking point-to-point trapezoidal double precision send.
+ *
+ * Arguments
+ * =========
+ *
+ * ConTxt (input) Ptr to int
+ * Index into MyConTxts00 (my contexts array).
+ *
+ * UPLO (input) Ptr to char
+ * Specifies the part of the matrix to be sent.
+ * = 'U': Upper trapezoidal part
+ * ELSE : Lower trapezoidal part
+ *
+ * DIAG (input) Ptr to char
+ * Specifies whether the matrix is unit diagonal or not.
+ * = 'U': Matrix is unit diagonal, diagonal not communicated.
+ * ELSE : Matrix is not unit diagonal, diagonal is communicated.
+ *
+ * M (input) Ptr to int
+ * The number of rows of the matrix A. M >= 0.
+ *
+ * N (input) Ptr to int
+ * The number of columns of the matrix A. N >= 0.
+ *
+ * A (input) Ptr to double precision two dimensional array
+ * The m by n matrix A. Fortran77 (column-major) storage
+ * assumed.
+ * If UPLO = 'U', only the upper trapezoid is accessed;
+ * if UPLO = 'L', only the lower trapezoid is accessed.
+ *
+ * LDA (input) Ptr to int
+ * The leading dimension of the array A. LDA >= M.
+ *
+ * RDEST (input) Ptr to int
+ * The process row of the destination process.
+ *
+ * CDEST (input) Ptr to int
+ * The process column of the destination process.
+ *
+ * ------------------------------------------------------------------------
+ */
+{
+ void BI_ArgCheck(int, int, char *, char, char, char, int, int, int, int,
+ int *, int *);
+ MPI_Datatype BI_GetMpiTrType(BLACSCONTEXT *, char, char, int, int, int,
+ MPI_Datatype, int *);
+ BLACBUFF *BI_Pack(BLACSCONTEXT *, BVOID *, BLACBUFF *, MPI_Datatype);
+ void BI_Ssend(BLACSCONTEXT *, int, int, BLACBUFF *);
+ void BI_Asend(BLACSCONTEXT *, int, int, BLACBUFF *);
+ void BI_UpdateBuffs(BLACBUFF *);
+ BLACBUFF *BI_GetBuff(int);
+ int BI_BuffIsFree(BLACBUFF *, int);
+
+ char tuplo, tdiag;
+ int dest, length, tlda, ierr;
+ BLACBUFF *bp;
+ BLACSCONTEXT *ctxt;
+ MPI_Datatype MatTyp;
+ extern BLACBUFF BI_AuxBuff, *BI_ActiveQ;
+
+ MGetConTxt(Mpval(ConTxt), ctxt);
+ tuplo = F2C_CharTrans(uplo);
+ tdiag = F2C_CharTrans(diag);
+ tuplo = Mlowcase(tuplo);
+ tdiag = Mlowcase(tdiag);
+
+#if (BlacsDebugLvl > 0)
+ BI_ArgCheck(Mpval(ConTxt), RT_SD, "DTRSD2D", 'a', tuplo, tdiag, Mpval(m),
+ Mpval(n), Mpval(lda), 1, Mpaddress(rdest), Mpaddress(cdest));
+#endif
+ if (Mpval(lda) < Mpval(m)) tlda = Mpval(m);
+ else tlda = Mpval(lda);
+ dest = Mvkpnum(ctxt, Mpval(rdest), Mpval(cdest));
+ ctxt->scp = &ctxt->pscp;
+
+ MatTyp = BI_GetMpiTrType(ctxt, tuplo, tdiag, Mpval(m), Mpval(n), tlda,
+ MPI_DOUBLE, &BI_AuxBuff.N);
+#ifdef SndIsLocBlk
+ BI_AuxBuff.Buff = (char *) A;
+ BI_AuxBuff.dtype = MatTyp;
+ BI_Ssend(ctxt, dest, PT2PTID, &BI_AuxBuff);
+#else
+ bp = BI_Pack(ctxt, (BVOID *) A, NULL, MatTyp);
+ BI_Asend(ctxt, Mkpnum(ctxt, Mpval(rdest), Mpval(cdest)), PT2PTID, bp);
+#endif
+ ierr=BI_MPI_TYPE_FREE(&MatTyp);
+
+/*
+ * Having started the async send, update the buffers (reform links, check if
+ * active buffers have become inactive, etc.)
+ */
+#ifdef SndIsLocBlk
+ if (BI_ActiveQ) BI_UpdateBuffs(NULL);
+#else
+ BI_UpdateBuffs(bp);
+#endif
+} /* end of dtrsd2d */
diff --git a/BLACS/SRC/dwalltime00_.c b/BLACS/SRC/dwalltime00_.c
new file mode 100644
index 0000000..f5c69fb
--- /dev/null
+++ b/BLACS/SRC/dwalltime00_.c
@@ -0,0 +1,10 @@
+#include "Bdef.h"
+
+#if (INTFACE == C_CALL)
+double Cdwalltime00(void)
+#else
+F_DOUBLE_FUNC dwalltime00_(void)
+#endif
+{
+ return(MPI_Wtime());
+}
diff --git a/BLACS/SRC/free_handle_.c b/BLACS/SRC/free_handle_.c
new file mode 100644
index 0000000..b7f6491
--- /dev/null
+++ b/BLACS/SRC/free_handle_.c
@@ -0,0 +1,50 @@
+#include "Bdef.h"
+
+#if (INTFACE == C_CALL)
+void Cfree_blacs_system_handle(int ISysCtxt)
+#else
+void free_blacs_system_handle_(int *ISysCxt)
+#endif
+{
+#if (INTFACE == C_CALL)
+ int i, j, DEF_WORLD;
+ MPI_Comm *tSysCtxt;
+ extern int BI_MaxNSysCtxt;
+ extern MPI_Comm *BI_SysContxts;
+
+
+ if ( (ISysCtxt < BI_MaxNSysCtxt) && (ISysCtxt > 0) )
+ {
+ if (BI_SysContxts[ISysCtxt] != MPI_COMM_NULL)
+ BI_SysContxts[ISysCtxt] = MPI_COMM_NULL;
+ else BI_BlacsWarn(-1, __LINE__, __FILE__,
+ "Trying to free non-existent system context handle %d", ISysCtxt);
+ }
+ else if (ISysCtxt == 0) return; /* never free MPI_COMM_WORLD */
+ else BI_BlacsWarn(-1, __LINE__, __FILE__,
+ "Trying to free non-existent system context handle %d", ISysCtxt);
+
+/*
+ * See if we have freed enough space to decrease the size of our table
+ */
+ for (i=j=0; i < BI_MaxNSysCtxt; i++)
+ if (BI_SysContxts[i] == MPI_COMM_NULL) j++;
+/*
+ * If needed, get a smaller system context array
+ */
+ if (j > 2*MAXNSYSCTXT)
+ {
+ j = BI_MaxNSysCtxt - MAXNSYSCTXT;
+ tSysCtxt = (MPI_Comm *) malloc(j * sizeof(MPI_Comm));
+ for (i=j=0; i < BI_MaxNSysCtxt; i++)
+ {
+ if (BI_SysContxts[i] != MPI_COMM_NULL)
+ tSysCtxt[j++] = BI_SysContxts[i];
+ }
+ BI_MaxNSysCtxt -= MAXNSYSCTXT;
+ for(; j < BI_MaxNSysCtxt; j++) tSysCtxt[j] = MPI_COMM_NULL;
+ free(BI_SysContxts);
+ BI_SysContxts = tSysCtxt;
+ }
+#endif
+}
diff --git a/BLACS/SRC/igamn2d_.c b/BLACS/SRC/igamn2d_.c
new file mode 100644
index 0000000..16bc003
--- /dev/null
+++ b/BLACS/SRC/igamn2d_.c
@@ -0,0 +1,370 @@
+#include "Bdef.h"
+
+#if (INTFACE == C_CALL)
+void Cigamn2d(int ConTxt, char *scope, char *top, int m, int n, int *A,
+ int lda, int *rA, int *cA, int ldia, int rdest, int cdest)
+#else
+F_VOID_FUNC igamn2d_(int *ConTxt, F_CHAR scope, F_CHAR top, int *m, int *n,
+ int *A, int *lda, int *rA, int *cA, int *ldia,
+ int *rdest, int *cdest)
+#endif
+/*
+ * -- V1.1 BLACS routine --
+ * University of Tennessee, May 1, 1996
+ * Written by Clint Whaley.
+ *
+ * Purpose
+ * =======
+ * Combine amn operation for integer rectangular matrices.
+ *
+ * Arguments
+ * =========
+ *
+ * ConTxt (input) Ptr to int
+ * Index into MyConTxts00 (my contexts array).
+ *
+ * SCOPE (input) Ptr to char
+ * Limit the scope of the operation.
+ * = 'R' : Operation is performed by a process row.
+ * = 'C' : Operation is performed by a process column.
+ * = 'A' : Operation is performed by all processes in grid.
+ *
+ * TOP (input) Ptr to char
+ * Controls fashion in which messages flow within the operation.
+ *
+ * M (input) Ptr to int
+ * The number of rows of the matrix A. M >= 0.
+ *
+ * N (input) Ptr to int
+ * The number of columns of the matrix A. N >= 0.
+ *
+ * A (output) Ptr to integer two dimensional array
+ * The m by n matrix A. Fortran77 (column-major) storage
+ * assumed.
+ *
+ * LDA (input) Ptr to int
+ * The leading dimension of the array A. LDA >= M.
+ *
+ * RA (output) Integer Array, dimension (LDIA, N)
+ * Contains process row that the amn of each element
+ * of A was found on: i.e., rA(1,2) contains the process
+ * row that the amn of A(1,2) was found on.
+ * Values are left on process {rdest, cdest} only, others
+ * may be modified, but not left with interesting data.
+ * If rdest == -1, then result is left on all processes in scope.
+ * If LDIA == -1, this array is not accessed, and need not exist.
+ *
+ * CA (output) Integer Array, dimension (LDIA, N)
+ * Contains process column that the amn of each element
+ * of A was found on: i.e., cA(1,2) contains the process
+ * column that the max/min of A(1,2) was found on.
+ * Values are left on process {rdest, cdest} only, others
+ * may be modified, but not left with interesting data.
+ * If rdest == -1, then result is left on all processes in scope.
+ * If LDIA == -1, this array is not accessed, and need not exist.
+ *
+ * LDIA (input) Ptr to int
+ * If (LDIA == -1), then the arrays RA and CA are not accessed.
+ * ELSE leading dimension of the arrays RA and CA. LDIA >= M.
+ *
+ * RDEST (input) Ptr to int
+ * The process row of the destination of the amn.
+ * If rdest == -1, then result is left on all processes in scope.
+ *
+ * CDEST (input) Ptr to int
+ * The process column of the destination of the amn.
+ * If rdest == -1, then CDEST ignored.
+ *
+ * ------------------------------------------------------------------------
+ */
+{
+ void BI_ArgCheck(int, int, char *, char, char, char, int, int, int, int,
+ int *, int *);
+ void BI_UpdateBuffs(BLACBUFF *);
+ BLACBUFF *BI_GetBuff(int);
+ int BI_BuffIsFree(BLACBUFF *, int);
+ MPI_Datatype BI_GetMpiGeType(BLACSCONTEXT *, int, int, int,
+ MPI_Datatype, int *);
+ BLACBUFF *BI_Pack(BLACSCONTEXT *, BVOID *, BLACBUFF *, MPI_Datatype);
+ MPI_Datatype BI_GetMpiGeType(BLACSCONTEXT *, int, int, int,
+ MPI_Datatype, int *);
+ void BI_Unpack(BLACSCONTEXT *, BVOID *, BLACBUFF *, MPI_Datatype);
+ void BI_MringComb(BLACSCONTEXT *, BLACBUFF *, BLACBUFF *, int, VVFUNPTR,
+ int, int);
+ void BI_TreeComb(BLACSCONTEXT *, BLACBUFF *, BLACBUFF *, int, VVFUNPTR,
+ int, int);
+ void BI_BeComb(BLACSCONTEXT *, BLACBUFF *, BLACBUFF *, int, VVFUNPTR);
+ void BI_ivvamn(int, char *, char *);
+ void BI_ivvamn2(int, char *, char *);
+ void BI_iMPI_amn(void *, void *, int *, MPI_Datatype *);
+ void BI_iMPI_amn2(void *, void *, int *, MPI_Datatype *);
+/*
+ * Variable Declarations
+ */
+ VVFUNPTR vvop;
+ BLACBUFF *bp, *bp2;
+ BLACSCONTEXT *ctxt;
+ char ttop, tscope;
+ int i, j, N, dest, idist, length, tlda, tldia, trdest, ierr;
+ int len[2];
+ MPI_Aint disp[2];
+ MPI_Datatype dtypes[2];
+ MPI_Op BlacComb;
+ MPI_Datatype MyType;
+ BI_DistType *dist, mydist;
+ extern BLACBUFF *BI_ActiveQ;
+ extern BLACBUFF BI_AuxBuff;
+
+ MGetConTxt(Mpval(ConTxt), ctxt);
+ ttop = F2C_CharTrans(top);
+ ttop = Mlowcase(ttop);
+ tscope = F2C_CharTrans(scope);
+ tscope = Mlowcase(tscope);
+/*
+ * If the user has set the default combine topology, use it instead of
+ * BLACS default
+ */
+#ifdef DefCombTop
+ if (ttop == ' ') ttop = DefCombTop;
+#endif
+ if (Mpval(cdest) == -1) trdest = -1;
+ else trdest = Mpval(rdest);
+#if (BlacsDebugLvl > 0)
+ BI_ArgCheck(Mpval(ConTxt), RT_COMB, __FILE__, tscope, 'u', 'u', Mpval(m),
+ Mpval(n), Mpval(lda), 1, &trdest, Mpaddress(cdest));
+ if (Mpval(ldia) < Mpval(m))
+ {
+ if (Mpval(ldia) != -1)
+ BI_BlacsWarn(Mpval(ConTxt), __LINE__, __FILE__,
+ "LDIA too small (LDIA=%d, but M=%d)", Mpval(ldia),
+ Mpval(m));
+ }
+#endif
+ if (Mpval(lda) >= Mpval(m)) tlda = Mpval(lda);
+ else tlda = Mpval(m);
+ if (Mpval(ldia) < Mpval(m)) tldia = Mpval(m);
+ else tldia = Mpval(ldia);
+ switch(tscope)
+ {
+ case 'r':
+ ctxt->scp = &ctxt->rscp;
+ if (trdest == -1) dest = -1;
+ else dest = Mpval(cdest);
+ break;
+ case 'c':
+ ctxt->scp = &ctxt->cscp;
+ dest = trdest;
+ break;
+ case 'a':
+ ctxt->scp = &ctxt->ascp;
+ if (trdest == -1) dest = -1;
+ else dest = Mvkpnum(ctxt, trdest, Mpval(cdest));
+ break;
+ default:
+ BI_BlacsErr(Mpval(ConTxt), __LINE__, __FILE__, "Unknown scope '%c'",
+ tscope);
+ }
+
+
+/*
+ * It's not defined how MPI reacts to 0 element reductions, so use BLACS 1-tree
+ * topology if we've got one
+ */
+ if (ttop == ' ') if ( (Mpval(m) < 1) || (Mpval(n) < 1) ) ttop = '1';
+ N = Mpval(m) * Mpval(n);
+/*
+ * If process who has amn is to be communicated, must set up distance
+ * vector after value vector
+ */
+ if (Mpval(ldia) != -1)
+ {
+ vvop = BI_ivvamn;
+ length = N * sizeof(int);
+ i = length % sizeof(BI_DistType); /* ensure dist vec aligned correctly */
+ if (i) length += sizeof(BI_DistType) - i;
+ idist = length;
+ length += N * sizeof(BI_DistType);
+/*
+ * For performance, insist second buffer is at least 8-byte aligned
+ */
+ j = 8;
+ if (sizeof(int) > j) j = sizeof(int);
+ i = length % j;
+ if (i) length += j - i;
+ i = 2 * length;
+
+ bp = BI_GetBuff(i);
+ bp2 = &BI_AuxBuff;
+ bp2->Buff = &bp->Buff[length];
+ BI_imvcopy(Mpval(m), Mpval(n), A, tlda, bp->Buff);
+/*
+ * Fill in distance vector
+ */
+ if (dest == -1) mydist = ctxt->scp->Iam;
+ else mydist = (ctxt->scp->Np + ctxt->scp->Iam - dest) % ctxt->scp->Np;
+ dist = (BI_DistType *) &bp->Buff[idist];
+ for (i=0; i < N; i++) dist[i] = mydist;
+
+/*
+ * Create the MPI datatype holding both user's buffer and distance vector
+ */
+ len[0] = len[1] = N;
+ disp[0] = 0;
+ disp[1] = idist;
+ dtypes[0] = MPI_INT;
+ dtypes[1] = BI_MpiDistType;
+#ifdef ZeroByteTypeBug
+ if (N > 0)
+ {
+#endif
+ i = 2;
+ ierr=MPI_Type_struct(i, len, disp, dtypes, &MyType);
+ ierr=MPI_Type_commit(&MyType);
+ bp->N = bp2->N = 1;
+ bp->dtype = bp2->dtype = MyType;
+#ifdef ZeroByteTypeBug
+ }
+ else
+ {
+ bp->N = bp2->N = 0;
+ bp->dtype = bp2->dtype = MPI_INT;
+ }
+#endif
+ }
+ else
+ {
+ vvop = BI_ivvamn2;
+ length = N * sizeof(int);
+/*
+ * If A is contiguous, we can use it as one of our buffers
+ */
+ if ( (Mpval(m) == tlda) || (Mpval(n) == 1) )
+ {
+ bp = &BI_AuxBuff;
+ bp->Buff = (char *) A;
+ bp2 = BI_GetBuff(length);
+ }
+ else
+ {
+ bp = BI_GetBuff(length*2);
+ bp2 = &BI_AuxBuff;
+ bp2->Buff = &bp->Buff[length];
+ BI_imvcopy(Mpval(m), Mpval(n), A, tlda, bp->Buff);
+ }
+ bp->N = bp2->N = N;
+ bp->dtype = bp2->dtype = MPI_INT;
+ }
+
+ switch(ttop)
+ {
+ case ' ': /* use MPI's reduction by default */
+ i = 1;
+ if (Mpval(ldia) == -1)
+ {
+ ierr=MPI_Op_create(BI_iMPI_amn2, i, &BlacComb);
+ }
+ else
+ {
+ ierr=MPI_Op_create(BI_iMPI_amn, i, &BlacComb);
+ BI_AuxBuff.Len = N; /* set this up for the MPI OP wrappers */
+ }
+
+ if (trdest != -1)
+ {
+ ierr=MPI_Reduce(bp->Buff, bp2->Buff, bp->N, bp->dtype, BlacComb, dest,
+ ctxt->scp->comm);
+ if (ctxt->scp->Iam == dest)
+ {
+ BI_ivmcopy(Mpval(m), Mpval(n), A, tlda, bp2->Buff);
+ if (Mpval(ldia) != -1)
+ BI_TransDist(ctxt, tscope, Mpval(m), Mpval(n), rA, cA, tldia,
+ (BI_DistType *) &bp2->Buff[idist],
+ trdest, Mpval(cdest));
+ }
+ }
+ else
+ {
+ ierr=MPI_Allreduce(bp->Buff, bp2->Buff, bp->N, bp->dtype, BlacComb,
+ ctxt->scp->comm);
+ BI_ivmcopy(Mpval(m), Mpval(n), A, tlda, bp2->Buff);
+ if (Mpval(ldia) != -1)
+ BI_TransDist(ctxt, tscope, Mpval(m), Mpval(n), rA, cA, tldia,
+ (BI_DistType *) &bp2->Buff[idist],
+ trdest, Mpval(cdest));
+ }
+ ierr=MPI_Op_free(&BlacComb);
+ if (Mpval(ldia) != -1)
+#ifdef ZeroByteTypeBug
+ if (N > 0)
+#endif
+ ierr=BI_MPI_TYPE_FREE(&MyType);
+ if (BI_ActiveQ) BI_UpdateBuffs(NULL);
+ return;
+ break;
+ case 'i':
+ BI_MringComb(ctxt, bp, bp2, N, vvop, dest, 1);
+ break;
+ case 'd':
+ BI_MringComb(ctxt, bp, bp2, N, vvop, dest, -1);
+ break;
+ case 's':
+ BI_MringComb(ctxt, bp, bp2, N, vvop, dest, 2);
+ break;
+ case 'm':
+ BI_MringComb(ctxt, bp, bp2, N, vvop, dest, ctxt->Nr_co);
+ break;
+ case '1':
+ case '2':
+ case '3':
+ case '4':
+ case '5':
+ case '6':
+ case '7':
+ case '8':
+ case '9':
+ BI_TreeComb(ctxt, bp, bp2, N, vvop, dest, ttop-47);
+ break;
+ case 'f':
+ BI_TreeComb(ctxt, bp, bp2, N, vvop, dest, FULLCON);
+ break;
+ case 't':
+ BI_TreeComb(ctxt, bp, bp2, N, vvop, dest, ctxt->Nb_co);
+ break;
+ case 'h':
+/*
+ * Use bidirectional exchange if everyone wants answer
+ */
+ if ( (trdest == -1) && !(ctxt->TopsCohrnt) )
+ BI_BeComb(ctxt, bp, bp2, N, vvop);
+ else
+ BI_TreeComb(ctxt, bp, bp2, N, vvop, dest, 2);
+ break;
+ default :
+ BI_BlacsErr(Mpval(ConTxt), __LINE__, __FILE__, "Unknown topology '%c'",
+ ttop);
+ }
+
+ if (Mpval(ldia) != -1)
+#ifdef ZeroByteTypeBug
+ if (N > 0)
+#endif
+ ierr=BI_MPI_TYPE_FREE(&MyType);
+/*
+ * If I am selected to receive answer
+ */
+ if ( (ctxt->scp->Iam == dest) || (dest == -1) )
+ {
+/*
+ * Translate the distances stored in the latter part of bp->Buff into
+ * process grid coordinates, and output these coordinates in the
+ * arrays rA and cA.
+ */
+ if (Mpval(ldia) != -1)
+ BI_TransDist(ctxt, tscope, Mpval(m), Mpval(n), rA, cA, tldia,
+ dist, trdest, Mpval(cdest));
+/*
+ * Unpack the amn array
+ */
+ if (bp != &BI_AuxBuff) BI_ivmcopy(Mpval(m), Mpval(n), A, tlda, bp->Buff);
+ }
+}
diff --git a/BLACS/SRC/igamx2d_.c b/BLACS/SRC/igamx2d_.c
new file mode 100644
index 0000000..8165cbe
--- /dev/null
+++ b/BLACS/SRC/igamx2d_.c
@@ -0,0 +1,370 @@
+#include "Bdef.h"
+
+#if (INTFACE == C_CALL)
+void Cigamx2d(int ConTxt, char *scope, char *top, int m, int n, int *A,
+ int lda, int *rA, int *cA, int ldia, int rdest, int cdest)
+#else
+F_VOID_FUNC igamx2d_(int *ConTxt, F_CHAR scope, F_CHAR top, int *m, int *n,
+ int *A, int *lda, int *rA, int *cA, int *ldia,
+ int *rdest, int *cdest)
+#endif
+/*
+ * -- V1.1 BLACS routine --
+ * University of Tennessee, May 1, 1996
+ * Written by Clint Whaley.
+ *
+ * Purpose
+ * =======
+ * Combine amx operation for integer rectangular matrices.
+ *
+ * Arguments
+ * =========
+ *
+ * ConTxt (input) Ptr to int
+ * Index into MyConTxts00 (my contexts array).
+ *
+ * SCOPE (input) Ptr to char
+ * Limit the scope of the operation.
+ * = 'R' : Operation is performed by a process row.
+ * = 'C' : Operation is performed by a process column.
+ * = 'A' : Operation is performed by all processes in grid.
+ *
+ * TOP (input) Ptr to char
+ * Controls fashion in which messages flow within the operation.
+ *
+ * M (input) Ptr to int
+ * The number of rows of the matrix A. M >= 0.
+ *
+ * N (input) Ptr to int
+ * The number of columns of the matrix A. N >= 0.
+ *
+ * A (output) Ptr to integer two dimensional array
+ * The m by n matrix A. Fortran77 (column-major) storage
+ * assumed.
+ *
+ * LDA (input) Ptr to int
+ * The leading dimension of the array A. LDA >= M.
+ *
+ * RA (output) Integer Array, dimension (LDIA, N)
+ * Contains process row that the amx of each element
+ * of A was found on: i.e., rA(1,2) contains the process
+ * row that the amx of A(1,2) was found on.
+ * Values are left on process {rdest, cdest} only, others
+ * may be modified, but not left with interesting data.
+ * If rdest == -1, then result is left on all processes in scope.
+ * If LDIA == -1, this array is not accessed, and need not exist.
+ *
+ * CA (output) Integer Array, dimension (LDIA, N)
+ * Contains process column that the amx of each element
+ * of A was found on: i.e., cA(1,2) contains the process
+ * column that the max/min of A(1,2) was found on.
+ * Values are left on process {rdest, cdest} only, others
+ * may be modified, but not left with interesting data.
+ * If rdest == -1, then result is left on all processes in scope.
+ * If LDIA == -1, this array is not accessed, and need not exist.
+ *
+ * LDIA (input) Ptr to int
+ * If (LDIA == -1), then the arrays RA and CA are not accessed.
+ * ELSE leading dimension of the arrays RA and CA. LDIA >= M.
+ *
+ * RDEST (input) Ptr to int
+ * The process row of the destination of the amx.
+ * If rdest == -1, then result is left on all processes in scope.
+ *
+ * CDEST (input) Ptr to int
+ * The process column of the destination of the amx.
+ * If rdest == -1, then CDEST ignored.
+ *
+ * ------------------------------------------------------------------------
+ */
+{
+ void BI_ArgCheck(int, int, char *, char, char, char, int, int, int, int,
+ int *, int *);
+ void BI_UpdateBuffs(BLACBUFF *);
+ BLACBUFF *BI_GetBuff(int);
+ int BI_BuffIsFree(BLACBUFF *, int);
+ MPI_Datatype BI_GetMpiGeType(BLACSCONTEXT *, int, int, int,
+ MPI_Datatype, int *);
+ BLACBUFF *BI_Pack(BLACSCONTEXT *, BVOID *, BLACBUFF *, MPI_Datatype);
+ MPI_Datatype BI_GetMpiGeType(BLACSCONTEXT *, int, int, int,
+ MPI_Datatype, int *);
+ void BI_Unpack(BLACSCONTEXT *, BVOID *, BLACBUFF *, MPI_Datatype);
+ void BI_MringComb(BLACSCONTEXT *, BLACBUFF *, BLACBUFF *, int, VVFUNPTR,
+ int, int);
+ void BI_TreeComb(BLACSCONTEXT *, BLACBUFF *, BLACBUFF *, int, VVFUNPTR,
+ int, int);
+ void BI_BeComb(BLACSCONTEXT *, BLACBUFF *, BLACBUFF *, int, VVFUNPTR);
+ void BI_ivvamx(int, char *, char *);
+ void BI_ivvamx2(int, char *, char *);
+ void BI_iMPI_amx(void *, void *, int *, MPI_Datatype *);
+ void BI_iMPI_amx2(void *, void *, int *, MPI_Datatype *);
+/*
+ * Variable Declarations
+ */
+ VVFUNPTR vvop;
+ BLACBUFF *bp, *bp2;
+ BLACSCONTEXT *ctxt;
+ char ttop, tscope;
+ int i, j, N, dest, idist, length, tlda, tldia, trdest, ierr;
+ int len[2];
+ MPI_Aint disp[2];
+ MPI_Datatype dtypes[2];
+ MPI_Op BlacComb;
+ MPI_Datatype MyType;
+ BI_DistType *dist, mydist;
+ extern BLACBUFF *BI_ActiveQ;
+ extern BLACBUFF BI_AuxBuff;
+
+ MGetConTxt(Mpval(ConTxt), ctxt);
+ ttop = F2C_CharTrans(top);
+ ttop = Mlowcase(ttop);
+ tscope = F2C_CharTrans(scope);
+ tscope = Mlowcase(tscope);
+/*
+ * If the user has set the default combine topology, use it instead of
+ * BLACS default
+ */
+#ifdef DefCombTop
+ if (ttop == ' ') ttop = DefCombTop;
+#endif
+ if (Mpval(cdest) == -1) trdest = -1;
+ else trdest = Mpval(rdest);
+#if (BlacsDebugLvl > 0)
+ BI_ArgCheck(Mpval(ConTxt), RT_COMB, __FILE__, tscope, 'u', 'u', Mpval(m),
+ Mpval(n), Mpval(lda), 1, &trdest, Mpaddress(cdest));
+ if (Mpval(ldia) < Mpval(m))
+ {
+ if (Mpval(ldia) != -1)
+ BI_BlacsWarn(Mpval(ConTxt), __LINE__, __FILE__,
+ "LDIA too small (LDIA=%d, but M=%d)", Mpval(ldia),
+ Mpval(m));
+ }
+#endif
+ if (Mpval(lda) >= Mpval(m)) tlda = Mpval(lda);
+ else tlda = Mpval(m);
+ if (Mpval(ldia) < Mpval(m)) tldia = Mpval(m);
+ else tldia = Mpval(ldia);
+ switch(tscope)
+ {
+ case 'r':
+ ctxt->scp = &ctxt->rscp;
+ if (trdest == -1) dest = -1;
+ else dest = Mpval(cdest);
+ break;
+ case 'c':
+ ctxt->scp = &ctxt->cscp;
+ dest = trdest;
+ break;
+ case 'a':
+ ctxt->scp = &ctxt->ascp;
+ if (trdest == -1) dest = -1;
+ else dest = Mvkpnum(ctxt, trdest, Mpval(cdest));
+ break;
+ default:
+ BI_BlacsErr(Mpval(ConTxt), __LINE__, __FILE__, "Unknown scope '%c'",
+ tscope);
+ }
+
+
+/*
+ * It's not defined how MPI reacts to 0 element reductions, so use BLACS 1-tree
+ * topology if we've got one
+ */
+ if (ttop == ' ') if ( (Mpval(m) < 1) || (Mpval(n) < 1) ) ttop = '1';
+ N = Mpval(m) * Mpval(n);
+/*
+ * If process who has amx is to be communicated, must set up distance
+ * vector after value vector
+ */
+ if (Mpval(ldia) != -1)
+ {
+ vvop = BI_ivvamx;
+ length = N * sizeof(int);
+ i = length % sizeof(BI_DistType); /* ensure dist vec aligned correctly */
+ if (i) length += sizeof(BI_DistType) - i;
+ idist = length;
+ length += N * sizeof(BI_DistType);
+/*
+ * For performance, insist second buffer is at least 8-byte aligned
+ */
+ j = 8;
+ if (sizeof(int) > j) j = sizeof(int);
+ i = length % j;
+ if (i) length += j - i;
+ i = 2 * length;
+
+ bp = BI_GetBuff(i);
+ bp2 = &BI_AuxBuff;
+ bp2->Buff = &bp->Buff[length];
+ BI_imvcopy(Mpval(m), Mpval(n), A, tlda, bp->Buff);
+/*
+ * Fill in distance vector
+ */
+ if (dest == -1) mydist = ctxt->scp->Iam;
+ else mydist = (ctxt->scp->Np + ctxt->scp->Iam - dest) % ctxt->scp->Np;
+ dist = (BI_DistType *) &bp->Buff[idist];
+ for (i=0; i < N; i++) dist[i] = mydist;
+
+/*
+ * Create the MPI datatype holding both user's buffer and distance vector
+ */
+ len[0] = len[1] = N;
+ disp[0] = 0;
+ disp[1] = idist;
+ dtypes[0] = MPI_INT;
+ dtypes[1] = BI_MpiDistType;
+#ifdef ZeroByteTypeBug
+ if (N > 0)
+ {
+#endif
+ i = 2;
+ ierr=MPI_Type_struct(i, len, disp, dtypes, &MyType);
+ ierr=MPI_Type_commit(&MyType);
+ bp->N = bp2->N = 1;
+ bp->dtype = bp2->dtype = MyType;
+#ifdef ZeroByteTypeBug
+ }
+ else
+ {
+ bp->N = bp2->N = 0;
+ bp->dtype = bp2->dtype = MPI_INT;
+ }
+#endif
+ }
+ else
+ {
+ vvop = BI_ivvamx2;
+ length = N * sizeof(int);
+/*
+ * If A is contiguous, we can use it as one of our buffers
+ */
+ if ( (Mpval(m) == tlda) || (Mpval(n) == 1) )
+ {
+ bp = &BI_AuxBuff;
+ bp->Buff = (char *) A;
+ bp2 = BI_GetBuff(length);
+ }
+ else
+ {
+ bp = BI_GetBuff(length*2);
+ bp2 = &BI_AuxBuff;
+ bp2->Buff = &bp->Buff[length];
+ BI_imvcopy(Mpval(m), Mpval(n), A, tlda, bp->Buff);
+ }
+ bp->N = bp2->N = N;
+ bp->dtype = bp2->dtype = MPI_INT;
+ }
+
+ switch(ttop)
+ {
+ case ' ': /* use MPI's reduction by default */
+ i = 1;
+ if (Mpval(ldia) == -1)
+ {
+ ierr=MPI_Op_create(BI_iMPI_amx2, i, &BlacComb);
+ }
+ else
+ {
+ ierr=MPI_Op_create(BI_iMPI_amx, i, &BlacComb);
+ BI_AuxBuff.Len = N; /* set this up for the MPI OP wrappers */
+ }
+
+ if (trdest != -1)
+ {
+ ierr=MPI_Reduce(bp->Buff, bp2->Buff, bp->N, bp->dtype, BlacComb, dest,
+ ctxt->scp->comm);
+ if (ctxt->scp->Iam == dest)
+ {
+ BI_ivmcopy(Mpval(m), Mpval(n), A, tlda, bp2->Buff);
+ if (Mpval(ldia) != -1)
+ BI_TransDist(ctxt, tscope, Mpval(m), Mpval(n), rA, cA, tldia,
+ (BI_DistType *) &bp2->Buff[idist],
+ trdest, Mpval(cdest));
+ }
+ }
+ else
+ {
+ ierr=MPI_Allreduce(bp->Buff, bp2->Buff, bp->N, bp->dtype, BlacComb,
+ ctxt->scp->comm);
+ BI_ivmcopy(Mpval(m), Mpval(n), A, tlda, bp2->Buff);
+ if (Mpval(ldia) != -1)
+ BI_TransDist(ctxt, tscope, Mpval(m), Mpval(n), rA, cA, tldia,
+ (BI_DistType *) &bp2->Buff[idist],
+ trdest, Mpval(cdest));
+ }
+ ierr=MPI_Op_free(&BlacComb);
+ if (Mpval(ldia) != -1)
+#ifdef ZeroByteTypeBug
+ if (N > 0)
+#endif
+ ierr=BI_MPI_TYPE_FREE(&MyType);
+ if (BI_ActiveQ) BI_UpdateBuffs(NULL);
+ return;
+ break;
+ case 'i':
+ BI_MringComb(ctxt, bp, bp2, N, vvop, dest, 1);
+ break;
+ case 'd':
+ BI_MringComb(ctxt, bp, bp2, N, vvop, dest, -1);
+ break;
+ case 's':
+ BI_MringComb(ctxt, bp, bp2, N, vvop, dest, 2);
+ break;
+ case 'm':
+ BI_MringComb(ctxt, bp, bp2, N, vvop, dest, ctxt->Nr_co);
+ break;
+ case '1':
+ case '2':
+ case '3':
+ case '4':
+ case '5':
+ case '6':
+ case '7':
+ case '8':
+ case '9':
+ BI_TreeComb(ctxt, bp, bp2, N, vvop, dest, ttop-47);
+ break;
+ case 'f':
+ BI_TreeComb(ctxt, bp, bp2, N, vvop, dest, FULLCON);
+ break;
+ case 't':
+ BI_TreeComb(ctxt, bp, bp2, N, vvop, dest, ctxt->Nb_co);
+ break;
+ case 'h':
+/*
+ * Use bidirectional exchange if everyone wants answer
+ */
+ if ( (trdest == -1) && !(ctxt->TopsCohrnt) )
+ BI_BeComb(ctxt, bp, bp2, N, vvop);
+ else
+ BI_TreeComb(ctxt, bp, bp2, N, vvop, dest, 2);
+ break;
+ default :
+ BI_BlacsErr(Mpval(ConTxt), __LINE__, __FILE__, "Unknown topology '%c'",
+ ttop);
+ }
+
+ if (Mpval(ldia) != -1)
+#ifdef ZeroByteTypeBug
+ if (N > 0)
+#endif
+ ierr=BI_MPI_TYPE_FREE(&MyType);
+/*
+ * If I am selected to receive answer
+ */
+ if ( (ctxt->scp->Iam == dest) || (dest == -1) )
+ {
+/*
+ * Translate the distances stored in the latter part of bp->Buff into
+ * process grid coordinates, and output these coordinates in the
+ * arrays rA and cA.
+ */
+ if (Mpval(ldia) != -1)
+ BI_TransDist(ctxt, tscope, Mpval(m), Mpval(n), rA, cA, tldia,
+ dist, trdest, Mpval(cdest));
+/*
+ * Unpack the amx array
+ */
+ if (bp != &BI_AuxBuff) BI_ivmcopy(Mpval(m), Mpval(n), A, tlda, bp->Buff);
+ }
+}
diff --git a/BLACS/SRC/igebr2d_.c b/BLACS/SRC/igebr2d_.c
new file mode 100644
index 0000000..609ee59
--- /dev/null
+++ b/BLACS/SRC/igebr2d_.c
@@ -0,0 +1,226 @@
+#include "Bdef.h"
+
+#if (INTFACE == C_CALL)
+void Cigebr2d(int ConTxt, char *scope, char *top, int m, int n, int *A,
+ int lda, int rsrc, int csrc)
+#else
+F_VOID_FUNC igebr2d_(int *ConTxt, F_CHAR scope, F_CHAR top, int *m, int *n,
+ int *A, int *lda, int *rsrc, int *csrc)
+#endif
+/*
+ * -- V1.1 BLACS routine --
+ * University of Tennessee, May 1, 1996
+ * Written by Clint Whaley.
+ *
+ * Purpose
+ * =======
+ * Broadcast/receive for general integer arrays.
+ *
+ * Arguments
+ * =========
+ *
+ * ConTxt (input) Ptr to int
+ * Index into MyConTxts00 (my contexts array).
+ *
+ * SCOPE (input) Ptr to char
+ * Limit the scope of the operation.
+ * = 'R' : Operation is performed by a process row.
+ * = 'C' : Operation is performed by a process column.
+ * = 'A' : Operation is performed by all processes in grid.
+ *
+ * TOP (input) Ptr to char
+ * Controls fashion in which messages flow within the operation.
+ *
+ * M (input) Ptr to int
+ * The number of rows of the matrix A. M >= 0.
+ *
+ * N (input) Ptr to int
+ * The number of columns of the matrix A. N >= 0.
+ *
+ * A (output) Ptr to integer two dimensional array
+ * The m by n matrix A. Fortran77 (column-major) storage
+ * assumed.
+ *
+ * LDA (input) Ptr to int
+ * The leading dimension of the array A. LDA >= M.
+ *
+ *
+ * RSRC (input) Ptr to int
+ * The process row of the source of the matrix.
+ *
+ * CSRC (input) Ptr to int
+ * The process column of the source of the matrix.
+ *
+ *
+ * ------------------------------------------------------------------------
+ */
+{
+ void BI_ArgCheck(int, int, char *, char, char, char, int, int, int, int,
+ int *, int *);
+ int BI_HypBR(BLACSCONTEXT *, BLACBUFF *, SDRVPTR, int);
+ void BI_IdringBR(BLACSCONTEXT *, BLACBUFF *, SDRVPTR, int, int);
+ void BI_SringBR(BLACSCONTEXT *, BLACBUFF *, SDRVPTR, int);
+ void BI_MpathBR(BLACSCONTEXT *, BLACBUFF *, SDRVPTR, int, int);
+ void BI_TreeBR(BLACSCONTEXT *, BLACBUFF *, SDRVPTR, int, int);
+ void BI_UpdateBuffs(BLACBUFF *);
+ BLACBUFF *BI_GetBuff(int);
+ int BI_BuffIsFree(BLACBUFF *, int);
+ MPI_Datatype BI_GetMpiGeType(BLACSCONTEXT *, int, int, int,
+ MPI_Datatype, int *);
+ void BI_Unpack(BLACSCONTEXT *, BVOID *, BLACBUFF *, MPI_Datatype);
+ void BI_Ssend(BLACSCONTEXT *, int, int, BLACBUFF *);
+ void BI_Asend(BLACSCONTEXT *, int, int, BLACBUFF *);
+
+ BLACSCONTEXT *ctxt;
+ BLACBUFF *bp=NULL;
+ SDRVPTR send;
+ MPI_Datatype MatTyp;
+ int length, src, tlda, error, one=1;
+ char ttop, tscope;
+ extern BLACBUFF BI_AuxBuff, *BI_ActiveQ;
+
+ MGetConTxt(Mpval(ConTxt), ctxt);
+ ttop = F2C_CharTrans(top);
+ ttop = Mlowcase(ttop);
+ tscope = F2C_CharTrans(scope);
+ tscope = Mlowcase(tscope);
+#if (BlacsDebugLvl > 0)
+ BI_ArgCheck(Mpval(ConTxt), RT_BR, __FILE__, tscope, 'u', 'u', Mpval(m),
+ Mpval(n), Mpval(lda), 1, Mpaddress(rsrc), Mpaddress(csrc));
+#endif
+/*
+ * If the user has set the default broadcast topology, use it instead of
+ * BLACS default
+ */
+#ifdef DefBSTop
+ if (ttop == ' ') ttop = DefBSTop;
+#endif
+ if (Mpval(m) <= Mpval(lda)) tlda = Mpval(lda);
+ else tlda = Mpval(m);
+
+ switch(tscope)
+ {
+ case 'r':
+ ctxt->scp = &ctxt->rscp;
+ src = Mpval(csrc);
+ break;
+ case 'c':
+ ctxt->scp = &ctxt->cscp;
+ src = Mpval(rsrc);
+ break;
+ case 'a':
+ ctxt->scp = &ctxt->ascp;
+ src = Mvkpnum(ctxt, Mpval(rsrc), Mpval(csrc));
+ break;
+ default:
+ BI_BlacsErr(Mpval(ConTxt), __LINE__, __FILE__, "Unknown scope '%c'",
+ tscope);
+ }
+
+ MatTyp = BI_GetMpiGeType(ctxt, Mpval(m), Mpval(n), tlda,
+ MPI_INT, &BI_AuxBuff.N);
+/*
+ * If using default topology, use MPI native broadcast
+ */
+ if (ttop == ' ')
+ {
+ error=MPI_Bcast(A, BI_AuxBuff.N, MatTyp, src, ctxt->scp->comm);
+ error=BI_MPI_TYPE_FREE(&MatTyp);
+ if (BI_ActiveQ) BI_UpdateBuffs(NULL);
+ return;
+ }
+/*
+ * If MPI handles non-contiguous buffering well, always use MPI data types
+ * instead of packing
+ */
+#ifndef MpiBuffGood
+/*
+ * If A is contiguous, receive and send directly to/from it
+ */
+ else if ( (tlda == Mpval(m)) || (Mpval(n) == 1) )
+ {
+#endif
+ send = BI_Ssend;
+ BI_AuxBuff.Buff = (char *) A;
+ BI_AuxBuff.dtype = MatTyp;
+ bp = &BI_AuxBuff;
+#ifndef MpiBuffGood
+ }
+/*
+ * If A is not contiguous, we receive message as packed so it can be
+ * forwarded without further system intervention
+ */
+ else
+ {
+ send = BI_Asend;
+ MPI_Pack_size(one, MatTyp, ctxt->scp->comm, &length, error);
+ bp = BI_GetBuff(length);
+ bp->N = length;
+ bp->dtype = MPI_PACKED;
+#if ZeroByteTypeBug
+ if (MatTyp == MPI_BYTE)
+ {
+ send = BI_Ssend;
+ bp->N = 0;
+ bp->dtype = MPI_BYTE;
+ }
+#endif
+ }
+#endif
+
+ switch(ttop)
+ {
+ case 'h':
+ error = BI_HypBR(ctxt, bp, send, src);
+ if (error == NPOW2) BI_TreeBR(ctxt, bp, send, src, 2);
+ break;
+ case '1':
+ case '2':
+ case '3':
+ case '4':
+ case '5':
+ case '6':
+ case '7':
+ case '8':
+ case '9':
+ BI_TreeBR(ctxt, bp, send, src, ttop-47);
+ break;
+ case 't':
+ BI_TreeBR(ctxt, bp, send, src, ctxt->Nb_bs);
+ break;
+ case 'i':
+ BI_IdringBR(ctxt, bp, send, src, 1);
+ break;
+ case 'd':
+ BI_IdringBR(ctxt, bp, send, src, -1);
+ break;
+ case 's':
+ BI_SringBR(ctxt, bp, send, src);
+ break;
+ case 'm':
+ BI_MpathBR(ctxt, bp, send, src, ctxt->Nr_bs);
+ break;
+ case 'f':
+ BI_MpathBR(ctxt, bp, send, src, FULLCON);
+ break;
+ default :
+ BI_BlacsErr(Mpval(ConTxt), __LINE__, __FILE__, "Unknown topology '%c'",
+ ttop);
+ }
+
+/*
+ * If we buffered, unpack.
+ */
+#ifndef MpiBuffGood
+ if (bp != &BI_AuxBuff)
+ {
+ BI_Unpack(ctxt, (BVOID *) A, bp, MatTyp);
+ BI_UpdateBuffs(bp);
+ }
+ else
+#endif
+ {
+ error=BI_MPI_TYPE_FREE(&MatTyp);
+ if (BI_ActiveQ) BI_UpdateBuffs(NULL);
+ }
+}
diff --git a/BLACS/SRC/igebs2d_.c b/BLACS/SRC/igebs2d_.c
new file mode 100644
index 0000000..82310dd
--- /dev/null
+++ b/BLACS/SRC/igebs2d_.c
@@ -0,0 +1,194 @@
+#include "Bdef.h"
+
+#if (INTFACE == C_CALL)
+void Cigebs2d(int ConTxt, char *scope, char *top, int m, int n, int *A, int lda)
+#else
+F_VOID_FUNC igebs2d_(int *ConTxt, F_CHAR scope, F_CHAR top, int *m, int *n,
+ int *A, int *lda)
+#endif
+/*
+ * -- V1.1 BLACS routine --
+ * University of Tennessee, May 1, 1996
+ * Written by Clint Whaley.
+ *
+ * Purpose
+ * =======
+ * Broadcast/send for general integer arrays.
+ *
+ * Arguments
+ * =========
+ *
+ * ConTxt (input) Ptr to int
+ * Index into MyConTxts00 (my contexts array).
+ *
+ * SCOPE (input) Ptr to char
+ * Limit the scope of the operation.
+ * = 'R' : Operation is performed by a process row.
+ * = 'C' : Operation is performed by a process column.
+ * = 'A' : Operation is performed by all processes in grid.
+ *
+ * TOP (input) Ptr to char
+ * Controls fashion in which messages flow within the operation.
+ *
+ * M (input) Ptr to int
+ * The number of rows of the matrix A. M >= 0.
+ *
+ * N (input) Ptr to int
+ * The number of columns of the matrix A. N >= 0.
+ *
+ * A (input) Ptr to integer two dimensional array
+ * The m by n matrix A. Fortran77 (column-major) storage
+ * assumed.
+ *
+ * LDA (input) Ptr to int
+ * The leading dimension of the array A. LDA >= M.
+ *
+ * ------------------------------------------------------------------------
+ */
+{
+ void BI_ArgCheck(int, int, char *, char, char, char, int, int, int, int,
+ int *, int *);
+ int BI_HypBS(BLACSCONTEXT *, BLACBUFF *, SDRVPTR);
+ void BI_IdringBS(BLACSCONTEXT *, BLACBUFF *, SDRVPTR, int);
+ void BI_SringBS(BLACSCONTEXT *, BLACBUFF *, SDRVPTR);
+ void BI_MpathBS(BLACSCONTEXT *, BLACBUFF *, SDRVPTR, int);
+ void BI_TreeBS(BLACSCONTEXT *, BLACBUFF *, SDRVPTR, int);
+ void BI_UpdateBuffs(BLACBUFF *);
+ BLACBUFF *BI_GetBuff(int);
+ int BI_BuffIsFree(BLACBUFF *, int);
+ MPI_Datatype BI_GetMpiGeType(BLACSCONTEXT *, int, int, int,
+ MPI_Datatype, int *);
+ BLACBUFF *BI_Pack(BLACSCONTEXT *, BVOID *, BLACBUFF *, MPI_Datatype);
+ void BI_Ssend(BLACSCONTEXT *, int, int, BLACBUFF *);
+ void BI_Asend(BLACSCONTEXT *, int, int, BLACBUFF *);
+
+ char ttop, tscope;
+ int error, tlda;
+ MPI_Datatype MatTyp;
+ SDRVPTR send;
+ BLACBUFF *bp;
+ BLACSCONTEXT *ctxt;
+ extern BLACBUFF BI_AuxBuff, *BI_ActiveQ;
+/*
+ * get context, lowcase char variables, and perform parameter checking
+ */
+ MGetConTxt(Mpval(ConTxt), ctxt);
+ ttop = F2C_CharTrans(top);
+ ttop = Mlowcase(ttop);
+ tscope = F2C_CharTrans(scope);
+ tscope = Mlowcase(tscope);
+#if (BlacsDebugLvl > 0)
+ BI_ArgCheck(Mpval(ConTxt), RT_BS, __FILE__, 'a', 'u', 'u', Mpval(m),
+ Mpval(n), Mpval(lda), 0, NULL, NULL);
+#endif
+/*
+ * If the user has set the default broadcast topology, use it instead of
+ * BLACS default
+ */
+#ifdef DefBSTop
+ if (ttop == ' ') ttop = DefBSTop;
+#endif
+ if (Mpval(lda) < Mpval(m)) tlda = Mpval(m);
+ else tlda = Mpval(lda);
+
+ switch(tscope)
+ {
+ case 'r':
+ ctxt->scp = &ctxt->rscp;
+ break;
+ case 'c':
+ ctxt->scp = &ctxt->cscp;
+ break;
+ case 'a':
+ ctxt->scp = &ctxt->ascp;
+ break;
+ default:
+ BI_BlacsErr(Mpval(ConTxt), __LINE__, __FILE__, "Unknown scope '%c'",
+ tscope);
+ }
+
+ MatTyp = BI_GetMpiGeType(ctxt, Mpval(m), Mpval(n), tlda,
+ MPI_INT, &BI_AuxBuff.N);
+/*
+ * If using default topology, use MPI native broadcast
+ */
+ if (ttop == ' ')
+ {
+ error=MPI_Bcast(A, BI_AuxBuff.N, MatTyp, ctxt->scp->Iam, ctxt->scp->comm);
+ error=BI_MPI_TYPE_FREE(&MatTyp);
+ if (BI_ActiveQ) BI_UpdateBuffs(NULL);
+ return;
+ }
+/*
+ * If MPI handles non-contiguous buffering well, always use MPI data types
+ * instead of packing
+ */
+#ifndef MpiBuffGood
+/*
+ * If A is contiguous, send directly from it
+ */
+ else if ( (tlda == Mpval(m)) || (Mpval(n) == 1) )
+ {
+#endif
+ send = BI_Ssend;
+ BI_AuxBuff.Buff = (char *) A;
+ BI_AuxBuff.dtype = MatTyp;
+ bp = &BI_AuxBuff;
+#ifndef MpiBuffGood
+ }
+ else
+ {
+ send = BI_Asend;
+ bp = BI_Pack(ctxt, (BVOID *) A, NULL, MatTyp);
+ }
+#endif
+
+/*
+ * Call correct topology for BS/BR
+ */
+ switch(ttop)
+ {
+ case 'h':
+ error = BI_HypBS(ctxt, bp, send);
+ if (error == NPOW2) BI_TreeBS(ctxt, bp, send, 2);
+ break;
+ case '1':
+ case '2':
+ case '3':
+ case '4':
+ case '5':
+ case '6':
+ case '7':
+ case '8':
+ case '9':
+ BI_TreeBS(ctxt, bp, send, ttop-47);
+ break;
+ case 't':
+ BI_TreeBS(ctxt, bp, send, ctxt->Nb_bs);
+ break;
+ case 'i':
+ BI_IdringBS(ctxt, bp, send, 1);
+ break;
+ case 'd':
+ BI_IdringBS(ctxt, bp, send, -1);
+ break;
+ case 's':
+ BI_SringBS(ctxt, bp, send);
+ break;
+ case 'f':
+ BI_MpathBS(ctxt, bp, send, FULLCON);
+ break;
+ case 'm':
+ BI_MpathBS(ctxt, bp, send, ctxt->Nr_bs);
+ break;
+ default :
+ BI_BlacsErr(Mpval(ConTxt), __LINE__, __FILE__, "Unknown topology '%c'",ttop);
+ }
+
+ error=BI_MPI_TYPE_FREE(&MatTyp);
+ if (bp == &BI_AuxBuff)
+ {
+ if (BI_ActiveQ) BI_UpdateBuffs(NULL);
+ }
+ else BI_UpdateBuffs(bp);
+} /* end igebs2d_ */
diff --git a/BLACS/SRC/igerv2d_.c b/BLACS/SRC/igerv2d_.c
new file mode 100644
index 0000000..1af3bee
--- /dev/null
+++ b/BLACS/SRC/igerv2d_.c
@@ -0,0 +1,82 @@
+#include "Bdef.h"
+
+#if (INTFACE == C_CALL)
+void Cigerv2d(int ConTxt, int m, int n, int *A, int lda, int rsrc, int csrc)
+#else
+F_VOID_FUNC igerv2d_(int *ConTxt, int *m, int *n, int *A, int *lda,
+ int *rsrc, int *csrc)
+#endif
+/*
+ * -- V1.1 BLACS routine --
+ * University of Tennessee, May 1, 1996
+ * Written by Clint Whaley.
+ *
+ * Purpose
+ * =======
+ * Globally-blocking point to point general integer receive.
+ *
+ * Arguments
+ * =========
+ *
+ * ConTxt (input) Ptr to int
+ * Index into MyConTxts00 (my contexts array).
+ *
+ * M (input) Ptr to int
+ * The number of rows of the matrix A. M >= 0.
+ *
+ * N (input) Ptr to int
+ * The number of columns of the matrix A. N >= 0.
+ *
+ * A (output) Ptr to integer two dimensional array
+ * The m by n matrix A. Fortran77 (column-major) storage
+ * assumed.
+ *
+ * LDA (input) Ptr to int
+ * The leading dimension of the array A. LDA >= M.
+ *
+ *
+ * RSRC (input) Ptr to int
+ * The process row of the source of the matrix.
+ *
+ * CSRC (input) Ptr to int
+ * The process column of the source of the matrix.
+ *
+ *
+ * ------------------------------------------------------------------------
+ */
+{
+/*
+ * Prototypes and variable declarations
+ */
+ void BI_ArgCheck(int, int, char *, char, char, char, int, int, int, int,
+ int *, int *);
+ MPI_Datatype BI_GetMpiGeType(BLACSCONTEXT *, int, int, int,
+ MPI_Datatype, int *);
+ void BI_Unpack(BLACSCONTEXT *, BVOID *, BLACBUFF *, MPI_Datatype);
+ void BI_Srecv(BLACSCONTEXT *, int, int, BLACBUFF *);
+ void BI_UpdateBuffs(BLACBUFF *);
+ BLACBUFF *BI_GetBuff(int);
+ int BI_BuffIsFree(BLACBUFF *, int);
+ int tlda;
+ int ierr;
+ MPI_Datatype MatTyp;
+ BLACSCONTEXT *ctxt;
+ extern BLACBUFF BI_AuxBuff, *BI_ActiveQ;
+
+ MGetConTxt(Mpval(ConTxt), ctxt);
+#if (BlacsDebugLvl > 0)
+ BI_ArgCheck(Mpval(ConTxt), RT_RV, __FILE__, 'a', 'u', 'u', Mpval(m),
+ Mpval(n), Mpval(lda), 1, Mpaddress(rsrc), Mpaddress(csrc));
+#endif
+ if (Mpval(lda) < Mpval(m)) tlda = Mpval(m);
+ else tlda = Mpval(lda);
+ ctxt->scp = &ctxt->pscp;
+
+ MatTyp = BI_GetMpiGeType(ctxt, Mpval(m), Mpval(n), tlda,
+ MPI_INT, &BI_AuxBuff.N);
+ BI_AuxBuff.Buff = (char *) A;
+ BI_AuxBuff.dtype = MatTyp;
+ BI_Srecv(ctxt, Mkpnum(ctxt, Mpval(rsrc), Mpval(csrc)), PT2PTID, &BI_AuxBuff);
+ ierr=BI_MPI_TYPE_FREE(&MatTyp);
+ if (BI_ActiveQ) BI_UpdateBuffs(NULL);
+}
diff --git a/BLACS/SRC/igesd2d_.c b/BLACS/SRC/igesd2d_.c
new file mode 100644
index 0000000..b8e1929
--- /dev/null
+++ b/BLACS/SRC/igesd2d_.c
@@ -0,0 +1,95 @@
+#include "Bdef.h"
+
+#if (INTFACE == C_CALL)
+void Cigesd2d(int ConTxt, int m, int n, int *A, int lda,
+ int rdest, int cdest)
+#else
+F_VOID_FUNC igesd2d_(int *ConTxt, int *m, int *n, int *A, int *lda,
+ int *rdest, int *cdest)
+#endif
+/*
+ * -- V1.1 BLACS routine --
+ * University of Tennessee, May 1, 1996
+ * Written by Clint Whaley.
+ *
+ * Purpose
+ * =======
+ * Locally-blocking point-to-point general integer send.
+ *
+ * Arguments
+ * =========
+ *
+ * ConTxt (input) Ptr to int
+ * Index into MyConTxts00 (my contexts array).
+ *
+ * M (input) Ptr to int
+ * The number of rows of the matrix A. M >= 0.
+ *
+ * N (input) Ptr to int
+ * The number of columns of the matrix A. N >= 0.
+ *
+ * A (input) Ptr to integer two dimensional array
+ * The m by n matrix A. Fortran77 (column-major) storage
+ * assumed.
+ *
+ * LDA (input) Ptr to int
+ * The leading dimension of the array A. LDA >= M.
+ *
+ * RDEST (input) Ptr to int
+ * The process row of the destination process.
+ *
+ * CDEST (input) Ptr to int
+ * The process column of the destination process.
+ *
+ * ------------------------------------------------------------------------
+ */
+{
+ void BI_ArgCheck(int, int, char *, char, char, char, int, int, int, int,
+ int *, int *);
+ MPI_Datatype BI_GetMpiGeType(BLACSCONTEXT *, int, int, int,
+ MPI_Datatype, int *);
+ BLACBUFF *BI_Pack(BLACSCONTEXT *, BVOID *, BLACBUFF *, MPI_Datatype);
+ void BI_Ssend(BLACSCONTEXT *, int, int, BLACBUFF *);
+ void BI_Asend(BLACSCONTEXT *, int, int, BLACBUFF *);
+ void BI_UpdateBuffs(BLACBUFF *);
+ BLACBUFF *BI_GetBuff(int);
+ int BI_BuffIsFree(BLACBUFF *, int);
+
+ int dest, tlda, ierr;
+ BLACBUFF *bp;
+ BLACSCONTEXT *ctxt;
+ MPI_Datatype MatTyp;
+ extern BLACBUFF BI_AuxBuff, *BI_ActiveQ;
+
+ MGetConTxt(Mpval(ConTxt), ctxt);
+#if (BlacsDebugLvl > 0)
+ BI_ArgCheck(Mpval(ConTxt), RT_SD, "IGESD2D", 'a', 'u', 'u', Mpval(m),
+ Mpval(n), Mpval(lda), 1, Mpaddress(rdest), Mpaddress(cdest));
+#endif
+ if (Mpval(lda) < Mpval(m)) tlda = Mpval(m);
+ else tlda = Mpval(lda);
+ dest = Mvkpnum(ctxt, Mpval(rdest), Mpval(cdest));
+ ctxt->scp = &ctxt->pscp;
+
+ MatTyp = BI_GetMpiGeType(ctxt, Mpval(m), Mpval(n), tlda,
+ MPI_INT, &BI_AuxBuff.N);
+#ifdef SndIsLocBlk
+ BI_AuxBuff.Buff = (char *) A;
+ BI_AuxBuff.dtype = MatTyp;
+ BI_Ssend(ctxt, dest, PT2PTID, &BI_AuxBuff);
+#else
+ bp = BI_Pack(ctxt, (BVOID *) A, NULL, MatTyp);
+ BI_Asend(ctxt, Mkpnum(ctxt, Mpval(rdest), Mpval(cdest)), PT2PTID, bp);
+#endif
+ ierr=BI_MPI_TYPE_FREE(&MatTyp);
+
+/*
+ * Having started the async send, update the buffers (reform links, check if
+ * active buffers have become inactive, etc.)
+ */
+#ifdef SndIsLocBlk
+ if (BI_ActiveQ) BI_UpdateBuffs(NULL);
+#else
+ BI_UpdateBuffs(bp);
+#endif
+} /* end of igesd2d */
diff --git a/BLACS/SRC/igsum2d_.c b/BLACS/SRC/igsum2d_.c
new file mode 100644
index 0000000..458abd4
--- /dev/null
+++ b/BLACS/SRC/igsum2d_.c
@@ -0,0 +1,234 @@
+#include "Bdef.h"
+
+
+#if (INTFACE == C_CALL)
+void Cigsum2d(int ConTxt, char *scope, char *top, int m, int n, int *A,
+ int lda, int rdest, int cdest)
+#else
+F_VOID_FUNC igsum2d_(int *ConTxt, F_CHAR scope, F_CHAR top, int *m, int *n,
+ int *A, int *lda, int *rdest, int *cdest)
+#endif
+/*
+ * -- V1.1 BLACS routine --
+ * University of Tennessee, May 1, 1996
+ * Written by Clint Whaley.
+ *
+ * Purpose
+ * =======
+ * Combine sum operation for integer rectangular matrices.
+ *
+ * Arguments
+ * =========
+ *
+ * ConTxt (input) Ptr to int
+ * Index into MyConTxts00 (my contexts array).
+ *
+ * SCOPE (input) Ptr to char
+ * Limit the scope of the operation.
+ * = 'R' : Operation is performed by a process row.
+ * = 'C' : Operation is performed by a process column.
+ * = 'A' : Operation is performed by all processes in grid.
+ *
+ * TOP (input) Ptr to char
+ * Controls fashion in which messages flow within the operation.
+ *
+ * M (input) Ptr to int
+ * The number of rows of the matrix A. M >= 0.
+ *
+ * N (input) Ptr to int
+ * The number of columns of the matrix A. N >= 0.
+ *
+ * A (output) Ptr to integer two dimensional array
+ * The m by n matrix A. Fortran77 (column-major) storage
+ * assumed.
+ *
+ * LDA (input) Ptr to int
+ * The leading dimension of the array A. LDA >= M.
+ *
+ * RDEST (input) Ptr to int
+ * The process row of the destination of the sum.
+ * If rdest == -1, then result is left on all processes in scope.
+ *
+ * CDEST (input) Ptr to int
+ * The process column of the destination of the sum.
+ * If rdest == -1, then CDEST ignored.
+ *
+ * ------------------------------------------------------------------------
+ */
+{
+ void BI_ArgCheck(int, int, char *, char, char, char, int, int, int, int,
+ int *, int *);
+ void BI_UpdateBuffs(BLACBUFF *);
+ BLACBUFF *BI_GetBuff(int);
+ int BI_BuffIsFree(BLACBUFF *, int);
+ MPI_Datatype BI_GetMpiGeType(BLACSCONTEXT *, int, int, int,
+ MPI_Datatype, int *);
+ BLACBUFF *BI_Pack(BLACSCONTEXT *, BVOID *, BLACBUFF *, MPI_Datatype);
+ MPI_Datatype BI_GetMpiGeType(BLACSCONTEXT *, int, int, int,
+ MPI_Datatype, int *);
+ void BI_Unpack(BLACSCONTEXT *, BVOID *, BLACBUFF *, MPI_Datatype);
+ void BI_MringComb(BLACSCONTEXT *, BLACBUFF *, BLACBUFF *, int, VVFUNPTR,
+ int, int);
+ void BI_TreeComb(BLACSCONTEXT *, BLACBUFF *, BLACBUFF *, int, VVFUNPTR,
+ int, int);
+ void BI_BeComb(BLACSCONTEXT *, BLACBUFF *, BLACBUFF *, int, VVFUNPTR);
+ void BI_ivvsum(int, char *, char *);
+/*
+ * Variable Declarations
+ */
+ BLACBUFF *bp, *bp2;
+ BLACSCONTEXT *ctxt;
+ char ttop, tscope;
+ int N, length, dest, tlda, trdest, ierr, itr;
+ extern BLACBUFF *BI_ActiveQ;
+ extern BLACBUFF BI_AuxBuff;
+
+ MGetConTxt(Mpval(ConTxt), ctxt);
+ ttop = F2C_CharTrans(top);
+ ttop = Mlowcase(ttop);
+ tscope = F2C_CharTrans(scope);
+ tscope = Mlowcase(tscope);
+/*
+ * If the user has set the default combine topology, use it instead of
+ * BLACS default
+ */
+#ifdef DefCombTop
+ if (ttop == ' ') ttop = DefCombTop;
+#endif
+ if (Mpval(cdest) == -1) trdest = -1;
+ else trdest = Mpval(rdest);
+#if (BlacsDebugLvl > 0)
+ BI_ArgCheck(Mpval(ConTxt), RT_COMB, __FILE__, tscope, 'u', 'u', Mpval(m),
+ Mpval(n), Mpval(lda), 1, &trdest, Mpaddress(cdest));
+#endif
+ if (Mpval(lda) >= Mpval(m)) tlda = Mpval(lda);
+ else tlda = Mpval(m);
+ switch(tscope)
+ {
+ case 'r':
+ ctxt->scp = &ctxt->rscp;
+ if (trdest == -1) dest = -1;
+ else dest = Mpval(cdest);
+ break;
+ case 'c':
+ ctxt->scp = &ctxt->cscp;
+ dest = trdest;
+ break;
+ case 'a':
+ ctxt->scp = &ctxt->ascp;
+ if (trdest == -1) dest = -1;
+ else dest = Mvkpnum(ctxt, trdest, Mpval(cdest));
+ break;
+ default:
+ BI_BlacsErr(Mpval(ConTxt), __LINE__, __FILE__, "Unknown scope '%c'",
+ tscope);
+ }
+
+
+/*
+ * It's not defined how MPI reacts to 0 element reductions, so use BLACS 1-tree
+ * topology if we've got one. Note that integer operations are always
+ * repeatable.
+ */
+ if (ttop == ' ') if ( (Mpval(m) < 1) || (Mpval(n) < 1) ) ttop = '1';
+ N = Mpval(m) * Mpval(n);
+ length = N * sizeof(int);
+/*
+ * If A is contiguous, we can use it as one of the buffers
+ */
+ if ( (Mpval(m) == tlda) || (Mpval(n) == 1) )
+ {
+ bp = &BI_AuxBuff;
+ bp->Buff = (char *) A;
+ bp2 = BI_GetBuff(length);
+ }
+/*
+ * Otherwise, we must allocate both buffers
+ */
+ else
+ {
+ bp = BI_GetBuff(length*2);
+ bp2 = &BI_AuxBuff;
+ bp2->Buff = &bp->Buff[length];
+ BI_imvcopy(Mpval(m), Mpval(n), A, tlda, bp->Buff);
+ }
+ bp->dtype = bp2->dtype = MPI_INT;
+ bp->N = bp2->N = N;
+
+ switch(ttop)
+ {
+ case ' ': /* use MPI's reduction by default */
+ if (dest != -1)
+ {
+ ierr=MPI_Reduce(bp->Buff, bp2->Buff, bp->N, bp->dtype, MPI_SUM,
+ dest, ctxt->scp->comm);
+ if (ctxt->scp->Iam == dest)
+ BI_ivmcopy(Mpval(m), Mpval(n), A, tlda, bp2->Buff);
+ }
+ else
+ {
+ ierr=MPI_Allreduce(bp->Buff, bp2->Buff, bp->N, bp->dtype, MPI_SUM,
+ ctxt->scp->comm);
+ BI_ivmcopy(Mpval(m), Mpval(n), A, tlda, bp2->Buff);
+ }
+ if (BI_ActiveQ) BI_UpdateBuffs(NULL);
+ return;
+ break;
+ case 'i':
+ BI_MringComb(ctxt, bp, bp2, N, BI_ivvsum, dest, 1);
+ break;
+ case 'd':
+ BI_MringComb(ctxt, bp, bp2, N, BI_ivvsum, dest, -1);
+ break;
+ case 's':
+ BI_MringComb(ctxt, bp, bp2, N, BI_ivvsum, dest, 2);
+ break;
+ case 'm':
+ BI_MringComb(ctxt, bp, bp2, N, BI_ivvsum, dest, ctxt->Nr_co);
+ break;
+ case '1':
+ case '2':
+ case '3':
+ case '4':
+ case '5':
+ case '6':
+ case '7':
+ case '8':
+ case '9':
+ BI_TreeComb(ctxt, bp, bp2, N, BI_ivvsum, dest, ttop-47);
+ break;
+ case 'f':
+ BI_TreeComb(ctxt, bp, bp2, N, BI_ivvsum, dest, FULLCON);
+ break;
+ case 't':
+ BI_TreeComb(ctxt, bp, bp2, N, BI_ivvsum, dest, ctxt->Nb_co);
+ break;
+ case 'h':
+/*
+ * Use bidirectional exchange if everyone wants answer
+ */
+ if ( (trdest == -1) && !(ctxt->TopsCohrnt) )
+ BI_BeComb(ctxt, bp, bp2, N, BI_ivvsum);
+ else
+ BI_TreeComb(ctxt, bp, bp2, N, BI_ivvsum, dest, 2);
+ break;
+ default :
+ BI_BlacsErr(Mpval(ConTxt), __LINE__, __FILE__, "Unknown topology '%c'",
+ ttop);
+ }
+
+/*
+ * If I am selected to receive answer
+ */
+ if (bp != &BI_AuxBuff)
+ {
+ if ( (ctxt->scp->Iam == dest) || (dest == -1) )
+ BI_ivmcopy(Mpval(m), Mpval(n), A, tlda, bp->Buff);
+ BI_UpdateBuffs(bp);
+ }
+ else
+ {
+ if (BI_ActiveQ) BI_UpdateBuffs(NULL);
+ BI_BuffIsFree(bp, 1);
+ }
+}
diff --git a/BLACS/SRC/itrbr2d_.c b/BLACS/SRC/itrbr2d_.c
new file mode 100644
index 0000000..8a4d9df
--- /dev/null
+++ b/BLACS/SRC/itrbr2d_.c
@@ -0,0 +1,224 @@
+#include "Bdef.h"
+
+#if (INTFACE == C_CALL)
+void Citrbr2d(int ConTxt, char *scope, char *top, char *uplo, char *diag,
+ int m, int n, int *A, int lda, int rsrc, int csrc)
+#else
+F_VOID_FUNC itrbr2d_(int *ConTxt, F_CHAR scope, F_CHAR top, F_CHAR uplo,
+ F_CHAR diag, int *m, int *n, int *A, int *lda,
+ int *rsrc, int *csrc)
+#endif
+/*
+ * -- V1.1 BLACS routine --
+ * University of Tennessee, May 1, 1996
+ * Written by Clint Whaley.
+ *
+ * Purpose
+ * =======
+ * Broadcast/receive for trapezoidal integer arrays.
+ *
+ * Arguments
+ * =========
+ *
+ * ConTxt (input) Ptr to int
+ * Index into MyConTxts00 (my contexts array).
+ *
+ * SCOPE (input) Ptr to char
+ * Limit the scope of the operation.
+ * = 'R' : Operation is performed by a process row.
+ * = 'C' : Operation is performed by a process column.
+ * = 'A' : Operation is performed by all processes in grid.
+ *
+ * TOP (input) Ptr to char
+ * Controls fashion in which messages flow within the operation.
+ *
+ * UPLO (input) Ptr to char
+ * Specifies the part of the matrix to be sent.
+ * = 'U': Upper trapezoidal part
+ * ELSE : Lower trapezoidal part
+ *
+ * DIAG (input) Ptr to char
+ * Specifies whether the matrix is unit diagonal or not.
+ * = 'U': Matrix is unit diagonal, diagonal not communicated.
+ * ELSE : Matrix is not unit diagonal, diagonal is communicated.
+ *
+ * M (input) Ptr to int
+ * The number of rows of the matrix A. M >= 0.
+ *
+ * N (input) Ptr to int
+ * The number of columns of the matrix A. N >= 0.
+ *
+ * A (output) Ptr to integer two dimensional array
+ * The m by n matrix A. Fortran77 (column-major) storage
+ * assumed.
+ * If UPLO = 'U', only the upper trapezoid is accessed;
+ * if UPLO = 'L', only the lower trapezoid is accessed.
+ *
+ * LDA (input) Ptr to int
+ * The leading dimension of the array A. LDA >= M.
+ *
+ *
+ * RSRC (input) Ptr to int
+ * The process row of the source of the matrix.
+ *
+ * CSRC (input) Ptr to int
+ * The process column of the source of the matrix.
+ *
+ *
+ * ------------------------------------------------------------------------
+ */
+{
+ void BI_ArgCheck(int, int, char *, char, char, char, int, int, int, int,
+ int *, int *);
+ int BI_HypBR(BLACSCONTEXT *, BLACBUFF *, SDRVPTR, int);
+ void BI_IdringBR(BLACSCONTEXT *, BLACBUFF *, SDRVPTR, int, int);
+ void BI_SringBR(BLACSCONTEXT *, BLACBUFF *, SDRVPTR, int);
+ void BI_MpathBR(BLACSCONTEXT *, BLACBUFF *, SDRVPTR, int, int);
+ void BI_TreeBR(BLACSCONTEXT *, BLACBUFF *, SDRVPTR, int, int);
+ void BI_UpdateBuffs(BLACBUFF *);
+ BLACBUFF *BI_GetBuff(int);
+ int BI_BuffIsFree(BLACBUFF *, int);
+ MPI_Datatype BI_GetMpiTrType(BLACSCONTEXT *, char, char, int, int, int,
+ MPI_Datatype, int *);
+ void BI_Unpack(BLACSCONTEXT *, BVOID *, BLACBUFF *, MPI_Datatype);
+ void BI_Ssend(BLACSCONTEXT *, int, int, BLACBUFF *);
+ void BI_Asend(BLACSCONTEXT *, int, int, BLACBUFF *);
+
+ BLACSCONTEXT *ctxt;
+ BLACBUFF *bp=NULL;
+ SDRVPTR send;
+ MPI_Datatype MatTyp;
+ int length, src, tlda, error, one=1;
+ char ttop, tscope, tuplo, tdiag;
+ extern BLACBUFF BI_AuxBuff, *BI_ActiveQ;
+
+ MGetConTxt(Mpval(ConTxt), ctxt);
+ ttop = F2C_CharTrans(top);
+ ttop = Mlowcase(ttop);
+ tscope = F2C_CharTrans(scope);
+ tscope = Mlowcase(tscope);
+ tdiag = F2C_CharTrans(diag);
+ tdiag = Mlowcase(tdiag);
+ tuplo = F2C_CharTrans(uplo);
+ tuplo = Mlowcase(tuplo);
+#if (BlacsDebugLvl > 0)
+ BI_ArgCheck(Mpval(ConTxt), RT_BR, __FILE__, tscope, tuplo, tdiag, Mpval(m),
+ Mpval(n), Mpval(lda), 1, Mpaddress(rsrc), Mpaddress(csrc));
+#endif
+/*
+ * If the user has set the default broadcast topology, use it instead of
+ * BLACS default
+ */
+#ifdef DefBSTop
+ if (ttop == ' ') ttop = DefBSTop;
+#endif
+ if (Mpval(m) <= Mpval(lda)) tlda = Mpval(lda);
+ else tlda = Mpval(m);
+
+ switch(tscope)
+ {
+ case 'r':
+ ctxt->scp = &ctxt->rscp;
+ src = Mpval(csrc);
+ break;
+ case 'c':
+ ctxt->scp = &ctxt->cscp;
+ src = Mpval(rsrc);
+ break;
+ case 'a':
+ ctxt->scp = &ctxt->ascp;
+ src = Mvkpnum(ctxt, Mpval(rsrc), Mpval(csrc));
+ break;
+ default:
+ BI_BlacsErr(Mpval(ConTxt), __LINE__, __FILE__, "Unknown scope '%c'",
+ tscope);
+ }
+
+ MatTyp = BI_GetMpiTrType(ctxt, tuplo, tdiag, Mpval(m), Mpval(n), tlda,
+ MPI_INT, &BI_AuxBuff.N);
+/*
+ * If using default topology, use MPI native broadcast
+ */
+ if (ttop == ' ')
+ {
+ error=MPI_Bcast(A, BI_AuxBuff.N, MatTyp, src, ctxt->scp->comm);
+ error=BI_MPI_TYPE_FREE(&MatTyp);
+ if (BI_ActiveQ) BI_UpdateBuffs(NULL);
+ return;
+ }
+/*
+ * If MPI handles non-contiguous buffering well, always use MPI data types
+ * instead of packing
+ */
+#ifdef MpiBuffGood
+ send = BI_Ssend;
+ BI_AuxBuff.Buff = (char *) A;
+ BI_AuxBuff.dtype = MatTyp;
+ bp = &BI_AuxBuff;
+#else
+
+ send = BI_Asend;
+ MPI_Pack_size(one, MatTyp, ctxt->scp->comm, &length, error);
+ bp = BI_GetBuff(length);
+ bp->N = length;
+ bp->dtype = MPI_PACKED;
+#if ZeroByteTypeBug
+ if (MatTyp == MPI_BYTE)
+ {
+ send = BI_Ssend;
+ bp->N = 0;
+ bp->dtype = MPI_BYTE;
+ }
+#endif
+
+#endif
+
+ switch(ttop)
+ {
+ case 'h':
+ error = BI_HypBR(ctxt, bp, send, src);
+ if (error == NPOW2) BI_TreeBR(ctxt, bp, send, src, 2);
+ break;
+ case '1':
+ case '2':
+ case '3':
+ case '4':
+ case '5':
+ case '6':
+ case '7':
+ case '8':
+ case '9':
+ BI_TreeBR(ctxt, bp, send, src, ttop-47);
+ break;
+ case 't':
+ BI_TreeBR(ctxt, bp, send, src, ctxt->Nb_bs);
+ break;
+ case 'i':
+ BI_IdringBR(ctxt, bp, send, src, 1);
+ break;
+ case 'd':
+ BI_IdringBR(ctxt, bp, send, src, -1);
+ break;
+ case 's':
+ BI_SringBR(ctxt, bp, send, src);
+ break;
+ case 'm':
+ BI_MpathBR(ctxt, bp, send, src, ctxt->Nr_bs);
+ break;
+ case 'f':
+ BI_MpathBR(ctxt, bp, send, src, FULLCON);
+ break;
+ default :
+ BI_BlacsErr(Mpval(ConTxt), __LINE__, __FILE__, "Unknown topology '%c'",
+ ttop);
+ }
+
+#ifdef MpiBuffGood
+ error=BI_MPI_TYPE_FREE(&MatTyp);
+ if (BI_ActiveQ) BI_UpdateBuffs(NULL);
+#endif
+#ifndef MpiBuffGood
+ BI_Unpack(ctxt, (BVOID *) A, bp, MatTyp);
+ BI_UpdateBuffs(bp);
+#endif
+}
diff --git a/BLACS/SRC/itrbs2d_.c b/BLACS/SRC/itrbs2d_.c
new file mode 100644
index 0000000..86fa272
--- /dev/null
+++ b/BLACS/SRC/itrbs2d_.c
@@ -0,0 +1,206 @@
+#include "Bdef.h"
+
+#if (INTFACE == C_CALL)
+void Citrbs2d(int ConTxt, char *scope, char *top, char *uplo, char *diag,
+ int m, int n, int *A, int lda)
+#else
+F_VOID_FUNC itrbs2d_(int *ConTxt, F_CHAR scope, F_CHAR top, F_CHAR uplo,
+ F_CHAR diag, int *m, int *n, int *A, int *lda)
+#endif
+/*
+ * -- V1.1 BLACS routine --
+ * University of Tennessee, May 1, 1996
+ * Written by Clint Whaley.
+ *
+ * Purpose
+ * =======
+ * Broadcast/send for trapezoidal integer arrays.
+ *
+ * Arguments
+ * =========
+ *
+ * ConTxt (input) Ptr to int
+ * Index into MyConTxts00 (my contexts array).
+ *
+ * SCOPE (input) Ptr to char
+ * Limit the scope of the operation.
+ * = 'R' : Operation is performed by a process row.
+ * = 'C' : Operation is performed by a process column.
+ * = 'A' : Operation is performed by all processes in grid.
+ *
+ * TOP (input) Ptr to char
+ * Controls fashion in which messages flow within the operation.
+ *
+ * UPLO (input) Ptr to char
+ * Specifies the part of the matrix to be sent.
+ * = 'U': Upper trapezoidal part
+ * ELSE : Lower trapezoidal part
+ *
+ * DIAG (input) Ptr to char
+ * Specifies whether the matrix is unit diagonal or not.
+ * = 'U': Matrix is unit diagonal, diagonal not communicated.
+ * ELSE : Matrix is not unit diagonal, diagonal is communicated.
+ *
+ * M (input) Ptr to int
+ * The number of rows of the matrix A. M >= 0.
+ *
+ * N (input) Ptr to int
+ * The number of columns of the matrix A. N >= 0.
+ *
+ * A (input) Ptr to integer two dimensional array
+ * The m by n matrix A. Fortran77 (column-major) storage
+ * assumed.
+ * If UPLO = 'U', only the upper trapezoid is accessed;
+ * if UPLO = 'L', only the lower trapezoid is accessed.
+ *
+ * LDA (input) Ptr to int
+ * The leading dimension of the array A. LDA >= M.
+ *
+ * ------------------------------------------------------------------------
+ */
+{
+ void BI_ArgCheck(int, int, char *, char, char, char, int, int, int, int,
+ int *, int *);
+ int BI_HypBS(BLACSCONTEXT *, BLACBUFF *, SDRVPTR);
+ void BI_IdringBS(BLACSCONTEXT *, BLACBUFF *, SDRVPTR, int);
+ void BI_SringBS(BLACSCONTEXT *, BLACBUFF *, SDRVPTR);
+ void BI_MpathBS(BLACSCONTEXT *, BLACBUFF *, SDRVPTR, int);
+ void BI_TreeBS(BLACSCONTEXT *, BLACBUFF *, SDRVPTR, int);
+ void BI_UpdateBuffs(BLACBUFF *);
+ BLACBUFF *BI_GetBuff(int);
+ int BI_BuffIsFree(BLACBUFF *, int);
+ MPI_Datatype BI_GetMpiTrType(BLACSCONTEXT *, char, char, int, int, int,
+ MPI_Datatype, int *);
+ BLACBUFF *BI_Pack(BLACSCONTEXT *, BVOID *, BLACBUFF *, MPI_Datatype);
+ void BI_Ssend(BLACSCONTEXT *, int, int, BLACBUFF *);
+ void BI_Asend(BLACSCONTEXT *, int, int, BLACBUFF *);
+
+ char ttop, tscope, tuplo, tdiag;
+ int error, tlda;
+ MPI_Datatype MatTyp;
+ SDRVPTR send;
+ BLACBUFF *bp;
+ BLACSCONTEXT *ctxt;
+ extern BLACBUFF BI_AuxBuff, *BI_ActiveQ;
+/*
+ * get context, lowcase char variables, and perform parameter checking
+ */
+ MGetConTxt(Mpval(ConTxt), ctxt);
+ ttop = F2C_CharTrans(top);
+ ttop = Mlowcase(ttop);
+ tscope = F2C_CharTrans(scope);
+ tscope = Mlowcase(tscope);
+ tuplo = F2C_CharTrans(uplo);
+ tuplo = Mlowcase(tuplo);
+ tdiag = F2C_CharTrans(diag);
+ tdiag = Mlowcase(tdiag);
+#if (BlacsDebugLvl > 0)
+ BI_ArgCheck(Mpval(ConTxt), RT_BS, __FILE__, 'a', tuplo, tdiag, Mpval(m),
+ Mpval(n), Mpval(lda), 0, NULL, NULL);
+#endif
+/*
+ * If the user has set the default broadcast topology, use it instead of
+ * BLACS default
+ */
+#ifdef DefBSTop
+ if (ttop == ' ') ttop = DefBSTop;
+#endif
+ if (Mpval(lda) < Mpval(m)) tlda = Mpval(m);
+ else tlda = Mpval(lda);
+
+ switch(tscope)
+ {
+ case 'r':
+ ctxt->scp = &ctxt->rscp;
+ break;
+ case 'c':
+ ctxt->scp = &ctxt->cscp;
+ break;
+ case 'a':
+ ctxt->scp = &ctxt->ascp;
+ break;
+ default:
+ BI_BlacsErr(Mpval(ConTxt), __LINE__, __FILE__, "Unknown scope '%c'",
+ tscope);
+ }
+ MatTyp = BI_GetMpiTrType(ctxt, tuplo, tdiag, Mpval(m), Mpval(n), tlda,
+ MPI_INT, &BI_AuxBuff.N);
+/*
+ * If using default topology, use MPI native broadcast
+ */
+ if (ttop == ' ')
+ {
+ error=MPI_Bcast(A, BI_AuxBuff.N, MatTyp, ctxt->scp->Iam, ctxt->scp->comm);
+ error=BI_MPI_TYPE_FREE(&MatTyp);
+ if (BI_ActiveQ) BI_UpdateBuffs(NULL);
+ return;
+ }
+/*
+ * If MPI handles non-contiguous buffering well, always use MPI data types
+ * instead of packing
+ */
+#ifdef MpiBuffGood
+ send = BI_Ssend;
+ BI_AuxBuff.Buff = (char *) A;
+ BI_AuxBuff.dtype = MatTyp;
+ bp = &BI_AuxBuff;
+#endif
+/*
+ * Pack and use non-blocking sends for broadcast if MPI's data types aren't
+ * more efficient
+ */
+#ifndef MpiBuffGood
+ send = BI_Asend;
+ bp = BI_Pack(ctxt, (BVOID *) A, NULL, MatTyp);
+#endif
+
+/*
+ * Call correct topology for BS/BR
+ */
+ switch(ttop)
+ {
+ case 'h':
+ error = BI_HypBS(ctxt, bp, send);
+ if (error == NPOW2) BI_TreeBS(ctxt, bp, send, 2);
+ break;
+ case '1':
+ case '2':
+ case '3':
+ case '4':
+ case '5':
+ case '6':
+ case '7':
+ case '8':
+ case '9':
+ BI_TreeBS(ctxt, bp, send, ttop-47);
+ break;
+ case 't':
+ BI_TreeBS(ctxt, bp, send, ctxt->Nb_bs);
+ break;
+ case 'i':
+ BI_IdringBS(ctxt, bp, send, 1);
+ break;
+ case 'd':
+ BI_IdringBS(ctxt, bp, send, -1);
+ break;
+ case 's':
+ BI_SringBS(ctxt, bp, send);
+ break;
+ case 'f':
+ BI_MpathBS(ctxt, bp, send, FULLCON);
+ break;
+ case 'm':
+ BI_MpathBS(ctxt, bp, send, ctxt->Nr_bs);
+ break;
+ default :
+ BI_BlacsErr(Mpval(ConTxt), __LINE__, __FILE__, "Unknown topology '%c'",
+ ttop);
+ }
+
+ error=BI_MPI_TYPE_FREE(&MatTyp);
+ if (bp == &BI_AuxBuff)
+ {
+ if (BI_ActiveQ) BI_UpdateBuffs(NULL);
+ }
+ else BI_UpdateBuffs(bp);
+} /* end itrbs2d_ */
diff --git a/BLACS/SRC/itrrv2d_.c b/BLACS/SRC/itrrv2d_.c
new file mode 100644
index 0000000..6c1f725
--- /dev/null
+++ b/BLACS/SRC/itrrv2d_.c
@@ -0,0 +1,101 @@
+#include "Bdef.h"
+
+#if (INTFACE == C_CALL)
+void Citrrv2d(int ConTxt, char *uplo, char *diag, int m, int n, int *A,
+ int lda, int rsrc, int csrc)
+#else
+F_VOID_FUNC itrrv2d_(int *ConTxt, F_CHAR uplo, F_CHAR diag, int *m, int *n,
+ int *A, int *lda, int *rsrc, int *csrc)
+#endif
+/*
+ * -- V1.1 BLACS routine --
+ * University of Tennessee, May 1, 1996
+ * Written by Clint Whaley.
+ *
+ * Purpose
+ * =======
+ * Globally-blocking point to point trapezoidal integer receive.
+ *
+ * Arguments
+ * =========
+ *
+ * ConTxt (input) Ptr to int
+ * Index into MyConTxts00 (my contexts array).
+ *
+ * UPLO (input) Ptr to char
+ * Specifies the part of the matrix to be sent.
+ * = 'U': Upper trapezoidal part
+ * ELSE : Lower trapezoidal part
+ *
+ * DIAG (input) Ptr to char
+ * Specifies whether the matrix is unit diagonal or not.
+ * = 'U': Matrix is unit diagonal, diagonal not communicated.
+ * ELSE : Matrix is not unit diagonal, diagonal is communicated.
+ *
+ * M (input) Ptr to int
+ * The number of rows of the matrix A. M >= 0.
+ *
+ * N (input) Ptr to int
+ * The number of columns of the matrix A. N >= 0.
+ *
+ * A (output) Ptr to integer two dimensional array
+ * The m by n matrix A. Fortran77 (column-major) storage
+ * assumed.
+ * If UPLO = 'U', only the upper trapezoid is accessed;
+ * if UPLO = 'L', only the lower trapezoid is accessed.
+ *
+ * LDA (input) Ptr to int
+ * The leading dimension of the array A. LDA >= M.
+ *
+ *
+ * RSRC (input) Ptr to int
+ * The process row of the source of the matrix.
+ *
+ * CSRC (input) Ptr to int
+ * The process column of the source of the matrix.
+ *
+ *
+ * ------------------------------------------------------------------------
+ */
+{
+/*
+ * Prototypes and variable declarations
+ */
+ void BI_ArgCheck(int, int, char *, char, char, char, int, int, int, int,
+ int *, int *);
+ MPI_Datatype BI_GetMpiTrType(BLACSCONTEXT *, char, char, int, int, int,
+ MPI_Datatype, int *);
+ void BI_Unpack(BLACSCONTEXT *, BVOID *, BLACBUFF *, MPI_Datatype);
+ void BI_Srecv(BLACSCONTEXT *, int, int, BLACBUFF *);
+ void BI_UpdateBuffs(BLACBUFF *);
+ BLACBUFF *BI_GetBuff(int);
+ int BI_BuffIsFree(BLACBUFF *, int);
+ int tuplo, tdiag, tlda;
+ int ierr, length;
+ BLACBUFF *bp;
+ MPI_Datatype MatTyp;
+ BLACSCONTEXT *ctxt;
+ extern BLACBUFF BI_AuxBuff, *BI_ActiveQ;
+
+ MGetConTxt(Mpval(ConTxt), ctxt);
+ tdiag = F2C_CharTrans(diag);
+ tuplo = F2C_CharTrans(uplo);
+ tdiag = Mlowcase(tdiag);
+ tuplo = Mlowcase(tuplo);
+
+#if (BlacsDebugLvl > 0)
+ BI_ArgCheck(Mpval(ConTxt), RT_RV, __FILE__, 'a', tuplo, tdiag, Mpval(m),
+ Mpval(n), Mpval(lda), 1, Mpaddress(rsrc), Mpaddress(csrc));
+#endif
+ if (Mpval(lda) < Mpval(m)) tlda = Mpval(m);
+ else tlda = Mpval(lda);
+ ctxt->scp = &ctxt->pscp;
+
+ MatTyp = BI_GetMpiTrType(ctxt, tuplo, tdiag, Mpval(m), Mpval(n), tlda,
+ MPI_INT, &BI_AuxBuff.N);
+ BI_AuxBuff.Buff = (char *) A;
+ BI_AuxBuff.dtype = MatTyp;
+ BI_Srecv(ctxt, Mkpnum(ctxt, Mpval(rsrc), Mpval(csrc)), PT2PTID, &BI_AuxBuff);
+ ierr=BI_MPI_TYPE_FREE(&MatTyp);
+ if (BI_ActiveQ) BI_UpdateBuffs(NULL);
+}
diff --git a/BLACS/SRC/itrsd2d_.c b/BLACS/SRC/itrsd2d_.c
new file mode 100644
index 0000000..3d5aa4d
--- /dev/null
+++ b/BLACS/SRC/itrsd2d_.c
@@ -0,0 +1,113 @@
+#include "Bdef.h"
+
+#if (INTFACE == C_CALL)
+void Citrsd2d(int ConTxt, char *uplo, char *diag, int m, int n, int *A,
+ int lda, int rdest, int cdest)
+#else
+F_VOID_FUNC itrsd2d_(int *ConTxt, F_CHAR uplo, F_CHAR diag, int *m, int *n,
+ int *A, int *lda, int *rdest, int *cdest)
+#endif
+/*
+ * -- V1.1 BLACS routine --
+ * University of Tennessee, May 1, 1996
+ * Written by Clint Whaley.
+ *
+ * Purpose
+ * =======
+ * Locally-blocking point-to-point trapezoidal integer send.
+ *
+ * Arguments
+ * =========
+ *
+ * ConTxt (input) Ptr to int
+ * Index into MyConTxts00 (my contexts array).
+ *
+ * UPLO (input) Ptr to char
+ * Specifies the part of the matrix to be sent.
+ * = 'U': Upper trapezoidal part
+ * ELSE : Lower trapezoidal part
+ *
+ * DIAG (input) Ptr to char
+ * Specifies whether the matrix is unit diagonal or not.
+ * = 'U': Matrix is unit diagonal, diagonal not communicated.
+ * ELSE : Matrix is not unit diagonal, diagonal is communicated.
+ *
+ * M (input) Ptr to int
+ * The number of rows of the matrix A. M >= 0.
+ *
+ * N (input) Ptr to int
+ * The number of columns of the matrix A. N >= 0.
+ *
+ * A (input) Ptr to integer two dimensional array
+ * The m by n matrix A. Fortran77 (column-major) storage
+ * assumed.
+ * If UPLO = 'U', only the upper trapezoid is accessed;
+ * if UPLO = 'L', only the lower trapezoid is accessed.
+ *
+ * LDA (input) Ptr to int
+ * The leading dimension of the array A. LDA >= M.
+ *
+ * RDEST (input) Ptr to int
+ * The process row of the destination process.
+ *
+ * CDEST (input) Ptr to int
+ * The process column of the destination process.
+ *
+ * ------------------------------------------------------------------------
+ */
+{
+ void BI_ArgCheck(int, int, char *, char, char, char, int, int, int, int,
+ int *, int *);
+ MPI_Datatype BI_GetMpiTrType(BLACSCONTEXT *, char, char, int, int, int,
+ MPI_Datatype, int *);
+ BLACBUFF *BI_Pack(BLACSCONTEXT *, BVOID *, BLACBUFF *, MPI_Datatype);
+ void BI_Ssend(BLACSCONTEXT *, int, int, BLACBUFF *);
+ void BI_Asend(BLACSCONTEXT *, int, int, BLACBUFF *);
+ void BI_UpdateBuffs(BLACBUFF *);
+ BLACBUFF *BI_GetBuff(int);
+ int BI_BuffIsFree(BLACBUFF *, int);
+
+ char tuplo, tdiag;
+ int dest, length, tlda, ierr;
+ BLACBUFF *bp;
+ BLACSCONTEXT *ctxt;
+ MPI_Datatype MatTyp;
+ extern BLACBUFF BI_AuxBuff, *BI_ActiveQ;
+
+ MGetConTxt(Mpval(ConTxt), ctxt);
+ tuplo = F2C_CharTrans(uplo);
+ tdiag = F2C_CharTrans(diag);
+ tuplo = Mlowcase(tuplo);
+ tdiag = Mlowcase(tdiag);
+
+#if (BlacsDebugLvl > 0)
+ BI_ArgCheck(Mpval(ConTxt), RT_SD, "ITRSD2D", 'a', tuplo, tdiag, Mpval(m),
+ Mpval(n), Mpval(lda), 1, Mpaddress(rdest), Mpaddress(cdest));
+#endif
+ if (Mpval(lda) < Mpval(m)) tlda = Mpval(m);
+ else tlda = Mpval(lda);
+ dest = Mvkpnum(ctxt, Mpval(rdest), Mpval(cdest));
+ ctxt->scp = &ctxt->pscp;
+
+ MatTyp = BI_GetMpiTrType(ctxt, tuplo, tdiag, Mpval(m), Mpval(n), tlda,
+ MPI_INT, &BI_AuxBuff.N);
+#ifdef SndIsLocBlk
+ BI_AuxBuff.Buff = (char *) A;
+ BI_AuxBuff.dtype = MatTyp;
+ BI_Ssend(ctxt, dest, PT2PTID, &BI_AuxBuff);
+#else
+ bp = BI_Pack(ctxt, (BVOID *) A, NULL, MatTyp);
+ BI_Asend(ctxt, Mkpnum(ctxt, Mpval(rdest), Mpval(cdest)), PT2PTID, bp);
+#endif
+ ierr=BI_MPI_TYPE_FREE(&MatTyp);
+
+/*
+ * Having started the async send, update the buffers (reform links, check if
+ * active buffers have become inactive, etc.)
+ */
+#ifdef SndIsLocBlk
+ if (BI_ActiveQ) BI_UpdateBuffs(NULL);
+#else
+ BI_UpdateBuffs(bp);
+#endif
+} /* end of itrsd2d */
diff --git a/BLACS/SRC/kbrid_.c b/BLACS/SRC/kbrid_.c
new file mode 100644
index 0000000..2305de5
--- /dev/null
+++ b/BLACS/SRC/kbrid_.c
@@ -0,0 +1,29 @@
+#include "Bdef.h"
+
+#if (INTFACE == C_CALL)
+int Ckbrid(int ConTxt, char *scope, int rsrc, int csrc)
+#else
+F_INT_FUNC kbrid_(int *ConTxt, F_CHAR scope, int *rsrc, int *csrc)
+#endif
+{
+ int msgid;
+ char tmpscope;
+ BLACSCONTEXT *ctxt;
+
+ MGetConTxt(Mpval(ConTxt), ctxt);
+ tmpscope = Mlowcase(F2C_CharTrans(scope));
+ switch(tmpscope)
+ {
+ case 'c' :
+ ctxt->scp = &ctxt->cscp;
+ break;
+ case 'r' :
+ ctxt->scp = &ctxt->cscp;
+ break;
+ case 'a' :
+ ctxt->scp = &ctxt->cscp;
+ break;
+ }
+ msgid = Mscopeid(ctxt);
+ return (msgid);
+}
diff --git a/BLACS/SRC/kbsid_.c b/BLACS/SRC/kbsid_.c
new file mode 100644
index 0000000..6f223d2
--- /dev/null
+++ b/BLACS/SRC/kbsid_.c
@@ -0,0 +1,29 @@
+#include "Bdef.h"
+
+#if (INTFACE == C_CALL)
+int Ckbsid(int ConTxt, char *scope)
+#else
+F_INT_FUNC kbsid_(int *ConTxt, F_CHAR scope)
+#endif
+{
+ char tmpscope;
+ int msgid;
+ BLACSCONTEXT *ctxt;
+
+ MGetConTxt(Mpval(ConTxt), ctxt);
+ tmpscope = Mlowcase(F2C_CharTrans(scope));
+ switch(tmpscope)
+ {
+ case 'c' :
+ ctxt->scp = &ctxt->cscp;
+ break;
+ case 'r' :
+ ctxt->scp = &ctxt->rscp;
+ break;
+ case 'a' :
+ ctxt->scp = &ctxt->ascp;
+ break;
+ }
+ msgid = Mscopeid(ctxt);
+ return(msgid);
+}
diff --git a/BLACS/SRC/krecvid_.c b/BLACS/SRC/krecvid_.c
new file mode 100644
index 0000000..c8df47f
--- /dev/null
+++ b/BLACS/SRC/krecvid_.c
@@ -0,0 +1,10 @@
+#include "Bdef.h"
+
+#if (INTFACE == C_CALL)
+int Ckrecvid(int ConTxt, int rsrc, int csrc)
+#else
+F_INT_FUNC krecvid_(int *ConTxt, int *rsrc, int *csrc)
+#endif
+{
+ return(PT2PTID+1);
+} /* end krecvid */
diff --git a/BLACS/SRC/ksendid_.c b/BLACS/SRC/ksendid_.c
new file mode 100644
index 0000000..6c53228
--- /dev/null
+++ b/BLACS/SRC/ksendid_.c
@@ -0,0 +1,10 @@
+#include "Bdef.h"
+
+#if (INTFACE == C_CALL)
+int Cksendid(int ConTxt, int rdest, int cdest)
+#else
+F_INT_FUNC ksendid_(int *ConTxt, int *rdest, int *cdest)
+#endif
+{
+ return(PT2PTID+1);
+} /* end ksendid */
diff --git a/BLACS/SRC/sgamn2d_.c b/BLACS/SRC/sgamn2d_.c
new file mode 100644
index 0000000..d6c95e5
--- /dev/null
+++ b/BLACS/SRC/sgamn2d_.c
@@ -0,0 +1,373 @@
+#include "Bdef.h"
+
+
+
+#if (INTFACE == C_CALL)
+void Csgamn2d(int ConTxt, char *scope, char *top, int m, int n, float *A,
+ int lda, int *rA, int *cA, int ldia, int rdest, int cdest)
+#else
+F_VOID_FUNC sgamn2d_(int *ConTxt, F_CHAR scope, F_CHAR top, int *m, int *n,
+ float *A, int *lda, int *rA, int *cA, int *ldia,
+ int *rdest, int *cdest)
+#endif
+/*
+ * -- V1.1 BLACS routine --
+ * University of Tennessee, May 1, 1996
+ * Written by Clint Whaley.
+ *
+ * Purpose
+ * =======
+ * Combine amn operation for real rectangular matrices.
+ *
+ * Arguments
+ * =========
+ *
+ * ConTxt (input) Ptr to int
+ * Index into MyConTxts00 (my contexts array).
+ *
+ * SCOPE (input) Ptr to char
+ * Limit the scope of the operation.
+ * = 'R' : Operation is performed by a process row.
+ * = 'C' : Operation is performed by a process column.
+ * = 'A' : Operation is performed by all processes in grid.
+ *
+ * TOP (input) Ptr to char
+ * Controls fashion in which messages flow within the operation.
+ *
+ * M (input) Ptr to int
+ * The number of rows of the matrix A. M >= 0.
+ *
+ * N (input) Ptr to int
+ * The number of columns of the matrix A. N >= 0.
+ *
+ * A (output) Ptr to real two dimensional array
+ * The m by n matrix A. Fortran77 (column-major) storage
+ * assumed.
+ *
+ * LDA (input) Ptr to int
+ * The leading dimension of the array A. LDA >= M.
+ *
+ * RA (output) Integer Array, dimension (LDIA, N)
+ * Contains process row that the amn of each element
+ * of A was found on: i.e., rA(1,2) contains the process
+ * row that the amn of A(1,2) was found on.
+ * Values are left on process {rdest, cdest} only, others
+ * may be modified, but not left with interesting data.
+ * If rdest == -1, then result is left on all processes in scope.
+ * If LDIA == -1, this array is not accessed, and need not exist.
+ *
+ * CA (output) Integer Array, dimension (LDIA, N)
+ * Contains process column that the amn of each element
+ * of A was found on: i.e., cA(1,2) contains the process
+ * column that the max/min of A(1,2) was found on.
+ * Values are left on process {rdest, cdest} only, others
+ * may be modified, but not left with interesting data.
+ * If rdest == -1, then result is left on all processes in scope.
+ * If LDIA == -1, this array is not accessed, and need not exist.
+ *
+ * LDIA (input) Ptr to int
+ * If (LDIA == -1), then the arrays RA and CA are not accessed.
+ * ELSE leading dimension of the arrays RA and CA. LDIA >= M.
+ *
+ * RDEST (input) Ptr to int
+ * The process row of the destination of the amn.
+ * If rdest == -1, then result is left on all processes in scope.
+ *
+ * CDEST (input) Ptr to int
+ * The process column of the destination of the amn.
+ * If rdest == -1, then CDEST ignored.
+ *
+ * ------------------------------------------------------------------------
+ */
+{
+ void BI_ArgCheck(int, int, char *, char, char, char, int, int, int, int,
+ int *, int *);
+ void BI_UpdateBuffs(BLACBUFF *);
+ BLACBUFF *BI_GetBuff(int);
+ int BI_BuffIsFree(BLACBUFF *, int);
+ MPI_Datatype BI_GetMpiGeType(BLACSCONTEXT *, int, int, int,
+ MPI_Datatype, int *);
+ BLACBUFF *BI_Pack(BLACSCONTEXT *, BVOID *, BLACBUFF *, MPI_Datatype);
+ MPI_Datatype BI_GetMpiGeType(BLACSCONTEXT *, int, int, int,
+ MPI_Datatype, int *);
+ void BI_Unpack(BLACSCONTEXT *, BVOID *, BLACBUFF *, MPI_Datatype);
+ void BI_MringComb(BLACSCONTEXT *, BLACBUFF *, BLACBUFF *, int, VVFUNPTR,
+ int, int);
+ void BI_TreeComb(BLACSCONTEXT *, BLACBUFF *, BLACBUFF *, int, VVFUNPTR,
+ int, int);
+ void BI_BeComb(BLACSCONTEXT *, BLACBUFF *, BLACBUFF *, int, VVFUNPTR);
+ void BI_svvamn(int, char *, char *);
+ void BI_svvamn2(int, char *, char *);
+ void BI_sMPI_amn(void *, void *, int *, MPI_Datatype *);
+ void BI_sMPI_amn2(void *, void *, int *, MPI_Datatype *);
+/*
+ * Variable Declarations
+ */
+ VVFUNPTR vvop;
+ BLACBUFF *bp, *bp2;
+ BLACSCONTEXT *ctxt;
+ char ttop, tscope;
+ int i, j, N, dest, idist, length, tlda, tldia, trdest, ierr;
+ int len[2];
+ MPI_Aint disp[2];
+ MPI_Datatype dtypes[2];
+ MPI_Op BlacComb;
+ MPI_Datatype MyType;
+ BI_DistType *dist, mydist;
+ extern BLACBUFF *BI_ActiveQ;
+ extern BLACBUFF BI_AuxBuff;
+
+ MGetConTxt(Mpval(ConTxt), ctxt);
+ ttop = F2C_CharTrans(top);
+ ttop = Mlowcase(ttop);
+ tscope = F2C_CharTrans(scope);
+ tscope = Mlowcase(tscope);
+/*
+ * If the user has set the default combine topology, use it instead of
+ * BLACS default
+ */
+#ifdef DefCombTop
+ if (ttop == ' ') ttop = DefCombTop;
+#endif
+ if (Mpval(cdest) == -1) trdest = -1;
+ else trdest = Mpval(rdest);
+#if (BlacsDebugLvl > 0)
+ BI_ArgCheck(Mpval(ConTxt), RT_COMB, __FILE__, tscope, 'u', 'u', Mpval(m),
+ Mpval(n), Mpval(lda), 1, &trdest, Mpaddress(cdest));
+ if (Mpval(ldia) < Mpval(m))
+ {
+ if (Mpval(ldia) != -1)
+ BI_BlacsWarn(Mpval(ConTxt), __LINE__, __FILE__,
+ "LDIA too small (LDIA=%d, but M=%d)", Mpval(ldia),
+ Mpval(m));
+ }
+#endif
+ if (Mpval(lda) >= Mpval(m)) tlda = Mpval(lda);
+ else tlda = Mpval(m);
+ if (Mpval(ldia) < Mpval(m)) tldia = Mpval(m);
+ else tldia = Mpval(ldia);
+ switch(tscope)
+ {
+ case 'r':
+ ctxt->scp = &ctxt->rscp;
+ if (trdest == -1) dest = -1;
+ else dest = Mpval(cdest);
+ break;
+ case 'c':
+ ctxt->scp = &ctxt->cscp;
+ dest = trdest;
+ break;
+ case 'a':
+ ctxt->scp = &ctxt->ascp;
+ if (trdest == -1) dest = -1;
+ else dest = Mvkpnum(ctxt, trdest, Mpval(cdest));
+ break;
+ default:
+ BI_BlacsErr(Mpval(ConTxt), __LINE__, __FILE__, "Unknown scope '%c'",
+ tscope);
+ }
+
+
+/*
+ * It's not defined how MPI reacts to 0 element reductions, so use BLACS 1-tree
+ * topology if we've got one
+ */
+ if (ttop == ' ')
+ if ( (Mpval(m) < 1) || (Mpval(n) < 1) || (ctxt->TopsRepeat) ) ttop = '1';
+ N = Mpval(m) * Mpval(n);
+/*
+ * If process who has amn is to be communicated, must set up distance
+ * vector after value vector
+ */
+ if (Mpval(ldia) != -1)
+ {
+ vvop = BI_svvamn;
+ length = N * sizeof(float);
+ i = length % sizeof(BI_DistType); /* ensure dist vec aligned correctly */
+ if (i) length += sizeof(BI_DistType) - i;
+ idist = length;
+ length += N * sizeof(BI_DistType);
+/*
+ * For performance, insist second buffer is at least 8-byte aligned
+ */
+ j = 8;
+ if (sizeof(float) > j) j = sizeof(float);
+ i = length % j;
+ if (i) length += j - i;
+ i = 2 * length;
+
+ bp = BI_GetBuff(i);
+ bp2 = &BI_AuxBuff;
+ bp2->Buff = &bp->Buff[length];
+ BI_smvcopy(Mpval(m), Mpval(n), A, tlda, bp->Buff);
+/*
+ * Fill in distance vector
+ */
+ if (dest == -1) mydist = ctxt->scp->Iam;
+ else mydist = (ctxt->scp->Np + ctxt->scp->Iam - dest) % ctxt->scp->Np;
+ dist = (BI_DistType *) &bp->Buff[idist];
+ for (i=0; i < N; i++) dist[i] = mydist;
+
+/*
+ * Create the MPI datatype holding both user's buffer and distance vector
+ */
+ len[0] = len[1] = N;
+ disp[0] = 0;
+ disp[1] = idist;
+ dtypes[0] = MPI_FLOAT;
+ dtypes[1] = BI_MpiDistType;
+#ifdef ZeroByteTypeBug
+ if (N > 0)
+ {
+#endif
+ i = 2;
+ ierr=MPI_Type_struct(i, len, disp, dtypes, &MyType);
+ ierr=MPI_Type_commit(&MyType);
+ bp->N = bp2->N = 1;
+ bp->dtype = bp2->dtype = MyType;
+#ifdef ZeroByteTypeBug
+ }
+ else
+ {
+ bp->N = bp2->N = 0;
+ bp->dtype = bp2->dtype = MPI_INT;
+ }
+#endif
+ }
+ else
+ {
+ vvop = BI_svvamn2;
+ length = N * sizeof(float);
+/*
+ * If A is contiguous, we can use it as one of our buffers
+ */
+ if ( (Mpval(m) == tlda) || (Mpval(n) == 1) )
+ {
+ bp = &BI_AuxBuff;
+ bp->Buff = (char *) A;
+ bp2 = BI_GetBuff(length);
+ }
+ else
+ {
+ bp = BI_GetBuff(length*2);
+ bp2 = &BI_AuxBuff;
+ bp2->Buff = &bp->Buff[length];
+ BI_smvcopy(Mpval(m), Mpval(n), A, tlda, bp->Buff);
+ }
+ bp->N = bp2->N = N;
+ bp->dtype = bp2->dtype = MPI_FLOAT;
+ }
+
+ switch(ttop)
+ {
+ case ' ': /* use MPI's reduction by default */
+ i = 1;
+ if (Mpval(ldia) == -1)
+ {
+ ierr=MPI_Op_create(BI_sMPI_amn2, i, &BlacComb);
+ }
+ else
+ {
+ ierr=MPI_Op_create(BI_sMPI_amn, i, &BlacComb);
+ BI_AuxBuff.Len = N; /* set this up for the MPI OP wrappers */
+ }
+
+ if (trdest != -1)
+ {
+ ierr=MPI_Reduce(bp->Buff, bp2->Buff, bp->N, bp->dtype, BlacComb, dest,
+ ctxt->scp->comm);
+ if (ctxt->scp->Iam == dest)
+ {
+ BI_svmcopy(Mpval(m), Mpval(n), A, tlda, bp2->Buff);
+ if (Mpval(ldia) != -1)
+ BI_TransDist(ctxt, tscope, Mpval(m), Mpval(n), rA, cA, tldia,
+ (BI_DistType *) &bp2->Buff[idist],
+ trdest, Mpval(cdest));
+ }
+ }
+ else
+ {
+ ierr=MPI_Allreduce(bp->Buff, bp2->Buff, bp->N, bp->dtype, BlacComb,
+ ctxt->scp->comm);
+ BI_svmcopy(Mpval(m), Mpval(n), A, tlda, bp2->Buff);
+ if (Mpval(ldia) != -1)
+ BI_TransDist(ctxt, tscope, Mpval(m), Mpval(n), rA, cA, tldia,
+ (BI_DistType *) &bp2->Buff[idist],
+ trdest, Mpval(cdest));
+ }
+ ierr=MPI_Op_free(&BlacComb);
+ if (Mpval(ldia) != -1)
+#ifdef ZeroByteTypeBug
+ if (N > 0)
+#endif
+ ierr=BI_MPI_TYPE_FREE(&MyType);
+ if (BI_ActiveQ) BI_UpdateBuffs(NULL);
+ return;
+ break;
+ case 'i':
+ BI_MringComb(ctxt, bp, bp2, N, vvop, dest, 1);
+ break;
+ case 'd':
+ BI_MringComb(ctxt, bp, bp2, N, vvop, dest, -1);
+ break;
+ case 's':
+ BI_MringComb(ctxt, bp, bp2, N, vvop, dest, 2);
+ break;
+ case 'm':
+ BI_MringComb(ctxt, bp, bp2, N, vvop, dest, ctxt->Nr_co);
+ break;
+ case '1':
+ case '2':
+ case '3':
+ case '4':
+ case '5':
+ case '6':
+ case '7':
+ case '8':
+ case '9':
+ BI_TreeComb(ctxt, bp, bp2, N, vvop, dest, ttop-47);
+ break;
+ case 'f':
+ BI_TreeComb(ctxt, bp, bp2, N, vvop, dest, FULLCON);
+ break;
+ case 't':
+ BI_TreeComb(ctxt, bp, bp2, N, vvop, dest, ctxt->Nb_co);
+ break;
+ case 'h':
+/*
+ * Use bidirectional exchange if everyone wants answer
+ */
+ if ( (trdest == -1) && !(ctxt->TopsCohrnt) )
+ BI_BeComb(ctxt, bp, bp2, N, vvop);
+ else
+ BI_TreeComb(ctxt, bp, bp2, N, vvop, dest, 2);
+ break;
+ default :
+ BI_BlacsErr(Mpval(ConTxt), __LINE__, __FILE__, "Unknown topology '%c'",
+ ttop);
+ }
+
+ if (Mpval(ldia) != -1)
+#ifdef ZeroByteTypeBug
+ if (N > 0)
+#endif
+ ierr=BI_MPI_TYPE_FREE(&MyType);
+/*
+ * If I am selected to receive answer
+ */
+ if ( (ctxt->scp->Iam == dest) || (dest == -1) )
+ {
+/*
+ * Translate the distances stored in the latter part of bp->Buff into
+ * process grid coordinates, and output these coordinates in the
+ * arrays rA and cA.
+ */
+ if (Mpval(ldia) != -1)
+ BI_TransDist(ctxt, tscope, Mpval(m), Mpval(n), rA, cA, tldia,
+ dist, trdest, Mpval(cdest));
+/*
+ * Unpack the amn array
+ */
+ if (bp != &BI_AuxBuff) BI_svmcopy(Mpval(m), Mpval(n), A, tlda, bp->Buff);
+ }
+}
diff --git a/BLACS/SRC/sgamx2d_.c b/BLACS/SRC/sgamx2d_.c
new file mode 100644
index 0000000..4b0af6f
--- /dev/null
+++ b/BLACS/SRC/sgamx2d_.c
@@ -0,0 +1,373 @@
+#include "Bdef.h"
+
+
+
+#if (INTFACE == C_CALL)
+void Csgamx2d(int ConTxt, char *scope, char *top, int m, int n, float *A,
+ int lda, int *rA, int *cA, int ldia, int rdest, int cdest)
+#else
+F_VOID_FUNC sgamx2d_(int *ConTxt, F_CHAR scope, F_CHAR top, int *m, int *n,
+ float *A, int *lda, int *rA, int *cA, int *ldia,
+ int *rdest, int *cdest)
+#endif
+/*
+ * -- V1.1 BLACS routine --
+ * University of Tennessee, May 1, 1996
+ * Written by Clint Whaley.
+ *
+ * Purpose
+ * =======
+ * Combine amx operation for real rectangular matrices.
+ *
+ * Arguments
+ * =========
+ *
+ * ConTxt (input) Ptr to int
+ * Index into MyConTxts00 (my contexts array).
+ *
+ * SCOPE (input) Ptr to char
+ * Limit the scope of the operation.
+ * = 'R' : Operation is performed by a process row.
+ * = 'C' : Operation is performed by a process column.
+ * = 'A' : Operation is performed by all processes in grid.
+ *
+ * TOP (input) Ptr to char
+ * Controls fashion in which messages flow within the operation.
+ *
+ * M (input) Ptr to int
+ * The number of rows of the matrix A. M >= 0.
+ *
+ * N (input) Ptr to int
+ * The number of columns of the matrix A. N >= 0.
+ *
+ * A (output) Ptr to real two dimensional array
+ * The m by n matrix A. Fortran77 (column-major) storage
+ * assumed.
+ *
+ * LDA (input) Ptr to int
+ * The leading dimension of the array A. LDA >= M.
+ *
+ * RA (output) Integer Array, dimension (LDIA, N)
+ * Contains process row that the amx of each element
+ * of A was found on: i.e., rA(1,2) contains the process
+ * row that the amx of A(1,2) was found on.
+ * Values are left on process {rdest, cdest} only, others
+ * may be modified, but not left with interesting data.
+ * If rdest == -1, then result is left on all processes in scope.
+ * If LDIA == -1, this array is not accessed, and need not exist.
+ *
+ * CA (output) Integer Array, dimension (LDIA, N)
+ * Contains process column that the amx of each element
+ * of A was found on: i.e., cA(1,2) contains the process
+ * column that the max/min of A(1,2) was found on.
+ * Values are left on process {rdest, cdest} only, others
+ * may be modified, but not left with interesting data.
+ * If rdest == -1, then result is left on all processes in scope.
+ * If LDIA == -1, this array is not accessed, and need not exist.
+ *
+ * LDIA (input) Ptr to int
+ * If (LDIA == -1), then the arrays RA and CA are not accessed.
+ * ELSE leading dimension of the arrays RA and CA. LDIA >= M.
+ *
+ * RDEST (input) Ptr to int
+ * The process row of the destination of the amx.
+ * If rdest == -1, then result is left on all processes in scope.
+ *
+ * CDEST (input) Ptr to int
+ * The process column of the destination of the amx.
+ * If rdest == -1, then CDEST ignored.
+ *
+ * ------------------------------------------------------------------------
+ */
+{
+ void BI_ArgCheck(int, int, char *, char, char, char, int, int, int, int,
+ int *, int *);
+ void BI_UpdateBuffs(BLACBUFF *);
+ BLACBUFF *BI_GetBuff(int);
+ int BI_BuffIsFree(BLACBUFF *, int);
+ MPI_Datatype BI_GetMpiGeType(BLACSCONTEXT *, int, int, int,
+ MPI_Datatype, int *);
+ BLACBUFF *BI_Pack(BLACSCONTEXT *, BVOID *, BLACBUFF *, MPI_Datatype);
+ MPI_Datatype BI_GetMpiGeType(BLACSCONTEXT *, int, int, int,
+ MPI_Datatype, int *);
+ void BI_Unpack(BLACSCONTEXT *, BVOID *, BLACBUFF *, MPI_Datatype);
+ void BI_MringComb(BLACSCONTEXT *, BLACBUFF *, BLACBUFF *, int, VVFUNPTR,
+ int, int);
+ void BI_TreeComb(BLACSCONTEXT *, BLACBUFF *, BLACBUFF *, int, VVFUNPTR,
+ int, int);
+ void BI_BeComb(BLACSCONTEXT *, BLACBUFF *, BLACBUFF *, int, VVFUNPTR);
+ void BI_svvamx(int, char *, char *);
+ void BI_svvamx2(int, char *, char *);
+ void BI_sMPI_amx(void *, void *, int *, MPI_Datatype *);
+ void BI_sMPI_amx2(void *, void *, int *, MPI_Datatype *);
+/*
+ * Variable Declarations
+ */
+ VVFUNPTR vvop;
+ BLACBUFF *bp, *bp2;
+ BLACSCONTEXT *ctxt;
+ char ttop, tscope;
+ int i, j, N, dest, idist, length, tlda, tldia, trdest, ierr;
+ int len[2];
+ MPI_Aint disp[2];
+ MPI_Datatype dtypes[2];
+ MPI_Op BlacComb;
+ MPI_Datatype MyType;
+ BI_DistType *dist, mydist;
+ extern BLACBUFF *BI_ActiveQ;
+ extern BLACBUFF BI_AuxBuff;
+
+ MGetConTxt(Mpval(ConTxt), ctxt);
+ ttop = F2C_CharTrans(top);
+ ttop = Mlowcase(ttop);
+ tscope = F2C_CharTrans(scope);
+ tscope = Mlowcase(tscope);
+/*
+ * If the user has set the default combine topology, use it instead of
+ * BLACS default
+ */
+#ifdef DefCombTop
+ if (ttop == ' ') ttop = DefCombTop;
+#endif
+ if (Mpval(cdest) == -1) trdest = -1;
+ else trdest = Mpval(rdest);
+#if (BlacsDebugLvl > 0)
+ BI_ArgCheck(Mpval(ConTxt), RT_COMB, __FILE__, tscope, 'u', 'u', Mpval(m),
+ Mpval(n), Mpval(lda), 1, &trdest, Mpaddress(cdest));
+ if (Mpval(ldia) < Mpval(m))
+ {
+ if (Mpval(ldia) != -1)
+ BI_BlacsWarn(Mpval(ConTxt), __LINE__, __FILE__,
+ "LDIA too small (LDIA=%d, but M=%d)", Mpval(ldia),
+ Mpval(m));
+ }
+#endif
+ if (Mpval(lda) >= Mpval(m)) tlda = Mpval(lda);
+ else tlda = Mpval(m);
+ if (Mpval(ldia) < Mpval(m)) tldia = Mpval(m);
+ else tldia = Mpval(ldia);
+ switch(tscope)
+ {
+ case 'r':
+ ctxt->scp = &ctxt->rscp;
+ if (trdest == -1) dest = -1;
+ else dest = Mpval(cdest);
+ break;
+ case 'c':
+ ctxt->scp = &ctxt->cscp;
+ dest = trdest;
+ break;
+ case 'a':
+ ctxt->scp = &ctxt->ascp;
+ if (trdest == -1) dest = -1;
+ else dest = Mvkpnum(ctxt, trdest, Mpval(cdest));
+ break;
+ default:
+ BI_BlacsErr(Mpval(ConTxt), __LINE__, __FILE__, "Unknown scope '%c'",
+ tscope);
+ }
+
+
+/*
+ * It's not defined how MPI reacts to 0 element reductions, so use BLACS 1-tree
+ * topology if we've got one
+ */
+ if (ttop == ' ')
+ if ( (Mpval(m) < 1) || (Mpval(n) < 1) || (ctxt->TopsRepeat) ) ttop = '1';
+ N = Mpval(m) * Mpval(n);
+/*
+ * If process who has amx is to be communicated, must set up distance
+ * vector after value vector
+ */
+ if (Mpval(ldia) != -1)
+ {
+ vvop = BI_svvamx;
+ length = N * sizeof(float);
+ i = length % sizeof(BI_DistType); /* ensure dist vec aligned correctly */
+ if (i) length += sizeof(BI_DistType) - i;
+ idist = length;
+ length += N * sizeof(BI_DistType);
+/*
+ * For performance, insist second buffer is at least 8-byte aligned
+ */
+ j = 8;
+ if (sizeof(float) > j) j = sizeof(float);
+ i = length % j;
+ if (i) length += j - i;
+ i = 2 * length;
+
+ bp = BI_GetBuff(i);
+ bp2 = &BI_AuxBuff;
+ bp2->Buff = &bp->Buff[length];
+ BI_smvcopy(Mpval(m), Mpval(n), A, tlda, bp->Buff);
+/*
+ * Fill in distance vector
+ */
+ if (dest == -1) mydist = ctxt->scp->Iam;
+ else mydist = (ctxt->scp->Np + ctxt->scp->Iam - dest) % ctxt->scp->Np;
+ dist = (BI_DistType *) &bp->Buff[idist];
+ for (i=0; i < N; i++) dist[i] = mydist;
+
+/*
+ * Create the MPI datatype holding both user's buffer and distance vector
+ */
+ len[0] = len[1] = N;
+ disp[0] = 0;
+ disp[1] = idist;
+ dtypes[0] = MPI_FLOAT;
+ dtypes[1] = BI_MpiDistType;
+#ifdef ZeroByteTypeBug
+ if (N > 0)
+ {
+#endif
+ i = 2;
+ ierr=MPI_Type_struct(i, len, disp, dtypes, &MyType);
+ ierr=MPI_Type_commit(&MyType);
+ bp->N = bp2->N = 1;
+ bp->dtype = bp2->dtype = MyType;
+#ifdef ZeroByteTypeBug
+ }
+ else
+ {
+ bp->N = bp2->N = 0;
+ bp->dtype = bp2->dtype = MPI_INT;
+ }
+#endif
+ }
+ else
+ {
+ vvop = BI_svvamx2;
+ length = N * sizeof(float);
+/*
+ * If A is contiguous, we can use it as one of our buffers
+ */
+ if ( (Mpval(m) == tlda) || (Mpval(n) == 1) )
+ {
+ bp = &BI_AuxBuff;
+ bp->Buff = (char *) A;
+ bp2 = BI_GetBuff(length);
+ }
+ else
+ {
+ bp = BI_GetBuff(length*2);
+ bp2 = &BI_AuxBuff;
+ bp2->Buff = &bp->Buff[length];
+ BI_smvcopy(Mpval(m), Mpval(n), A, tlda, bp->Buff);
+ }
+ bp->N = bp2->N = N;
+ bp->dtype = bp2->dtype = MPI_FLOAT;
+ }
+
+ switch(ttop)
+ {
+ case ' ': /* use MPI's reduction by default */
+ i = 1;
+ if (Mpval(ldia) == -1)
+ {
+ ierr=MPI_Op_create(BI_sMPI_amx2, i, &BlacComb);
+ }
+ else
+ {
+ ierr=MPI_Op_create(BI_sMPI_amx, i, &BlacComb);
+ BI_AuxBuff.Len = N; /* set this up for the MPI OP wrappers */
+ }
+
+ if (trdest != -1)
+ {
+ ierr=MPI_Reduce(bp->Buff, bp2->Buff, bp->N, bp->dtype, BlacComb, dest,
+ ctxt->scp->comm);
+ if (ctxt->scp->Iam == dest)
+ {
+ BI_svmcopy(Mpval(m), Mpval(n), A, tlda, bp2->Buff);
+ if (Mpval(ldia) != -1)
+ BI_TransDist(ctxt, tscope, Mpval(m), Mpval(n), rA, cA, tldia,
+ (BI_DistType *) &bp2->Buff[idist],
+ trdest, Mpval(cdest));
+ }
+ }
+ else
+ {
+ ierr=MPI_Allreduce(bp->Buff, bp2->Buff, bp->N, bp->dtype, BlacComb,
+ ctxt->scp->comm);
+ BI_svmcopy(Mpval(m), Mpval(n), A, tlda, bp2->Buff);
+ if (Mpval(ldia) != -1)
+ BI_TransDist(ctxt, tscope, Mpval(m), Mpval(n), rA, cA, tldia,
+ (BI_DistType *) &bp2->Buff[idist],
+ trdest, Mpval(cdest));
+ }
+ ierr=MPI_Op_free(&BlacComb);
+ if (Mpval(ldia) != -1)
+#ifdef ZeroByteTypeBug
+ if (N > 0)
+#endif
+ ierr=BI_MPI_TYPE_FREE(&MyType);
+ if (BI_ActiveQ) BI_UpdateBuffs(NULL);
+ return;
+ break;
+ case 'i':
+ BI_MringComb(ctxt, bp, bp2, N, vvop, dest, 1);
+ break;
+ case 'd':
+ BI_MringComb(ctxt, bp, bp2, N, vvop, dest, -1);
+ break;
+ case 's':
+ BI_MringComb(ctxt, bp, bp2, N, vvop, dest, 2);
+ break;
+ case 'm':
+ BI_MringComb(ctxt, bp, bp2, N, vvop, dest, ctxt->Nr_co);
+ break;
+ case '1':
+ case '2':
+ case '3':
+ case '4':
+ case '5':
+ case '6':
+ case '7':
+ case '8':
+ case '9':
+ BI_TreeComb(ctxt, bp, bp2, N, vvop, dest, ttop-47);
+ break;
+ case 'f':
+ BI_TreeComb(ctxt, bp, bp2, N, vvop, dest, FULLCON);
+ break;
+ case 't':
+ BI_TreeComb(ctxt, bp, bp2, N, vvop, dest, ctxt->Nb_co);
+ break;
+ case 'h':
+/*
+ * Use bidirectional exchange if everyone wants answer
+ */
+ if ( (trdest == -1) && !(ctxt->TopsCohrnt) )
+ BI_BeComb(ctxt, bp, bp2, N, vvop);
+ else
+ BI_TreeComb(ctxt, bp, bp2, N, vvop, dest, 2);
+ break;
+ default :
+ BI_BlacsErr(Mpval(ConTxt), __LINE__, __FILE__, "Unknown topology '%c'",
+ ttop);
+ }
+
+ if (Mpval(ldia) != -1)
+#ifdef ZeroByteTypeBug
+ if (N > 0)
+#endif
+ ierr=BI_MPI_TYPE_FREE(&MyType);
+/*
+ * If I am selected to receive answer
+ */
+ if ( (ctxt->scp->Iam == dest) || (dest == -1) )
+ {
+/*
+ * Translate the distances stored in the latter part of bp->Buff into
+ * process grid coordinates, and output these coordinates in the
+ * arrays rA and cA.
+ */
+ if (Mpval(ldia) != -1)
+ BI_TransDist(ctxt, tscope, Mpval(m), Mpval(n), rA, cA, tldia,
+ dist, trdest, Mpval(cdest));
+/*
+ * Unpack the amx array
+ */
+ if (bp != &BI_AuxBuff) BI_svmcopy(Mpval(m), Mpval(n), A, tlda, bp->Buff);
+ }
+}
diff --git a/BLACS/SRC/sgebr2d_.c b/BLACS/SRC/sgebr2d_.c
new file mode 100644
index 0000000..65ee3dd
--- /dev/null
+++ b/BLACS/SRC/sgebr2d_.c
@@ -0,0 +1,226 @@
+#include "Bdef.h"
+
+#if (INTFACE == C_CALL)
+void Csgebr2d(int ConTxt, char *scope, char *top, int m, int n, float *A,
+ int lda, int rsrc, int csrc)
+#else
+F_VOID_FUNC sgebr2d_(int *ConTxt, F_CHAR scope, F_CHAR top, int *m, int *n,
+ float *A, int *lda, int *rsrc, int *csrc)
+#endif
+/*
+ * -- V1.1 BLACS routine --
+ * University of Tennessee, May 1, 1996
+ * Written by Clint Whaley.
+ *
+ * Purpose
+ * =======
+ * Broadcast/receive for general real arrays.
+ *
+ * Arguments
+ * =========
+ *
+ * ConTxt (input) Ptr to int
+ * Index into MyConTxts00 (my contexts array).
+ *
+ * SCOPE (input) Ptr to char
+ * Limit the scope of the operation.
+ * = 'R' : Operation is performed by a process row.
+ * = 'C' : Operation is performed by a process column.
+ * = 'A' : Operation is performed by all processes in grid.
+ *
+ * TOP (input) Ptr to char
+ * Controls fashion in which messages flow within the operation.
+ *
+ * M (input) Ptr to int
+ * The number of rows of the matrix A. M >= 0.
+ *
+ * N (input) Ptr to int
+ * The number of columns of the matrix A. N >= 0.
+ *
+ * A (output) Ptr to real two dimensional array
+ * The m by n matrix A. Fortran77 (column-major) storage
+ * assumed.
+ *
+ * LDA (input) Ptr to int
+ * The leading dimension of the array A. LDA >= M.
+ *
+ *
+ * RSRC (input) Ptr to int
+ * The process row of the source of the matrix.
+ *
+ * CSRC (input) Ptr to int
+ * The process column of the source of the matrix.
+ *
+ *
+ * ------------------------------------------------------------------------
+ */
+{
+ void BI_ArgCheck(int, int, char *, char, char, char, int, int, int, int,
+ int *, int *);
+ int BI_HypBR(BLACSCONTEXT *, BLACBUFF *, SDRVPTR, int);
+ void BI_IdringBR(BLACSCONTEXT *, BLACBUFF *, SDRVPTR, int, int);
+ void BI_SringBR(BLACSCONTEXT *, BLACBUFF *, SDRVPTR, int);
+ void BI_MpathBR(BLACSCONTEXT *, BLACBUFF *, SDRVPTR, int, int);
+ void BI_TreeBR(BLACSCONTEXT *, BLACBUFF *, SDRVPTR, int, int);
+ void BI_UpdateBuffs(BLACBUFF *);
+ BLACBUFF *BI_GetBuff(int);
+ int BI_BuffIsFree(BLACBUFF *, int);
+ MPI_Datatype BI_GetMpiGeType(BLACSCONTEXT *, int, int, int,
+ MPI_Datatype, int *);
+ void BI_Unpack(BLACSCONTEXT *, BVOID *, BLACBUFF *, MPI_Datatype);
+ void BI_Ssend(BLACSCONTEXT *, int, int, BLACBUFF *);
+ void BI_Asend(BLACSCONTEXT *, int, int, BLACBUFF *);
+
+ BLACSCONTEXT *ctxt;
+ BLACBUFF *bp=NULL;
+ SDRVPTR send;
+ MPI_Datatype MatTyp;
+ int length, src, tlda, error, one=1;
+ char ttop, tscope;
+ extern BLACBUFF BI_AuxBuff, *BI_ActiveQ;
+
+ MGetConTxt(Mpval(ConTxt), ctxt);
+ ttop = F2C_CharTrans(top);
+ ttop = Mlowcase(ttop);
+ tscope = F2C_CharTrans(scope);
+ tscope = Mlowcase(tscope);
+#if (BlacsDebugLvl > 0)
+ BI_ArgCheck(Mpval(ConTxt), RT_BR, __FILE__, tscope, 'u', 'u', Mpval(m),
+ Mpval(n), Mpval(lda), 1, Mpaddress(rsrc), Mpaddress(csrc));
+#endif
+/*
+ * If the user has set the default broadcast topology, use it instead of
+ * BLACS default
+ */
+#ifdef DefBSTop
+ if (ttop == ' ') ttop = DefBSTop;
+#endif
+ if (Mpval(m) <= Mpval(lda)) tlda = Mpval(lda);
+ else tlda = Mpval(m);
+
+ switch(tscope)
+ {
+ case 'r':
+ ctxt->scp = &ctxt->rscp;
+ src = Mpval(csrc);
+ break;
+ case 'c':
+ ctxt->scp = &ctxt->cscp;
+ src = Mpval(rsrc);
+ break;
+ case 'a':
+ ctxt->scp = &ctxt->ascp;
+ src = Mvkpnum(ctxt, Mpval(rsrc), Mpval(csrc));
+ break;
+ default:
+ BI_BlacsErr(Mpval(ConTxt), __LINE__, __FILE__, "Unknown scope '%c'",
+ tscope);
+ }
+
+ MatTyp = BI_GetMpiGeType(ctxt, Mpval(m), Mpval(n), tlda,
+ MPI_FLOAT, &BI_AuxBuff.N);
+/*
+ * If using default topology, use MPI native broadcast
+ */
+ if (ttop == ' ')
+ {
+ error=MPI_Bcast(A, BI_AuxBuff.N, MatTyp, src, ctxt->scp->comm);
+ error=BI_MPI_TYPE_FREE(&MatTyp);
+ if (BI_ActiveQ) BI_UpdateBuffs(NULL);
+ return;
+ }
+/*
+ * If MPI handles non-contiguous buffering well, always use MPI data types
+ * instead of packing
+ */
+#ifndef MpiBuffGood
+/*
+ * If A is contiguous, receive and send directly to/from it
+ */
+ else if ( (tlda == Mpval(m)) || (Mpval(n) == 1) )
+ {
+#endif
+ send = BI_Ssend;
+ BI_AuxBuff.Buff = (char *) A;
+ BI_AuxBuff.dtype = MatTyp;
+ bp = &BI_AuxBuff;
+#ifndef MpiBuffGood
+ }
+/*
+ * If A is not contiguous, we receive message as packed so it can be
+ * forwarded without further system intervention
+ */
+ else
+ {
+ send = BI_Asend;
+ error=MPI_Pack_size(one, MatTyp, ctxt->scp->comm, &length);
+ bp = BI_GetBuff(length);
+ bp->N = length;
+ bp->dtype = MPI_PACKED;
+#if ZeroByteTypeBug
+ if (MatTyp == MPI_BYTE)
+ {
+ send = BI_Ssend;
+ bp->N = 0;
+ bp->dtype = MPI_BYTE;
+ }
+#endif
+ }
+#endif
+
+ switch(ttop)
+ {
+ case 'h':
+ error = BI_HypBR(ctxt, bp, send, src);
+ if (error == NPOW2) BI_TreeBR(ctxt, bp, send, src, 2);
+ break;
+ case '1':
+ case '2':
+ case '3':
+ case '4':
+ case '5':
+ case '6':
+ case '7':
+ case '8':
+ case '9':
+ BI_TreeBR(ctxt, bp, send, src, ttop-47);
+ break;
+ case 't':
+ BI_TreeBR(ctxt, bp, send, src, ctxt->Nb_bs);
+ break;
+ case 'i':
+ BI_IdringBR(ctxt, bp, send, src, 1);
+ break;
+ case 'd':
+ BI_IdringBR(ctxt, bp, send, src, -1);
+ break;
+ case 's':
+ BI_SringBR(ctxt, bp, send, src);
+ break;
+ case 'm':
+ BI_MpathBR(ctxt, bp, send, src, ctxt->Nr_bs);
+ break;
+ case 'f':
+ BI_MpathBR(ctxt, bp, send, src, FULLCON);
+ break;
+ default :
+ BI_BlacsErr(Mpval(ConTxt), __LINE__, __FILE__, "Unknown topology '%c'",
+ ttop);
+ }
+
+/*
+ * If we buffered, unpack.
+ */
+#ifndef MpiBuffGood
+ if (bp != &BI_AuxBuff)
+ {
+ BI_Unpack(ctxt, (BVOID *) A, bp, MatTyp);
+ BI_UpdateBuffs(bp);
+ }
+ else
+#endif
+ {
+ error=BI_MPI_TYPE_FREE(&MatTyp);
+ if (BI_ActiveQ) BI_UpdateBuffs(NULL);
+ }
+}
diff --git a/BLACS/SRC/sgebs2d_.c b/BLACS/SRC/sgebs2d_.c
new file mode 100644
index 0000000..98fb2ea
--- /dev/null
+++ b/BLACS/SRC/sgebs2d_.c
@@ -0,0 +1,195 @@
+#include "Bdef.h"
+
+#if (INTFACE == C_CALL)
+void Csgebs2d(int ConTxt, char *scope, char *top, int m, int n, float *A, int lda)
+#else
+F_VOID_FUNC sgebs2d_(int *ConTxt, F_CHAR scope, F_CHAR top, int *m, int *n,
+ float *A, int *lda)
+#endif
+/*
+ * -- V1.1 BLACS routine --
+ * University of Tennessee, May 1, 1996
+ * Written by Clint Whaley.
+ *
+ * Purpose
+ * =======
+ * Broadcast/send for general real arrays.
+ *
+ * Arguments
+ * =========
+ *
+ * ConTxt (input) Ptr to int
+ * Index into MyConTxts00 (my contexts array).
+ *
+ * SCOPE (input) Ptr to char
+ * Limit the scope of the operation.
+ * = 'R' : Operation is performed by a process row.
+ * = 'C' : Operation is performed by a process column.
+ * = 'A' : Operation is performed by all processes in grid.
+ *
+ * TOP (input) Ptr to char
+ * Controls fashion in which messages flow within the operation.
+ *
+ * M (input) Ptr to int
+ * The number of rows of the matrix A. M >= 0.
+ *
+ * N (input) Ptr to int
+ * The number of columns of the matrix A. N >= 0.
+ *
+ * A (input) Ptr to real two dimensional array
+ * The m by n matrix A. Fortran77 (column-major) storage
+ * assumed.
+ *
+ * LDA (input) Ptr to int
+ * The leading dimension of the array A. LDA >= M.
+ *
+ * ------------------------------------------------------------------------
+ */
+{
+ void BI_ArgCheck(int, int, char *, char, char, char, int, int, int, int,
+ int *, int *);
+ int BI_HypBS(BLACSCONTEXT *, BLACBUFF *, SDRVPTR);
+ void BI_IdringBS(BLACSCONTEXT *, BLACBUFF *, SDRVPTR, int);
+ void BI_SringBS(BLACSCONTEXT *, BLACBUFF *, SDRVPTR);
+ void BI_MpathBS(BLACSCONTEXT *, BLACBUFF *, SDRVPTR, int);
+ void BI_TreeBS(BLACSCONTEXT *, BLACBUFF *, SDRVPTR, int);
+ void BI_UpdateBuffs(BLACBUFF *);
+ BLACBUFF *BI_GetBuff(int);
+ int BI_BuffIsFree(BLACBUFF *, int);
+ MPI_Datatype BI_GetMpiGeType(BLACSCONTEXT *, int, int, int,
+ MPI_Datatype, int *);
+ BLACBUFF *BI_Pack(BLACSCONTEXT *, BVOID *, BLACBUFF *, MPI_Datatype);
+ void BI_Ssend(BLACSCONTEXT *, int, int, BLACBUFF *);
+ void BI_Asend(BLACSCONTEXT *, int, int, BLACBUFF *);
+
+ char ttop, tscope;
+ int error, tlda;
+ MPI_Datatype MatTyp;
+ SDRVPTR send;
+ BLACBUFF *bp;
+ BLACSCONTEXT *ctxt;
+ extern BLACBUFF BI_AuxBuff, *BI_ActiveQ;
+/*
+ * get context, lowcase char variables, and perform parameter checking
+ */
+ MGetConTxt(Mpval(ConTxt), ctxt);
+ ttop = F2C_CharTrans(top);
+ ttop = Mlowcase(ttop);
+ tscope = F2C_CharTrans(scope);
+ tscope = Mlowcase(tscope);
+#if (BlacsDebugLvl > 0)
+ BI_ArgCheck(Mpval(ConTxt), RT_BS, __FILE__, 'a', 'u', 'u', Mpval(m),
+ Mpval(n), Mpval(lda), 0, NULL, NULL);
+#endif
+/*
+ * If the user has set the default broadcast topology, use it instead of
+ * BLACS default
+ */
+#ifdef DefBSTop
+ if (ttop == ' ') ttop = DefBSTop;
+#endif
+ if (Mpval(lda) < Mpval(m)) tlda = Mpval(m);
+ else tlda = Mpval(lda);
+
+ switch(tscope)
+ {
+ case 'r':
+ ctxt->scp = &ctxt->rscp;
+ break;
+ case 'c':
+ ctxt->scp = &ctxt->cscp;
+ break;
+ case 'a':
+ ctxt->scp = &ctxt->ascp;
+ break;
+ default:
+ BI_BlacsErr(Mpval(ConTxt), __LINE__, __FILE__, "Unknown scope '%c'",
+ tscope);
+ }
+
+ MatTyp = BI_GetMpiGeType(ctxt, Mpval(m), Mpval(n), tlda,
+ MPI_FLOAT, &BI_AuxBuff.N);
+/*
+ * If using default topology, use MPI native broadcast
+ */
+ if (ttop == ' ')
+ {
+ error=MPI_Bcast(A, BI_AuxBuff.N, MatTyp, ctxt->scp->Iam, ctxt->scp->comm);
+ error=BI_MPI_TYPE_FREE(&MatTyp);
+ if (BI_ActiveQ) BI_UpdateBuffs(NULL);
+ return;
+ }
+/*
+ * If MPI handles non-contiguous buffering well, always use MPI data types
+ * instead of packing
+ */
+#ifndef MpiBuffGood
+/*
+ * If A is contiguous, send directly from it
+ */
+ else if ( (tlda == Mpval(m)) || (Mpval(n) == 1) )
+ {
+#endif
+ send = BI_Ssend;
+ BI_AuxBuff.Buff = (char *) A;
+ BI_AuxBuff.dtype = MatTyp;
+ bp = &BI_AuxBuff;
+#ifndef MpiBuffGood
+ }
+ else
+ {
+ send = BI_Asend;
+ bp = BI_Pack(ctxt, (BVOID *) A, NULL, MatTyp);
+ }
+#endif
+
+/*
+ * Call correct topology for BS/BR
+ */
+ switch(ttop)
+ {
+ case 'h':
+ error = BI_HypBS(ctxt, bp, send);
+ if (error == NPOW2) BI_TreeBS(ctxt, bp, send, 2);
+ break;
+ case '1':
+ case '2':
+ case '3':
+ case '4':
+ case '5':
+ case '6':
+ case '7':
+ case '8':
+ case '9':
+ BI_TreeBS(ctxt, bp, send, ttop-47);
+ break;
+ case 't':
+ BI_TreeBS(ctxt, bp, send, ctxt->Nb_bs);
+ break;
+ case 'i':
+ BI_IdringBS(ctxt, bp, send, 1);
+ break;
+ case 'd':
+ BI_IdringBS(ctxt, bp, send, -1);
+ break;
+ case 's':
+ BI_SringBS(ctxt, bp, send);
+ break;
+ case 'f':
+ BI_MpathBS(ctxt, bp, send, FULLCON);
+ break;
+ case 'm':
+ BI_MpathBS(ctxt, bp, send, ctxt->Nr_bs);
+ break;
+ default :
+ BI_BlacsErr(Mpval(ConTxt), __LINE__, __FILE__, "Unknown topology '%c'",
+ ttop);
+ }
+
+ error=BI_MPI_TYPE_FREE(&MatTyp);
+ if (bp == &BI_AuxBuff)
+ {
+ if (BI_ActiveQ) BI_UpdateBuffs(NULL);
+ }
+ else BI_UpdateBuffs(bp);
+} /* end sgebs2d_ */
diff --git a/BLACS/SRC/sgerv2d_.c b/BLACS/SRC/sgerv2d_.c
new file mode 100644
index 0000000..d671cbf
--- /dev/null
+++ b/BLACS/SRC/sgerv2d_.c
@@ -0,0 +1,82 @@
+#include "Bdef.h"
+
+#if (INTFACE == C_CALL)
+void Csgerv2d(int ConTxt, int m, int n, float *A, int lda, int rsrc, int csrc)
+#else
+F_VOID_FUNC sgerv2d_(int *ConTxt, int *m, int *n, float *A, int *lda,
+ int *rsrc, int *csrc)
+#endif
+/*
+ * -- V1.1 BLACS routine --
+ * University of Tennessee, May 1, 1996
+ * Written by Clint Whaley.
+ *
+ * Purpose
+ * =======
+ * Globally-blocking point to point general real receive.
+ *
+ * Arguments
+ * =========
+ *
+ * ConTxt (input) Ptr to int
+ * Index into MyConTxts00 (my contexts array).
+ *
+ * M (input) Ptr to int
+ * The number of rows of the matrix A. M >= 0.
+ *
+ * N (input) Ptr to int
+ * The number of columns of the matrix A. N >= 0.
+ *
+ * A (output) Ptr to real two dimensional array
+ * The m by n matrix A. Fortran77 (column-major) storage
+ * assumed.
+ *
+ * LDA (input) Ptr to int
+ * The leading dimension of the array A. LDA >= M.
+ *
+ *
+ * RSRC (input) Ptr to int
+ * The process row of the source of the matrix.
+ *
+ * CSRC (input) Ptr to int
+ * The process column of the source of the matrix.
+ *
+ *
+ * ------------------------------------------------------------------------
+ */
+{
+/*
+ * Prototypes and variable declarations
+ */
+ void BI_ArgCheck(int, int, char *, char, char, char, int, int, int, int,
+ int *, int *);
+ MPI_Datatype BI_GetMpiGeType(BLACSCONTEXT *, int, int, int,
+ MPI_Datatype, int *);
+ void BI_Unpack(BLACSCONTEXT *, BVOID *, BLACBUFF *, MPI_Datatype);
+ void BI_Srecv(BLACSCONTEXT *, int, int, BLACBUFF *);
+ void BI_UpdateBuffs(BLACBUFF *);
+ BLACBUFF *BI_GetBuff(int);
+ int BI_BuffIsFree(BLACBUFF *, int);
+ int tlda;
+ int ierr;
+ MPI_Datatype MatTyp;
+ BLACSCONTEXT *ctxt;
+ extern BLACBUFF BI_AuxBuff, *BI_ActiveQ;
+
+ MGetConTxt(Mpval(ConTxt), ctxt);
+#if (BlacsDebugLvl > 0)
+ BI_ArgCheck(Mpval(ConTxt), RT_RV, __FILE__, 'a', 'u', 'u', Mpval(m),
+ Mpval(n), Mpval(lda), 1, Mpaddress(rsrc), Mpaddress(csrc));
+#endif
+ if (Mpval(lda) < Mpval(m)) tlda = Mpval(m);
+ else tlda = Mpval(lda);
+ ctxt->scp = &ctxt->pscp;
+
+ MatTyp = BI_GetMpiGeType(ctxt, Mpval(m), Mpval(n), tlda,
+ MPI_FLOAT, &BI_AuxBuff.N);
+ BI_AuxBuff.Buff = (char *) A;
+ BI_AuxBuff.dtype = MatTyp;
+ BI_Srecv(ctxt, Mkpnum(ctxt, Mpval(rsrc), Mpval(csrc)), PT2PTID, &BI_AuxBuff);
+ ierr=BI_MPI_TYPE_FREE(&MatTyp);
+ if (BI_ActiveQ) BI_UpdateBuffs(NULL);
+}
diff --git a/BLACS/SRC/sgesd2d_.c b/BLACS/SRC/sgesd2d_.c
new file mode 100644
index 0000000..b657079
--- /dev/null
+++ b/BLACS/SRC/sgesd2d_.c
@@ -0,0 +1,95 @@
+#include "Bdef.h"
+
+#if (INTFACE == C_CALL)
+void Csgesd2d(int ConTxt, int m, int n, float *A, int lda,
+ int rdest, int cdest)
+#else
+F_VOID_FUNC sgesd2d_(int *ConTxt, int *m, int *n, float *A, int *lda,
+ int *rdest, int *cdest)
+#endif
+/*
+ * -- V1.1 BLACS routine --
+ * University of Tennessee, May 1, 1996
+ * Written by Clint Whaley.
+ *
+ * Purpose
+ * =======
+ * Locally-blocking point-to-point general real send.
+ *
+ * Arguments
+ * =========
+ *
+ * ConTxt (input) Ptr to int
+ * Index into MyConTxts00 (my contexts array).
+ *
+ * M (input) Ptr to int
+ * The number of rows of the matrix A. M >= 0.
+ *
+ * N (input) Ptr to int
+ * The number of columns of the matrix A. N >= 0.
+ *
+ * A (input) Ptr to real two dimensional array
+ * The m by n matrix A. Fortran77 (column-major) storage
+ * assumed.
+ *
+ * LDA (input) Ptr to int
+ * The leading dimension of the array A. LDA >= M.
+ *
+ * RDEST (input) Ptr to int
+ * The process row of the destination process.
+ *
+ * CDEST (input) Ptr to int
+ * The process column of the destination process.
+ *
+ * ------------------------------------------------------------------------
+ */
+{
+ void BI_ArgCheck(int, int, char *, char, char, char, int, int, int, int,
+ int *, int *);
+ MPI_Datatype BI_GetMpiGeType(BLACSCONTEXT *, int, int, int,
+ MPI_Datatype, int *);
+ BLACBUFF *BI_Pack(BLACSCONTEXT *, BVOID *, BLACBUFF *, MPI_Datatype);
+ void BI_Ssend(BLACSCONTEXT *, int, int, BLACBUFF *);
+ void BI_Asend(BLACSCONTEXT *, int, int, BLACBUFF *);
+ void BI_UpdateBuffs(BLACBUFF *);
+ BLACBUFF *BI_GetBuff(int);
+ int BI_BuffIsFree(BLACBUFF *, int);
+
+ int dest, tlda, ierr;
+ BLACBUFF *bp;
+ BLACSCONTEXT *ctxt;
+ MPI_Datatype MatTyp;
+ extern BLACBUFF BI_AuxBuff, *BI_ActiveQ;
+
+ MGetConTxt(Mpval(ConTxt), ctxt);
+#if (BlacsDebugLvl > 0)
+ BI_ArgCheck(Mpval(ConTxt), RT_SD, "SGESD2D", 'a', 'u', 'u', Mpval(m),
+ Mpval(n), Mpval(lda), 1, Mpaddress(rdest), Mpaddress(cdest));
+#endif
+ if (Mpval(lda) < Mpval(m)) tlda = Mpval(m);
+ else tlda = Mpval(lda);
+ dest = Mvkpnum(ctxt, Mpval(rdest), Mpval(cdest));
+ ctxt->scp = &ctxt->pscp;
+
+ MatTyp = BI_GetMpiGeType(ctxt, Mpval(m), Mpval(n), tlda,
+ MPI_FLOAT, &BI_AuxBuff.N);
+#ifdef SndIsLocBlk
+ BI_AuxBuff.Buff = (char *) A;
+ BI_AuxBuff.dtype = MatTyp;
+ BI_Ssend(ctxt, dest, PT2PTID, &BI_AuxBuff);
+#else
+ bp = BI_Pack(ctxt, (BVOID *) A, NULL, MatTyp);
+ BI_Asend(ctxt, Mkpnum(ctxt, Mpval(rdest), Mpval(cdest)), PT2PTID, bp);
+#endif
+ ierr=BI_MPI_TYPE_FREE(&MatTyp);
+
+/*
+ * Having started the async send, update the buffers (reform links, check if
+ * active buffers have become inactive, etc.)
+ */
+#ifdef SndIsLocBlk
+ if (BI_ActiveQ) BI_UpdateBuffs(NULL);
+#else
+ BI_UpdateBuffs(bp);
+#endif
+} /* end of sgesd2d */
diff --git a/BLACS/SRC/sgsum2d_.c b/BLACS/SRC/sgsum2d_.c
new file mode 100644
index 0000000..7319bbf
--- /dev/null
+++ b/BLACS/SRC/sgsum2d_.c
@@ -0,0 +1,235 @@
+#include "Bdef.h"
+
+
+#if (INTFACE == C_CALL)
+void Csgsum2d(int ConTxt, char *scope, char *top, int m, int n, float *A,
+ int lda, int rdest, int cdest)
+#else
+F_VOID_FUNC sgsum2d_(int *ConTxt, F_CHAR scope, F_CHAR top, int *m, int *n,
+ float *A, int *lda, int *rdest, int *cdest)
+#endif
+/*
+ * -- V1.1 BLACS routine --
+ * University of Tennessee, May 1, 1996
+ * Written by Clint Whaley.
+ *
+ * Purpose
+ * =======
+ * Combine sum operation for real rectangular matrices.
+ *
+ * Arguments
+ * =========
+ *
+ * ConTxt (input) Ptr to int
+ * Index into MyConTxts00 (my contexts array).
+ *
+ * SCOPE (input) Ptr to char
+ * Limit the scope of the operation.
+ * = 'R' : Operation is performed by a process row.
+ * = 'C' : Operation is performed by a process column.
+ * = 'A' : Operation is performed by all processes in grid.
+ *
+ * TOP (input) Ptr to char
+ * Controls fashion in which messages flow within the operation.
+ *
+ * M (input) Ptr to int
+ * The number of rows of the matrix A. M >= 0.
+ *
+ * N (input) Ptr to int
+ * The number of columns of the matrix A. N >= 0.
+ *
+ * A (output) Ptr to real two dimensional array
+ * The m by n matrix A. Fortran77 (column-major) storage
+ * assumed.
+ *
+ * LDA (input) Ptr to int
+ * The leading dimension of the array A. LDA >= M.
+ *
+ * RDEST (input) Ptr to int
+ * The process row of the destination of the sum.
+ * If rdest == -1, then result is left on all processes in scope.
+ *
+ * CDEST (input) Ptr to int
+ * The process column of the destination of the sum.
+ * If rdest == -1, then CDEST ignored.
+ *
+ * ------------------------------------------------------------------------
+ */
+{
+ void BI_ArgCheck(int, int, char *, char, char, char, int, int, int, int,
+ int *, int *);
+ void BI_UpdateBuffs(BLACBUFF *);
+ BLACBUFF *BI_GetBuff(int);
+ int BI_BuffIsFree(BLACBUFF *, int);
+ MPI_Datatype BI_GetMpiGeType(BLACSCONTEXT *, int, int, int,
+ MPI_Datatype, int *);
+ BLACBUFF *BI_Pack(BLACSCONTEXT *, BVOID *, BLACBUFF *, MPI_Datatype);
+ MPI_Datatype BI_GetMpiGeType(BLACSCONTEXT *, int, int, int,
+ MPI_Datatype, int *);
+ void BI_Unpack(BLACSCONTEXT *, BVOID *, BLACBUFF *, MPI_Datatype);
+ void BI_MringComb(BLACSCONTEXT *, BLACBUFF *, BLACBUFF *, int, VVFUNPTR,
+ int, int);
+ void BI_TreeComb(BLACSCONTEXT *, BLACBUFF *, BLACBUFF *, int, VVFUNPTR,
+ int, int);
+ void BI_BeComb(BLACSCONTEXT *, BLACBUFF *, BLACBUFF *, int, VVFUNPTR);
+ void BI_svvsum(int, char *, char *);
+/*
+ * Variable Declarations
+ */
+ BLACBUFF *bp, *bp2;
+ BLACSCONTEXT *ctxt;
+ char ttop, tscope;
+ int N, length, dest, tlda, trdest, ierr;
+ extern BLACBUFF *BI_ActiveQ;
+ extern BLACBUFF BI_AuxBuff;
+
+ MGetConTxt(Mpval(ConTxt), ctxt);
+ ttop = F2C_CharTrans(top);
+ ttop = Mlowcase(ttop);
+ tscope = F2C_CharTrans(scope);
+ tscope = Mlowcase(tscope);
+/*
+ * If the user has set the default combine topology, use it instead of
+ * BLACS default
+ */
+#ifdef DefCombTop
+ if (ttop == ' ') ttop = DefCombTop;
+#endif
+ if (Mpval(cdest) == -1) trdest = -1;
+ else trdest = Mpval(rdest);
+#if (BlacsDebugLvl > 0)
+ BI_ArgCheck(Mpval(ConTxt), RT_COMB, __FILE__, tscope, 'u', 'u', Mpval(m),
+ Mpval(n), Mpval(lda), 1, &trdest, Mpaddress(cdest));
+#endif
+ if (Mpval(lda) >= Mpval(m)) tlda = Mpval(lda);
+ else tlda = Mpval(m);
+ switch(tscope)
+ {
+ case 'r':
+ ctxt->scp = &ctxt->rscp;
+ if (trdest == -1) dest = -1;
+ else dest = Mpval(cdest);
+ break;
+ case 'c':
+ ctxt->scp = &ctxt->cscp;
+ dest = trdest;
+ break;
+ case 'a':
+ ctxt->scp = &ctxt->ascp;
+ if (trdest == -1) dest = -1;
+ else dest = Mvkpnum(ctxt, trdest, Mpval(cdest));
+ break;
+ default:
+ BI_BlacsErr(Mpval(ConTxt), __LINE__, __FILE__, "Unknown scope '%c'",
+ tscope);
+ }
+
+
+/*
+ * It's not defined how MPI reacts to 0 element reductions, so use BLACS 1-tree
+ * topology if we've got one. Also, we can't use MPI functions if we need to
+ * guarantee repeatability.
+ */
+ if (ttop == ' ')
+ if ( (Mpval(m) < 1) || (Mpval(n) < 1) || (ctxt->TopsRepeat) ) ttop = '1';
+ N = Mpval(m) * Mpval(n);
+ length = N * sizeof(float);
+/*
+ * If A is contiguous, we can use it as one of the buffers
+ */
+ if ( (Mpval(m) == tlda) || (Mpval(n) == 1) )
+ {
+ bp = &BI_AuxBuff;
+ bp->Buff = (char *) A;
+ bp2 = BI_GetBuff(length);
+ }
+/*
+ * Otherwise, we must allocate both buffers
+ */
+ else
+ {
+ bp = BI_GetBuff(length*2);
+ bp2 = &BI_AuxBuff;
+ bp2->Buff = &bp->Buff[length];
+ BI_smvcopy(Mpval(m), Mpval(n), A, tlda, bp->Buff);
+ }
+ bp->dtype = bp2->dtype = MPI_FLOAT;
+ bp->N = bp2->N = N;
+
+ switch(ttop)
+ {
+ case ' ': /* use MPI's reduction by default */
+ if (dest != -1)
+ {
+ ierr=MPI_Reduce(bp->Buff, bp2->Buff, bp->N, bp->dtype, MPI_SUM,
+ dest, ctxt->scp->comm);
+ if (ctxt->scp->Iam == dest)
+ BI_svmcopy(Mpval(m), Mpval(n), A, tlda, bp2->Buff);
+ }
+ else
+ {
+ ierr=MPI_Allreduce(bp->Buff, bp2->Buff, bp->N, bp->dtype, MPI_SUM,
+ ctxt->scp->comm);
+ BI_svmcopy(Mpval(m), Mpval(n), A, tlda, bp2->Buff);
+ }
+ if (BI_ActiveQ) BI_UpdateBuffs(NULL);
+ return;
+ break;
+ case 'i':
+ BI_MringComb(ctxt, bp, bp2, N, BI_svvsum, dest, 1);
+ break;
+ case 'd':
+ BI_MringComb(ctxt, bp, bp2, N, BI_svvsum, dest, -1);
+ break;
+ case 's':
+ BI_MringComb(ctxt, bp, bp2, N, BI_svvsum, dest, 2);
+ break;
+ case 'm':
+ BI_MringComb(ctxt, bp, bp2, N, BI_svvsum, dest, ctxt->Nr_co);
+ break;
+ case '1':
+ case '2':
+ case '3':
+ case '4':
+ case '5':
+ case '6':
+ case '7':
+ case '8':
+ case '9':
+ BI_TreeComb(ctxt, bp, bp2, N, BI_svvsum, dest, ttop-47);
+ break;
+ case 'f':
+ BI_TreeComb(ctxt, bp, bp2, N, BI_svvsum, dest, FULLCON);
+ break;
+ case 't':
+ BI_TreeComb(ctxt, bp, bp2, N, BI_svvsum, dest, ctxt->Nb_co);
+ break;
+ case 'h':
+/*
+ * Use bidirectional exchange if everyone wants answer
+ */
+ if ( (trdest == -1) && !(ctxt->TopsCohrnt) )
+ BI_BeComb(ctxt, bp, bp2, N, BI_svvsum);
+ else
+ BI_TreeComb(ctxt, bp, bp2, N, BI_svvsum, dest, 2);
+ break;
+ default :
+ BI_BlacsErr(Mpval(ConTxt), __LINE__, __FILE__, "Unknown topology '%c'",
+ ttop);
+ }
+
+/*
+ * If I am selected to receive answer
+ */
+ if (bp != &BI_AuxBuff)
+ {
+ if ( (ctxt->scp->Iam == dest) || (dest == -1) )
+ BI_svmcopy(Mpval(m), Mpval(n), A, tlda, bp->Buff);
+ BI_UpdateBuffs(bp);
+ }
+ else
+ {
+ if (BI_ActiveQ) BI_UpdateBuffs(NULL);
+ BI_BuffIsFree(bp, 1);
+ }
+}
diff --git a/BLACS/SRC/src-C.c.in b/BLACS/SRC/src-C.c.in
new file mode 100644
index 0000000..26ca82d
--- /dev/null
+++ b/BLACS/SRC/src-C.c.in
@@ -0,0 +1,2 @@
+#define CallFromC
+#include "@CMAKE_CURRENT_SOURCE_DIR@/@src@"
diff --git a/BLACS/SRC/strbr2d_.c b/BLACS/SRC/strbr2d_.c
new file mode 100644
index 0000000..98bc720
--- /dev/null
+++ b/BLACS/SRC/strbr2d_.c
@@ -0,0 +1,224 @@
+#include "Bdef.h"
+
+#if (INTFACE == C_CALL)
+void Cstrbr2d(int ConTxt, char *scope, char *top, char *uplo, char *diag,
+ int m, int n, float *A, int lda, int rsrc, int csrc)
+#else
+F_VOID_FUNC strbr2d_(int *ConTxt, F_CHAR scope, F_CHAR top, F_CHAR uplo,
+ F_CHAR diag, int *m, int *n, float *A, int *lda,
+ int *rsrc, int *csrc)
+#endif
+/*
+ * -- V1.1 BLACS routine --
+ * University of Tennessee, May 1, 1996
+ * Written by Clint Whaley.
+ *
+ * Purpose
+ * =======
+ * Broadcast/receive for trapezoidal real arrays.
+ *
+ * Arguments
+ * =========
+ *
+ * ConTxt (input) Ptr to int
+ * Index into MyConTxts00 (my contexts array).
+ *
+ * SCOPE (input) Ptr to char
+ * Limit the scope of the operation.
+ * = 'R' : Operation is performed by a process row.
+ * = 'C' : Operation is performed by a process column.
+ * = 'A' : Operation is performed by all processes in grid.
+ *
+ * TOP (input) Ptr to char
+ * Controls fashion in which messages flow within the operation.
+ *
+ * UPLO (input) Ptr to char
+ * Specifies the part of the matrix to be sent.
+ * = 'U': Upper trapezoidal part
+ * ELSE : Lower trapezoidal part
+ *
+ * DIAG (input) Ptr to char
+ * Specifies whether the matrix is unit diagonal or not.
+ * = 'U': Matrix is unit diagonal, diagonal not communicated.
+ * ELSE : Matrix is not unit diagonal, diagonal is communicated.
+ *
+ * M (input) Ptr to int
+ * The number of rows of the matrix A. M >= 0.
+ *
+ * N (input) Ptr to int
+ * The number of columns of the matrix A. N >= 0.
+ *
+ * A (output) Ptr to real two dimensional array
+ * The m by n matrix A. Fortran77 (column-major) storage
+ * assumed.
+ * If UPLO = 'U', only the upper trapezoid is accessed;
+ * if UPLO = 'L', only the lower trapezoid is accessed.
+ *
+ * LDA (input) Ptr to int
+ * The leading dimension of the array A. LDA >= M.
+ *
+ *
+ * RSRC (input) Ptr to int
+ * The process row of the source of the matrix.
+ *
+ * CSRC (input) Ptr to int
+ * The process column of the source of the matrix.
+ *
+ *
+ * ------------------------------------------------------------------------
+ */
+{
+ void BI_ArgCheck(int, int, char *, char, char, char, int, int, int, int,
+ int *, int *);
+ int BI_HypBR(BLACSCONTEXT *, BLACBUFF *, SDRVPTR, int);
+ void BI_IdringBR(BLACSCONTEXT *, BLACBUFF *, SDRVPTR, int, int);
+ void BI_SringBR(BLACSCONTEXT *, BLACBUFF *, SDRVPTR, int);
+ void BI_MpathBR(BLACSCONTEXT *, BLACBUFF *, SDRVPTR, int, int);
+ void BI_TreeBR(BLACSCONTEXT *, BLACBUFF *, SDRVPTR, int, int);
+ void BI_UpdateBuffs(BLACBUFF *);
+ BLACBUFF *BI_GetBuff(int);
+ int BI_BuffIsFree(BLACBUFF *, int);
+ MPI_Datatype BI_GetMpiTrType(BLACSCONTEXT *, char, char, int, int, int,
+ MPI_Datatype, int *);
+ void BI_Unpack(BLACSCONTEXT *, BVOID *, BLACBUFF *, MPI_Datatype);
+ void BI_Ssend(BLACSCONTEXT *, int, int, BLACBUFF *);
+ void BI_Asend(BLACSCONTEXT *, int, int, BLACBUFF *);
+
+ BLACSCONTEXT *ctxt;
+ BLACBUFF *bp=NULL;
+ SDRVPTR send;
+ MPI_Datatype MatTyp;
+ int length, src, tlda, error, one=1;
+ char ttop, tscope, tuplo, tdiag;
+ extern BLACBUFF BI_AuxBuff, *BI_ActiveQ;
+
+ MGetConTxt(Mpval(ConTxt), ctxt);
+ ttop = F2C_CharTrans(top);
+ ttop = Mlowcase(ttop);
+ tscope = F2C_CharTrans(scope);
+ tscope = Mlowcase(tscope);
+ tdiag = F2C_CharTrans(diag);
+ tdiag = Mlowcase(tdiag);
+ tuplo = F2C_CharTrans(uplo);
+ tuplo = Mlowcase(tuplo);
+#if (BlacsDebugLvl > 0)
+ BI_ArgCheck(Mpval(ConTxt), RT_BR, __FILE__, tscope, tuplo, tdiag, Mpval(m),
+ Mpval(n), Mpval(lda), 1, Mpaddress(rsrc), Mpaddress(csrc));
+#endif
+/*
+ * If the user has set the default broadcast topology, use it instead of
+ * BLACS default
+ */
+#ifdef DefBSTop
+ if (ttop == ' ') ttop = DefBSTop;
+#endif
+ if (Mpval(m) <= Mpval(lda)) tlda = Mpval(lda);
+ else tlda = Mpval(m);
+
+ switch(tscope)
+ {
+ case 'r':
+ ctxt->scp = &ctxt->rscp;
+ src = Mpval(csrc);
+ break;
+ case 'c':
+ ctxt->scp = &ctxt->cscp;
+ src = Mpval(rsrc);
+ break;
+ case 'a':
+ ctxt->scp = &ctxt->ascp;
+ src = Mvkpnum(ctxt, Mpval(rsrc), Mpval(csrc));
+ break;
+ default:
+ BI_BlacsErr(Mpval(ConTxt), __LINE__, __FILE__, "Unknown scope '%c'",
+ tscope);
+ }
+
+ MatTyp = BI_GetMpiTrType(ctxt, tuplo, tdiag, Mpval(m), Mpval(n), tlda,
+ MPI_FLOAT, &BI_AuxBuff.N);
+/*
+ * If using default topology, use MPI native broadcast
+ */
+ if (ttop == ' ')
+ {
+ error=MPI_Bcast(A, BI_AuxBuff.N, MatTyp, src, ctxt->scp->comm);
+ error=BI_MPI_TYPE_FREE(&MatTyp);
+ if (BI_ActiveQ) BI_UpdateBuffs(NULL);
+ return;
+ }
+/*
+ * If MPI handles non-contiguous buffering well, always use MPI data types
+ * instead of packing
+ */
+#ifdef MpiBuffGood
+ send = BI_Ssend;
+ BI_AuxBuff.Buff = (char *) A;
+ BI_AuxBuff.dtype = MatTyp;
+ bp = &BI_AuxBuff;
+#else
+
+ send = BI_Asend;
+ MPI_Pack_size(one, MatTyp, ctxt->scp->comm, &length, error);
+ bp = BI_GetBuff(length);
+ bp->N = length;
+ bp->dtype = MPI_PACKED;
+#if ZeroByteTypeBug
+ if (MatTyp == MPI_BYTE)
+ {
+ send = BI_Ssend;
+ bp->N = 0;
+ bp->dtype = MPI_BYTE;
+ }
+#endif
+
+#endif
+
+ switch(ttop)
+ {
+ case 'h':
+ error = BI_HypBR(ctxt, bp, send, src);
+ if (error == NPOW2) BI_TreeBR(ctxt, bp, send, src, 2);
+ break;
+ case '1':
+ case '2':
+ case '3':
+ case '4':
+ case '5':
+ case '6':
+ case '7':
+ case '8':
+ case '9':
+ BI_TreeBR(ctxt, bp, send, src, ttop-47);
+ break;
+ case 't':
+ BI_TreeBR(ctxt, bp, send, src, ctxt->Nb_bs);
+ break;
+ case 'i':
+ BI_IdringBR(ctxt, bp, send, src, 1);
+ break;
+ case 'd':
+ BI_IdringBR(ctxt, bp, send, src, -1);
+ break;
+ case 's':
+ BI_SringBR(ctxt, bp, send, src);
+ break;
+ case 'm':
+ BI_MpathBR(ctxt, bp, send, src, ctxt->Nr_bs);
+ break;
+ case 'f':
+ BI_MpathBR(ctxt, bp, send, src, FULLCON);
+ break;
+ default :
+ BI_BlacsErr(Mpval(ConTxt), __LINE__, __FILE__, "Unknown topology '%c'",
+ ttop);
+ }
+
+#ifdef MpiBuffGood
+ error=BI_MPI_TYPE_FREE(&MatTyp);
+ if (BI_ActiveQ) BI_UpdateBuffs(NULL);
+#endif
+#ifndef MpiBuffGood
+ BI_Unpack(ctxt, (BVOID *) A, bp, MatTyp);
+ BI_UpdateBuffs(bp);
+#endif
+}
diff --git a/BLACS/SRC/strbs2d_.c b/BLACS/SRC/strbs2d_.c
new file mode 100644
index 0000000..126b585
--- /dev/null
+++ b/BLACS/SRC/strbs2d_.c
@@ -0,0 +1,206 @@
+#include "Bdef.h"
+
+#if (INTFACE == C_CALL)
+void Cstrbs2d(int ConTxt, char *scope, char *top, char *uplo, char *diag,
+ int m, int n, float *A, int lda)
+#else
+F_VOID_FUNC strbs2d_(int *ConTxt, F_CHAR scope, F_CHAR top, F_CHAR uplo,
+ F_CHAR diag, int *m, int *n, float *A, int *lda)
+#endif
+/*
+ * -- V1.1 BLACS routine --
+ * University of Tennessee, May 1, 1996
+ * Written by Clint Whaley.
+ *
+ * Purpose
+ * =======
+ * Broadcast/send for trapezoidal real arrays.
+ *
+ * Arguments
+ * =========
+ *
+ * ConTxt (input) Ptr to int
+ * Index into MyConTxts00 (my contexts array).
+ *
+ * SCOPE (input) Ptr to char
+ * Limit the scope of the operation.
+ * = 'R' : Operation is performed by a process row.
+ * = 'C' : Operation is performed by a process column.
+ * = 'A' : Operation is performed by all processes in grid.
+ *
+ * TOP (input) Ptr to char
+ * Controls fashion in which messages flow within the operation.
+ *
+ * UPLO (input) Ptr to char
+ * Specifies the part of the matrix to be sent.
+ * = 'U': Upper trapezoidal part
+ * ELSE : Lower trapezoidal part
+ *
+ * DIAG (input) Ptr to char
+ * Specifies whether the matrix is unit diagonal or not.
+ * = 'U': Matrix is unit diagonal, diagonal not communicated.
+ * ELSE : Matrix is not unit diagonal, diagonal is communicated.
+ *
+ * M (input) Ptr to int
+ * The number of rows of the matrix A. M >= 0.
+ *
+ * N (input) Ptr to int
+ * The number of columns of the matrix A. N >= 0.
+ *
+ * A (input) Ptr to real two dimensional array
+ * The m by n matrix A. Fortran77 (column-major) storage
+ * assumed.
+ * If UPLO = 'U', only the upper trapezoid is accessed;
+ * if UPLO = 'L', only the lower trapezoid is accessed.
+ *
+ * LDA (input) Ptr to int
+ * The leading dimension of the array A. LDA >= M.
+ *
+ * ------------------------------------------------------------------------
+ */
+{
+ void BI_ArgCheck(int, int, char *, char, char, char, int, int, int, int,
+ int *, int *);
+ int BI_HypBS(BLACSCONTEXT *, BLACBUFF *, SDRVPTR);
+ void BI_IdringBS(BLACSCONTEXT *, BLACBUFF *, SDRVPTR, int);
+ void BI_SringBS(BLACSCONTEXT *, BLACBUFF *, SDRVPTR);
+ void BI_MpathBS(BLACSCONTEXT *, BLACBUFF *, SDRVPTR, int);
+ void BI_TreeBS(BLACSCONTEXT *, BLACBUFF *, SDRVPTR, int);
+ void BI_UpdateBuffs(BLACBUFF *);
+ BLACBUFF *BI_GetBuff(int);
+ int BI_BuffIsFree(BLACBUFF *, int);
+ MPI_Datatype BI_GetMpiTrType(BLACSCONTEXT *, char, char, int, int, int,
+ MPI_Datatype, int *);
+ BLACBUFF *BI_Pack(BLACSCONTEXT *, BVOID *, BLACBUFF *, MPI_Datatype);
+ void BI_Ssend(BLACSCONTEXT *, int, int, BLACBUFF *);
+ void BI_Asend(BLACSCONTEXT *, int, int, BLACBUFF *);
+
+ char ttop, tscope, tuplo, tdiag;
+ int error, tlda;
+ MPI_Datatype MatTyp;
+ SDRVPTR send;
+ BLACBUFF *bp;
+ BLACSCONTEXT *ctxt;
+ extern BLACBUFF BI_AuxBuff, *BI_ActiveQ;
+/*
+ * get context, lowcase char variables, and perform parameter checking
+ */
+ MGetConTxt(Mpval(ConTxt), ctxt);
+ ttop = F2C_CharTrans(top);
+ ttop = Mlowcase(ttop);
+ tscope = F2C_CharTrans(scope);
+ tscope = Mlowcase(tscope);
+ tuplo = F2C_CharTrans(uplo);
+ tuplo = Mlowcase(tuplo);
+ tdiag = F2C_CharTrans(diag);
+ tdiag = Mlowcase(tdiag);
+#if (BlacsDebugLvl > 0)
+ BI_ArgCheck(Mpval(ConTxt), RT_BS, __FILE__, 'a', tuplo, tdiag, Mpval(m),
+ Mpval(n), Mpval(lda), 0, NULL, NULL);
+#endif
+/*
+ * If the user has set the default broadcast topology, use it instead of
+ * BLACS default
+ */
+#ifdef DefBSTop
+ if (ttop == ' ') ttop = DefBSTop;
+#endif
+ if (Mpval(lda) < Mpval(m)) tlda = Mpval(m);
+ else tlda = Mpval(lda);
+
+ switch(tscope)
+ {
+ case 'r':
+ ctxt->scp = &ctxt->rscp;
+ break;
+ case 'c':
+ ctxt->scp = &ctxt->cscp;
+ break;
+ case 'a':
+ ctxt->scp = &ctxt->ascp;
+ break;
+ default:
+ BI_BlacsErr(Mpval(ConTxt), __LINE__, __FILE__, "Unknown scope '%c'",
+ tscope);
+ }
+ MatTyp = BI_GetMpiTrType(ctxt, tuplo, tdiag, Mpval(m), Mpval(n), tlda,
+ MPI_FLOAT, &BI_AuxBuff.N);
+/*
+ * If using default topology, use MPI native broadcast
+ */
+ if (ttop == ' ')
+ {
+ error=MPI_Bcast(A, BI_AuxBuff.N, MatTyp, ctxt->scp->Iam, ctxt->scp->comm);
+ error=BI_MPI_TYPE_FREE(&MatTyp);
+ if (BI_ActiveQ) BI_UpdateBuffs(NULL);
+ return;
+ }
+/*
+ * If MPI handles non-contiguous buffering well, always use MPI data types
+ * instead of packing
+ */
+#ifdef MpiBuffGood
+ send = BI_Ssend;
+ BI_AuxBuff.Buff = (char *) A;
+ BI_AuxBuff.dtype = MatTyp;
+ bp = &BI_AuxBuff;
+#endif
+/*
+ * Pack and use non-blocking sends for broadcast if MPI's data types aren't
+ * more efficient
+ */
+#ifndef MpiBuffGood
+ send = BI_Asend;
+ bp = BI_Pack(ctxt, (BVOID *) A, NULL, MatTyp);
+#endif
+
+/*
+ * Call correct topology for BS/BR
+ */
+ switch(ttop)
+ {
+ case 'h':
+ error = BI_HypBS(ctxt, bp, send);
+ if (error == NPOW2) BI_TreeBS(ctxt, bp, send, 2);
+ break;
+ case '1':
+ case '2':
+ case '3':
+ case '4':
+ case '5':
+ case '6':
+ case '7':
+ case '8':
+ case '9':
+ BI_TreeBS(ctxt, bp, send, ttop-47);
+ break;
+ case 't':
+ BI_TreeBS(ctxt, bp, send, ctxt->Nb_bs);
+ break;
+ case 'i':
+ BI_IdringBS(ctxt, bp, send, 1);
+ break;
+ case 'd':
+ BI_IdringBS(ctxt, bp, send, -1);
+ break;
+ case 's':
+ BI_SringBS(ctxt, bp, send);
+ break;
+ case 'f':
+ BI_MpathBS(ctxt, bp, send, FULLCON);
+ break;
+ case 'm':
+ BI_MpathBS(ctxt, bp, send, ctxt->Nr_bs);
+ break;
+ default :
+ BI_BlacsErr(Mpval(ConTxt), __LINE__, __FILE__, "Unknown topology '%c'",
+ ttop);
+ }
+
+ error=BI_MPI_TYPE_FREE(&MatTyp);
+ if (bp == &BI_AuxBuff)
+ {
+ if (BI_ActiveQ) BI_UpdateBuffs(NULL);
+ }
+ else BI_UpdateBuffs(bp);
+} /* end strbs2d_ */
diff --git a/BLACS/SRC/strrv2d_.c b/BLACS/SRC/strrv2d_.c
new file mode 100644
index 0000000..f3aca06
--- /dev/null
+++ b/BLACS/SRC/strrv2d_.c
@@ -0,0 +1,101 @@
+#include "Bdef.h"
+
+#if (INTFACE == C_CALL)
+void Cstrrv2d(int ConTxt, char *uplo, char *diag, int m, int n, float *A,
+ int lda, int rsrc, int csrc)
+#else
+F_VOID_FUNC strrv2d_(int *ConTxt, F_CHAR uplo, F_CHAR diag, int *m, int *n,
+ float *A, int *lda, int *rsrc, int *csrc)
+#endif
+/*
+ * -- V1.1 BLACS routine --
+ * University of Tennessee, May 1, 1996
+ * Written by Clint Whaley.
+ *
+ * Purpose
+ * =======
+ * Globally-blocking point to point trapezoidal real receive.
+ *
+ * Arguments
+ * =========
+ *
+ * ConTxt (input) Ptr to int
+ * Index into MyConTxts00 (my contexts array).
+ *
+ * UPLO (input) Ptr to char
+ * Specifies the part of the matrix to be sent.
+ * = 'U': Upper trapezoidal part
+ * ELSE : Lower trapezoidal part
+ *
+ * DIAG (input) Ptr to char
+ * Specifies whether the matrix is unit diagonal or not.
+ * = 'U': Matrix is unit diagonal, diagonal not communicated.
+ * ELSE : Matrix is not unit diagonal, diagonal is communicated.
+ *
+ * M (input) Ptr to int
+ * The number of rows of the matrix A. M >= 0.
+ *
+ * N (input) Ptr to int
+ * The number of columns of the matrix A. N >= 0.
+ *
+ * A (output) Ptr to real two dimensional array
+ * The m by n matrix A. Fortran77 (column-major) storage
+ * assumed.
+ * If UPLO = 'U', only the upper trapezoid is accessed;
+ * if UPLO = 'L', only the lower trapezoid is accessed.
+ *
+ * LDA (input) Ptr to int
+ * The leading dimension of the array A. LDA >= M.
+ *
+ *
+ * RSRC (input) Ptr to int
+ * The process row of the source of the matrix.
+ *
+ * CSRC (input) Ptr to int
+ * The process column of the source of the matrix.
+ *
+ *
+ * ------------------------------------------------------------------------
+ */
+{
+/*
+ * Prototypes and variable declarations
+ */
+ void BI_ArgCheck(int, int, char *, char, char, char, int, int, int, int,
+ int *, int *);
+ MPI_Datatype BI_GetMpiTrType(BLACSCONTEXT *, char, char, int, int, int,
+ MPI_Datatype, int *);
+ void BI_Unpack(BLACSCONTEXT *, BVOID *, BLACBUFF *, MPI_Datatype);
+ void BI_Srecv(BLACSCONTEXT *, int, int, BLACBUFF *);
+ void BI_UpdateBuffs(BLACBUFF *);
+ BLACBUFF *BI_GetBuff(int);
+ int BI_BuffIsFree(BLACBUFF *, int);
+ int tuplo, tdiag, tlda;
+ int ierr, length;
+ BLACBUFF *bp;
+ MPI_Datatype MatTyp;
+ BLACSCONTEXT *ctxt;
+ extern BLACBUFF BI_AuxBuff, *BI_ActiveQ;
+
+ MGetConTxt(Mpval(ConTxt), ctxt);
+ tdiag = F2C_CharTrans(diag);
+ tuplo = F2C_CharTrans(uplo);
+ tdiag = Mlowcase(tdiag);
+ tuplo = Mlowcase(tuplo);
+
+#if (BlacsDebugLvl > 0)
+ BI_ArgCheck(Mpval(ConTxt), RT_RV, __FILE__, 'a', tuplo, tdiag, Mpval(m),
+ Mpval(n), Mpval(lda), 1, Mpaddress(rsrc), Mpaddress(csrc));
+#endif
+ if (Mpval(lda) < Mpval(m)) tlda = Mpval(m);
+ else tlda = Mpval(lda);
+ ctxt->scp = &ctxt->pscp;
+
+ MatTyp = BI_GetMpiTrType(ctxt, tuplo, tdiag, Mpval(m), Mpval(n), tlda,
+ MPI_FLOAT, &BI_AuxBuff.N);
+ BI_AuxBuff.Buff = (char *) A;
+ BI_AuxBuff.dtype = MatTyp;
+ BI_Srecv(ctxt, Mkpnum(ctxt, Mpval(rsrc), Mpval(csrc)), PT2PTID, &BI_AuxBuff);
+ ierr=BI_MPI_TYPE_FREE(&MatTyp);
+ if (BI_ActiveQ) BI_UpdateBuffs(NULL);
+}
diff --git a/BLACS/SRC/strsd2d_.c b/BLACS/SRC/strsd2d_.c
new file mode 100644
index 0000000..fb39c1f
--- /dev/null
+++ b/BLACS/SRC/strsd2d_.c
@@ -0,0 +1,113 @@
+#include "Bdef.h"
+
+#if (INTFACE == C_CALL)
+void Cstrsd2d(int ConTxt, char *uplo, char *diag, int m, int n, float *A,
+ int lda, int rdest, int cdest)
+#else
+F_VOID_FUNC strsd2d_(int *ConTxt, F_CHAR uplo, F_CHAR diag, int *m, int *n,
+ float *A, int *lda, int *rdest, int *cdest)
+#endif
+/*
+ * -- V1.1 BLACS routine --
+ * University of Tennessee, May 1, 1996
+ * Written by Clint Whaley.
+ *
+ * Purpose
+ * =======
+ * Locally-blocking point-to-point trapezoidal real send.
+ *
+ * Arguments
+ * =========
+ *
+ * ConTxt (input) Ptr to int
+ * Index into MyConTxts00 (my contexts array).
+ *
+ * UPLO (input) Ptr to char
+ * Specifies the part of the matrix to be sent.
+ * = 'U': Upper trapezoidal part
+ * ELSE : Lower trapezoidal part
+ *
+ * DIAG (input) Ptr to char
+ * Specifies whether the matrix is unit diagonal or not.
+ * = 'U': Matrix is unit diagonal, diagonal not communicated.
+ * ELSE : Matrix is not unit diagonal, diagonal is communicated.
+ *
+ * M (input) Ptr to int
+ * The number of rows of the matrix A. M >= 0.
+ *
+ * N (input) Ptr to int
+ * The number of columns of the matrix A. N >= 0.
+ *
+ * A (input) Ptr to real two dimensional array
+ * The m by n matrix A. Fortran77 (column-major) storage
+ * assumed.
+ * If UPLO = 'U', only the upper trapezoid is accessed;
+ * if UPLO = 'L', only the lower trapezoid is accessed.
+ *
+ * LDA (input) Ptr to int
+ * The leading dimension of the array A. LDA >= M.
+ *
+ * RDEST (input) Ptr to int
+ * The process row of the destination process.
+ *
+ * CDEST (input) Ptr to int
+ * The process column of the destination process.
+ *
+ * ------------------------------------------------------------------------
+ */
+{
+ void BI_ArgCheck(int, int, char *, char, char, char, int, int, int, int,
+ int *, int *);
+ MPI_Datatype BI_GetMpiTrType(BLACSCONTEXT *, char, char, int, int, int,
+ MPI_Datatype, int *);
+ BLACBUFF *BI_Pack(BLACSCONTEXT *, BVOID *, BLACBUFF *, MPI_Datatype);
+ void BI_Ssend(BLACSCONTEXT *, int, int, BLACBUFF *);
+ void BI_Asend(BLACSCONTEXT *, int, int, BLACBUFF *);
+ void BI_UpdateBuffs(BLACBUFF *);
+ BLACBUFF *BI_GetBuff(int);
+ int BI_BuffIsFree(BLACBUFF *, int);
+
+ char tuplo, tdiag;
+ int dest, length, tlda, ierr;
+ BLACBUFF *bp;
+ BLACSCONTEXT *ctxt;
+ MPI_Datatype MatTyp;
+ extern BLACBUFF BI_AuxBuff, *BI_ActiveQ;
+
+ MGetConTxt(Mpval(ConTxt), ctxt);
+ tuplo = F2C_CharTrans(uplo);
+ tdiag = F2C_CharTrans(diag);
+ tuplo = Mlowcase(tuplo);
+ tdiag = Mlowcase(tdiag);
+
+#if (BlacsDebugLvl > 0)
+ BI_ArgCheck(Mpval(ConTxt), RT_SD, "STRSD2D", 'a', tuplo, tdiag, Mpval(m),
+ Mpval(n), Mpval(lda), 1, Mpaddress(rdest), Mpaddress(cdest));
+#endif
+ if (Mpval(lda) < Mpval(m)) tlda = Mpval(m);
+ else tlda = Mpval(lda);
+ dest = Mvkpnum(ctxt, Mpval(rdest), Mpval(cdest));
+ ctxt->scp = &ctxt->pscp;
+
+ MatTyp = BI_GetMpiTrType(ctxt, tuplo, tdiag, Mpval(m), Mpval(n), tlda,
+ MPI_FLOAT, &BI_AuxBuff.N);
+#ifdef SndIsLocBlk
+ BI_AuxBuff.Buff = (char *) A;
+ BI_AuxBuff.dtype = MatTyp;
+ BI_Ssend(ctxt, dest, PT2PTID, &BI_AuxBuff);
+#else
+ bp = BI_Pack(ctxt, (BVOID *) A, NULL, MatTyp);
+ BI_Asend(ctxt, Mkpnum(ctxt, Mpval(rdest), Mpval(cdest)), PT2PTID, bp);
+#endif
+ ierr=BI_MPI_TYPE_FREE(&MatTyp);
+
+/*
+ * Having started the async send, update the buffers (reform links, check if
+ * active buffers have become inactive, etc.)
+ */
+#ifdef SndIsLocBlk
+ if (BI_ActiveQ) BI_UpdateBuffs(NULL);
+#else
+ BI_UpdateBuffs(bp);
+#endif
+} /* end of strsd2d */
diff --git a/BLACS/SRC/sys2blacs_.c b/BLACS/SRC/sys2blacs_.c
new file mode 100644
index 0000000..0af84ab
--- /dev/null
+++ b/BLACS/SRC/sys2blacs_.c
@@ -0,0 +1,55 @@
+#include "Bdef.h"
+
+#if (INTFACE == C_CALL)
+int Csys2blacs_handle(MPI_Comm SysCtxt)
+#else
+int sys2blacs_handle_(int *SysCtxt)
+#endif
+{
+#if (INTFACE == C_CALL)
+ int i, j, DEF_WORLD;
+ MPI_Comm *tSysCtxt;
+ extern int BI_MaxNSysCtxt;
+ extern MPI_Comm *BI_SysContxts;
+
+ if (BI_COMM_WORLD == NULL)
+ Cblacs_pinfo(&i, &j);
+ if (SysCtxt == MPI_COMM_NULL)
+ BI_BlacsErr(-1, __LINE__, __FILE__,
+ "Cannot define a BLACS system handle based on MPI_COMM_NULL");
+/*
+ * See if we already have this system handle stored
+ */
+ for (i=0; i < BI_MaxNSysCtxt; i++)
+ if (BI_SysContxts[i] == SysCtxt) return(i);
+/*
+ * The first time in this routine, we need to define MPI_COMM_WORLD, if it isn't
+ * what is already being defined.
+ */
+ DEF_WORLD = ( (!BI_SysContxts) && (SysCtxt != MPI_COMM_WORLD) );
+/*
+ * Find free slot in system context array
+ */
+ for (i=0; i < BI_MaxNSysCtxt; i++)
+ if (BI_SysContxts[i] == MPI_COMM_NULL) break;
+/*
+ * If needed, get a bigger system context array
+ */
+ if (i == BI_MaxNSysCtxt)
+ {
+ j = BI_MaxNSysCtxt + MAXNSYSCTXT;
+ if ( (MAXNSYSCTXT == 1) && (DEF_WORLD) ) j++;
+ tSysCtxt = (MPI_Comm *) malloc(j * sizeof(MPI_Comm));
+ for (i=0; i < BI_MaxNSysCtxt; i++) tSysCtxt[i] = BI_SysContxts[i];
+ BI_MaxNSysCtxt = j;
+ for (j=i; j < BI_MaxNSysCtxt; j++) tSysCtxt[j] = MPI_COMM_NULL;
+ if (BI_SysContxts) free(BI_SysContxts);
+ BI_SysContxts = tSysCtxt;
+ }
+ if (DEF_WORLD) BI_SysContxts[i++] = MPI_COMM_WORLD;
+ BI_SysContxts[i] = SysCtxt;
+ return(i);
+#else
+ return(*SysCtxt);
+#endif
+}
diff --git a/BLACS/SRC/zgamn2d_.c b/BLACS/SRC/zgamn2d_.c
new file mode 100644
index 0000000..9de2b23
--- /dev/null
+++ b/BLACS/SRC/zgamn2d_.c
@@ -0,0 +1,373 @@
+#include "Bdef.h"
+
+
+
+#if (INTFACE == C_CALL)
+void Czgamn2d(int ConTxt, char *scope, char *top, int m, int n, double *A,
+ int lda, int *rA, int *cA, int ldia, int rdest, int cdest)
+#else
+F_VOID_FUNC zgamn2d_(int *ConTxt, F_CHAR scope, F_CHAR top, int *m, int *n,
+ double *A, int *lda, int *rA, int *cA, int *ldia,
+ int *rdest, int *cdest)
+#endif
+/*
+ * -- V1.1 BLACS routine --
+ * University of Tennessee, May 1, 1996
+ * Written by Clint Whaley.
+ *
+ * Purpose
+ * =======
+ * Combine amn operation for double complex rectangular matrices.
+ *
+ * Arguments
+ * =========
+ *
+ * ConTxt (input) Ptr to int
+ * Index into MyConTxts00 (my contexts array).
+ *
+ * SCOPE (input) Ptr to char
+ * Limit the scope of the operation.
+ * = 'R' : Operation is performed by a process row.
+ * = 'C' : Operation is performed by a process column.
+ * = 'A' : Operation is performed by all processes in grid.
+ *
+ * TOP (input) Ptr to char
+ * Controls fashion in which messages flow within the operation.
+ *
+ * M (input) Ptr to int
+ * The number of rows of the matrix A. M >= 0.
+ *
+ * N (input) Ptr to int
+ * The number of columns of the matrix A. N >= 0.
+ *
+ * A (output) Ptr to double complex two dimensional array
+ * The m by n matrix A. Fortran77 (column-major) storage
+ * assumed.
+ *
+ * LDA (input) Ptr to int
+ * The leading dimension of the array A. LDA >= M.
+ *
+ * RA (output) Integer Array, dimension (LDIA, N)
+ * Contains process row that the amn of each element
+ * of A was found on: i.e., rA(1,2) contains the process
+ * row that the amn of A(1,2) was found on.
+ * Values are left on process {rdest, cdest} only, others
+ * may be modified, but not left with interesting data.
+ * If rdest == -1, then result is left on all processes in scope.
+ * If LDIA == -1, this array is not accessed, and need not exist.
+ *
+ * CA (output) Integer Array, dimension (LDIA, N)
+ * Contains process column that the amn of each element
+ * of A was found on: i.e., cA(1,2) contains the process
+ * column that the max/min of A(1,2) was found on.
+ * Values are left on process {rdest, cdest} only, others
+ * may be modified, but not left with interesting data.
+ * If rdest == -1, then result is left on all processes in scope.
+ * If LDIA == -1, this array is not accessed, and need not exist.
+ *
+ * LDIA (input) Ptr to int
+ * If (LDIA == -1), then the arrays RA and CA are not accessed.
+ * ELSE leading dimension of the arrays RA and CA. LDIA >= M.
+ *
+ * RDEST (input) Ptr to int
+ * The process row of the destination of the amn.
+ * If rdest == -1, then result is left on all processes in scope.
+ *
+ * CDEST (input) Ptr to int
+ * The process column of the destination of the amn.
+ * If rdest == -1, then CDEST ignored.
+ *
+ * ------------------------------------------------------------------------
+ */
+{
+ void BI_ArgCheck(int, int, char *, char, char, char, int, int, int, int,
+ int *, int *);
+ void BI_UpdateBuffs(BLACBUFF *);
+ BLACBUFF *BI_GetBuff(int);
+ int BI_BuffIsFree(BLACBUFF *, int);
+ MPI_Datatype BI_GetMpiGeType(BLACSCONTEXT *, int, int, int,
+ MPI_Datatype, int *);
+ BLACBUFF *BI_Pack(BLACSCONTEXT *, BVOID *, BLACBUFF *, MPI_Datatype);
+ MPI_Datatype BI_GetMpiGeType(BLACSCONTEXT *, int, int, int,
+ MPI_Datatype, int *);
+ void BI_Unpack(BLACSCONTEXT *, BVOID *, BLACBUFF *, MPI_Datatype);
+ void BI_MringComb(BLACSCONTEXT *, BLACBUFF *, BLACBUFF *, int, VVFUNPTR,
+ int, int);
+ void BI_TreeComb(BLACSCONTEXT *, BLACBUFF *, BLACBUFF *, int, VVFUNPTR,
+ int, int);
+ void BI_BeComb(BLACSCONTEXT *, BLACBUFF *, BLACBUFF *, int, VVFUNPTR);
+ void BI_zvvamn(int, char *, char *);
+ void BI_zvvamn2(int, char *, char *);
+ void BI_zMPI_amn(void *, void *, int *, MPI_Datatype *);
+ void BI_zMPI_amn2(void *, void *, int *, MPI_Datatype *);
+/*
+ * Variable Declarations
+ */
+ VVFUNPTR vvop;
+ BLACBUFF *bp, *bp2;
+ BLACSCONTEXT *ctxt;
+ char ttop, tscope;
+ int i, j, N, dest, idist, length, tlda, tldia, trdest, ierr;
+ int len[2];
+ MPI_Aint disp[2];
+ MPI_Datatype dtypes[2];
+ MPI_Op BlacComb;
+ MPI_Datatype MyType;
+ BI_DistType *dist, mydist;
+ extern BLACBUFF *BI_ActiveQ;
+ extern BLACBUFF BI_AuxBuff;
+
+ MGetConTxt(Mpval(ConTxt), ctxt);
+ ttop = F2C_CharTrans(top);
+ ttop = Mlowcase(ttop);
+ tscope = F2C_CharTrans(scope);
+ tscope = Mlowcase(tscope);
+/*
+ * If the user has set the default combine topology, use it instead of
+ * BLACS default
+ */
+#ifdef DefCombTop
+ if (ttop == ' ') ttop = DefCombTop;
+#endif
+ if (Mpval(cdest) == -1) trdest = -1;
+ else trdest = Mpval(rdest);
+#if (BlacsDebugLvl > 0)
+ BI_ArgCheck(Mpval(ConTxt), RT_COMB, __FILE__, tscope, 'u', 'u', Mpval(m),
+ Mpval(n), Mpval(lda), 1, &trdest, Mpaddress(cdest));
+ if (Mpval(ldia) < Mpval(m))
+ {
+ if (Mpval(ldia) != -1)
+ BI_BlacsWarn(Mpval(ConTxt), __LINE__, __FILE__,
+ "LDIA too small (LDIA=%d, but M=%d)", Mpval(ldia),
+ Mpval(m));
+ }
+#endif
+ if (Mpval(lda) >= Mpval(m)) tlda = Mpval(lda);
+ else tlda = Mpval(m);
+ if (Mpval(ldia) < Mpval(m)) tldia = Mpval(m);
+ else tldia = Mpval(ldia);
+ switch(tscope)
+ {
+ case 'r':
+ ctxt->scp = &ctxt->rscp;
+ if (trdest == -1) dest = -1;
+ else dest = Mpval(cdest);
+ break;
+ case 'c':
+ ctxt->scp = &ctxt->cscp;
+ dest = trdest;
+ break;
+ case 'a':
+ ctxt->scp = &ctxt->ascp;
+ if (trdest == -1) dest = -1;
+ else dest = Mvkpnum(ctxt, trdest, Mpval(cdest));
+ break;
+ default:
+ BI_BlacsErr(Mpval(ConTxt), __LINE__, __FILE__, "Unknown scope '%c'",
+ tscope);
+ }
+
+
+/*
+ * It's not defined how MPI reacts to 0 element reductions, so use BLACS 1-tree
+ * topology if we've got one
+ */
+ if (ttop == ' ')
+ if ( (Mpval(m) < 1) || (Mpval(n) < 1) || (ctxt->TopsRepeat) ) ttop = '1';
+ N = Mpval(m) * Mpval(n);
+/*
+ * If process who has amn is to be communicated, must set up distance
+ * vector after value vector
+ */
+ if (Mpval(ldia) != -1)
+ {
+ vvop = BI_zvvamn;
+ length = N * sizeof(DCOMPLEX);
+ i = length % sizeof(BI_DistType); /* ensure dist vec aligned correctly */
+ if (i) length += sizeof(BI_DistType) - i;
+ idist = length;
+ length += N * sizeof(BI_DistType);
+/*
+ * For performance, insist second buffer is at least 8-byte aligned
+ */
+ j = 8;
+ if (sizeof(DCOMPLEX) > j) j = sizeof(DCOMPLEX);
+ i = length % j;
+ if (i) length += j - i;
+ i = 2 * length;
+
+ bp = BI_GetBuff(i);
+ bp2 = &BI_AuxBuff;
+ bp2->Buff = &bp->Buff[length];
+ BI_zmvcopy(Mpval(m), Mpval(n), A, tlda, bp->Buff);
+/*
+ * Fill in distance vector
+ */
+ if (dest == -1) mydist = ctxt->scp->Iam;
+ else mydist = (ctxt->scp->Np + ctxt->scp->Iam - dest) % ctxt->scp->Np;
+ dist = (BI_DistType *) &bp->Buff[idist];
+ for (i=0; i < N; i++) dist[i] = mydist;
+
+/*
+ * Create the MPI datatype holding both user's buffer and distance vector
+ */
+ len[0] = len[1] = N;
+ disp[0] = 0;
+ disp[1] = idist;
+ dtypes[0] = MPI_DOUBLE_COMPLEX;
+ dtypes[1] = BI_MpiDistType;
+#ifdef ZeroByteTypeBug
+ if (N > 0)
+ {
+#endif
+ i = 2;
+ ierr=MPI_Type_struct(i, len, disp, dtypes, &MyType);
+ ierr=MPI_Type_commit(&MyType);
+ bp->N = bp2->N = 1;
+ bp->dtype = bp2->dtype = MyType;
+#ifdef ZeroByteTypeBug
+ }
+ else
+ {
+ bp->N = bp2->N = 0;
+ bp->dtype = bp2->dtype = MPI_INT;
+ }
+#endif
+ }
+ else
+ {
+ vvop = BI_zvvamn2;
+ length = N * sizeof(DCOMPLEX);
+/*
+ * If A is contiguous, we can use it as one of our buffers
+ */
+ if ( (Mpval(m) == tlda) || (Mpval(n) == 1) )
+ {
+ bp = &BI_AuxBuff;
+ bp->Buff = (char *) A;
+ bp2 = BI_GetBuff(length);
+ }
+ else
+ {
+ bp = BI_GetBuff(length*2);
+ bp2 = &BI_AuxBuff;
+ bp2->Buff = &bp->Buff[length];
+ BI_zmvcopy(Mpval(m), Mpval(n), A, tlda, bp->Buff);
+ }
+ bp->N = bp2->N = N;
+ bp->dtype = bp2->dtype = MPI_DOUBLE_COMPLEX;
+ }
+
+ switch(ttop)
+ {
+ case ' ': /* use MPI's reduction by default */
+ i = 1;
+ if (Mpval(ldia) == -1)
+ {
+ ierr=MPI_Op_create(BI_zMPI_amn2, i, &BlacComb);
+ }
+ else
+ {
+ ierr=MPI_Op_create(BI_zMPI_amn, i, &BlacComb);
+ BI_AuxBuff.Len = N; /* set this up for the MPI OP wrappers */
+ }
+
+ if (trdest != -1)
+ {
+ ierr=MPI_Reduce(bp->Buff, bp2->Buff, bp->N, bp->dtype, BlacComb, dest,
+ ctxt->scp->comm);
+ if (ctxt->scp->Iam == dest)
+ {
+ BI_zvmcopy(Mpval(m), Mpval(n), A, tlda, bp2->Buff);
+ if (Mpval(ldia) != -1)
+ BI_TransDist(ctxt, tscope, Mpval(m), Mpval(n), rA, cA, tldia,
+ (BI_DistType *) &bp2->Buff[idist],
+ trdest, Mpval(cdest));
+ }
+ }
+ else
+ {
+ ierr=MPI_Allreduce(bp->Buff, bp2->Buff, bp->N, bp->dtype, BlacComb,
+ ctxt->scp->comm);
+ BI_zvmcopy(Mpval(m), Mpval(n), A, tlda, bp2->Buff);
+ if (Mpval(ldia) != -1)
+ BI_TransDist(ctxt, tscope, Mpval(m), Mpval(n), rA, cA, tldia,
+ (BI_DistType *) &bp2->Buff[idist],
+ trdest, Mpval(cdest));
+ }
+ ierr=MPI_Op_free(&BlacComb);
+ if (Mpval(ldia) != -1)
+#ifdef ZeroByteTypeBug
+ if (N > 0)
+#endif
+ ierr=BI_MPI_TYPE_FREE(&MyType);
+ if (BI_ActiveQ) BI_UpdateBuffs(NULL);
+ return;
+ break;
+ case 'i':
+ BI_MringComb(ctxt, bp, bp2, N, vvop, dest, 1);
+ break;
+ case 'd':
+ BI_MringComb(ctxt, bp, bp2, N, vvop, dest, -1);
+ break;
+ case 's':
+ BI_MringComb(ctxt, bp, bp2, N, vvop, dest, 2);
+ break;
+ case 'm':
+ BI_MringComb(ctxt, bp, bp2, N, vvop, dest, ctxt->Nr_co);
+ break;
+ case '1':
+ case '2':
+ case '3':
+ case '4':
+ case '5':
+ case '6':
+ case '7':
+ case '8':
+ case '9':
+ BI_TreeComb(ctxt, bp, bp2, N, vvop, dest, ttop-47);
+ break;
+ case 'f':
+ BI_TreeComb(ctxt, bp, bp2, N, vvop, dest, FULLCON);
+ break;
+ case 't':
+ BI_TreeComb(ctxt, bp, bp2, N, vvop, dest, ctxt->Nb_co);
+ break;
+ case 'h':
+/*
+ * Use bidirectional exchange if everyone wants answer
+ */
+ if ( (trdest == -1) && !(ctxt->TopsCohrnt) )
+ BI_BeComb(ctxt, bp, bp2, N, vvop);
+ else
+ BI_TreeComb(ctxt, bp, bp2, N, vvop, dest, 2);
+ break;
+ default :
+ BI_BlacsErr(Mpval(ConTxt), __LINE__, __FILE__, "Unknown topology '%c'",
+ ttop);
+ }
+
+ if (Mpval(ldia) != -1)
+#ifdef ZeroByteTypeBug
+ if (N > 0)
+#endif
+ ierr=BI_MPI_TYPE_FREE(&MyType);
+/*
+ * If I am selected to receive answer
+ */
+ if ( (ctxt->scp->Iam == dest) || (dest == -1) )
+ {
+/*
+ * Translate the distances stored in the latter part of bp->Buff into
+ * process grid coordinates, and output these coordinates in the
+ * arrays rA and cA.
+ */
+ if (Mpval(ldia) != -1)
+ BI_TransDist(ctxt, tscope, Mpval(m), Mpval(n), rA, cA, tldia,
+ dist, trdest, Mpval(cdest));
+/*
+ * Unpack the amn array
+ */
+ if (bp != &BI_AuxBuff) BI_zvmcopy(Mpval(m), Mpval(n), A, tlda, bp->Buff);
+ }
+}
diff --git a/BLACS/SRC/zgamx2d_.c b/BLACS/SRC/zgamx2d_.c
new file mode 100644
index 0000000..414c381
--- /dev/null
+++ b/BLACS/SRC/zgamx2d_.c
@@ -0,0 +1,373 @@
+#include "Bdef.h"
+
+
+
+#if (INTFACE == C_CALL)
+void Czgamx2d(int ConTxt, char *scope, char *top, int m, int n, double *A,
+ int lda, int *rA, int *cA, int ldia, int rdest, int cdest)
+#else
+F_VOID_FUNC zgamx2d_(int *ConTxt, F_CHAR scope, F_CHAR top, int *m, int *n,
+ double *A, int *lda, int *rA, int *cA, int *ldia,
+ int *rdest, int *cdest)
+#endif
+/*
+ * -- V1.1 BLACS routine --
+ * University of Tennessee, May 1, 1996
+ * Written by Clint Whaley.
+ *
+ * Purpose
+ * =======
+ * Combine amx operation for double complex rectangular matrices.
+ *
+ * Arguments
+ * =========
+ *
+ * ConTxt (input) Ptr to int
+ * Index into MyConTxts00 (my contexts array).
+ *
+ * SCOPE (input) Ptr to char
+ * Limit the scope of the operation.
+ * = 'R' : Operation is performed by a process row.
+ * = 'C' : Operation is performed by a process column.
+ * = 'A' : Operation is performed by all processes in grid.
+ *
+ * TOP (input) Ptr to char
+ * Controls fashion in which messages flow within the operation.
+ *
+ * M (input) Ptr to int
+ * The number of rows of the matrix A. M >= 0.
+ *
+ * N (input) Ptr to int
+ * The number of columns of the matrix A. N >= 0.
+ *
+ * A (output) Ptr to double complex two dimensional array
+ * The m by n matrix A. Fortran77 (column-major) storage
+ * assumed.
+ *
+ * LDA (input) Ptr to int
+ * The leading dimension of the array A. LDA >= M.
+ *
+ * RA (output) Integer Array, dimension (LDIA, N)
+ * Contains process row that the amx of each element
+ * of A was found on: i.e., rA(1,2) contains the process
+ * row that the amx of A(1,2) was found on.
+ * Values are left on process {rdest, cdest} only, others
+ * may be modified, but not left with interesting data.
+ * If rdest == -1, then result is left on all processes in scope.
+ * If LDIA == -1, this array is not accessed, and need not exist.
+ *
+ * CA (output) Integer Array, dimension (LDIA, N)
+ * Contains process column that the amx of each element
+ * of A was found on: i.e., cA(1,2) contains the process
+ * column that the max/min of A(1,2) was found on.
+ * Values are left on process {rdest, cdest} only, others
+ * may be modified, but not left with interesting data.
+ * If rdest == -1, then result is left on all processes in scope.
+ * If LDIA == -1, this array is not accessed, and need not exist.
+ *
+ * LDIA (input) Ptr to int
+ * If (LDIA == -1), then the arrays RA and CA are not accessed.
+ * ELSE leading dimension of the arrays RA and CA. LDIA >= M.
+ *
+ * RDEST (input) Ptr to int
+ * The process row of the destination of the amx.
+ * If rdest == -1, then result is left on all processes in scope.
+ *
+ * CDEST (input) Ptr to int
+ * The process column of the destination of the amx.
+ * If rdest == -1, then CDEST ignored.
+ *
+ * ------------------------------------------------------------------------
+ */
+{
+ void BI_ArgCheck(int, int, char *, char, char, char, int, int, int, int,
+ int *, int *);
+ void BI_UpdateBuffs(BLACBUFF *);
+ BLACBUFF *BI_GetBuff(int);
+ int BI_BuffIsFree(BLACBUFF *, int);
+ MPI_Datatype BI_GetMpiGeType(BLACSCONTEXT *, int, int, int,
+ MPI_Datatype, int *);
+ BLACBUFF *BI_Pack(BLACSCONTEXT *, BVOID *, BLACBUFF *, MPI_Datatype);
+ MPI_Datatype BI_GetMpiGeType(BLACSCONTEXT *, int, int, int,
+ MPI_Datatype, int *);
+ void BI_Unpack(BLACSCONTEXT *, BVOID *, BLACBUFF *, MPI_Datatype);
+ void BI_MringComb(BLACSCONTEXT *, BLACBUFF *, BLACBUFF *, int, VVFUNPTR,
+ int, int);
+ void BI_TreeComb(BLACSCONTEXT *, BLACBUFF *, BLACBUFF *, int, VVFUNPTR,
+ int, int);
+ void BI_BeComb(BLACSCONTEXT *, BLACBUFF *, BLACBUFF *, int, VVFUNPTR);
+ void BI_zvvamx(int, char *, char *);
+ void BI_zvvamx2(int, char *, char *);
+ void BI_zMPI_amx(void *, void *, int *, MPI_Datatype *);
+ void BI_zMPI_amx2(void *, void *, int *, MPI_Datatype *);
+/*
+ * Variable Declarations
+ */
+ VVFUNPTR vvop;
+ BLACBUFF *bp, *bp2;
+ BLACSCONTEXT *ctxt;
+ char ttop, tscope;
+ int i, j, N, dest, idist, length, tlda, tldia, trdest, ierr;
+ int len[2];
+ MPI_Aint disp[2];
+ MPI_Datatype dtypes[2];
+ MPI_Op BlacComb;
+ MPI_Datatype MyType;
+ BI_DistType *dist, mydist;
+ extern BLACBUFF *BI_ActiveQ;
+ extern BLACBUFF BI_AuxBuff;
+
+ MGetConTxt(Mpval(ConTxt), ctxt);
+ ttop = F2C_CharTrans(top);
+ ttop = Mlowcase(ttop);
+ tscope = F2C_CharTrans(scope);
+ tscope = Mlowcase(tscope);
+/*
+ * If the user has set the default combine topology, use it instead of
+ * BLACS default
+ */
+#ifdef DefCombTop
+ if (ttop == ' ') ttop = DefCombTop;
+#endif
+ if (Mpval(cdest) == -1) trdest = -1;
+ else trdest = Mpval(rdest);
+#if (BlacsDebugLvl > 0)
+ BI_ArgCheck(Mpval(ConTxt), RT_COMB, __FILE__, tscope, 'u', 'u', Mpval(m),
+ Mpval(n), Mpval(lda), 1, &trdest, Mpaddress(cdest));
+ if (Mpval(ldia) < Mpval(m))
+ {
+ if (Mpval(ldia) != -1)
+ BI_BlacsWarn(Mpval(ConTxt), __LINE__, __FILE__,
+ "LDIA too small (LDIA=%d, but M=%d)", Mpval(ldia),
+ Mpval(m));
+ }
+#endif
+ if (Mpval(lda) >= Mpval(m)) tlda = Mpval(lda);
+ else tlda = Mpval(m);
+ if (Mpval(ldia) < Mpval(m)) tldia = Mpval(m);
+ else tldia = Mpval(ldia);
+ switch(tscope)
+ {
+ case 'r':
+ ctxt->scp = &ctxt->rscp;
+ if (trdest == -1) dest = -1;
+ else dest = Mpval(cdest);
+ break;
+ case 'c':
+ ctxt->scp = &ctxt->cscp;
+ dest = trdest;
+ break;
+ case 'a':
+ ctxt->scp = &ctxt->ascp;
+ if (trdest == -1) dest = -1;
+ else dest = Mvkpnum(ctxt, trdest, Mpval(cdest));
+ break;
+ default:
+ BI_BlacsErr(Mpval(ConTxt), __LINE__, __FILE__, "Unknown scope '%c'",
+ tscope);
+ }
+
+
+/*
+ * It's not defined how MPI reacts to 0 element reductions, so use BLACS 1-tree
+ * topology if we've got one
+ */
+ if (ttop == ' ')
+ if ( (Mpval(m) < 1) || (Mpval(n) < 1) || (ctxt->TopsRepeat) ) ttop = '1';
+ N = Mpval(m) * Mpval(n);
+/*
+ * If process who has amx is to be communicated, must set up distance
+ * vector after value vector
+ */
+ if (Mpval(ldia) != -1)
+ {
+ vvop = BI_zvvamx;
+ length = N * sizeof(DCOMPLEX);
+ i = length % sizeof(BI_DistType); /* ensure dist vec aligned correctly */
+ if (i) length += sizeof(BI_DistType) - i;
+ idist = length;
+ length += N * sizeof(BI_DistType);
+/*
+ * For performance, insist second buffer is at least 8-byte aligned
+ */
+ j = 8;
+ if (sizeof(DCOMPLEX) > j) j = sizeof(DCOMPLEX);
+ i = length % j;
+ if (i) length += j - i;
+ i = 2 * length;
+
+ bp = BI_GetBuff(i);
+ bp2 = &BI_AuxBuff;
+ bp2->Buff = &bp->Buff[length];
+ BI_zmvcopy(Mpval(m), Mpval(n), A, tlda, bp->Buff);
+/*
+ * Fill in distance vector
+ */
+ if (dest == -1) mydist = ctxt->scp->Iam;
+ else mydist = (ctxt->scp->Np + ctxt->scp->Iam - dest) % ctxt->scp->Np;
+ dist = (BI_DistType *) &bp->Buff[idist];
+ for (i=0; i < N; i++) dist[i] = mydist;
+
+/*
+ * Create the MPI datatype holding both user's buffer and distance vector
+ */
+ len[0] = len[1] = N;
+ disp[0] = 0;
+ disp[1] = idist;
+ dtypes[0] = MPI_DOUBLE_COMPLEX;
+ dtypes[1] = BI_MpiDistType;
+#ifdef ZeroByteTypeBug
+ if (N > 0)
+ {
+#endif
+ i = 2;
+ ierr=MPI_Type_struct(i, len, disp, dtypes, &MyType);
+ ierr=MPI_Type_commit(&MyType);
+ bp->N = bp2->N = 1;
+ bp->dtype = bp2->dtype = MyType;
+#ifdef ZeroByteTypeBug
+ }
+ else
+ {
+ bp->N = bp2->N = 0;
+ bp->dtype = bp2->dtype = MPI_INT;
+ }
+#endif
+ }
+ else
+ {
+ vvop = BI_zvvamx2;
+ length = N * sizeof(DCOMPLEX);
+/*
+ * If A is contiguous, we can use it as one of our buffers
+ */
+ if ( (Mpval(m) == tlda) || (Mpval(n) == 1) )
+ {
+ bp = &BI_AuxBuff;
+ bp->Buff = (char *) A;
+ bp2 = BI_GetBuff(length);
+ }
+ else
+ {
+ bp = BI_GetBuff(length*2);
+ bp2 = &BI_AuxBuff;
+ bp2->Buff = &bp->Buff[length];
+ BI_zmvcopy(Mpval(m), Mpval(n), A, tlda, bp->Buff);
+ }
+ bp->N = bp2->N = N;
+ bp->dtype = bp2->dtype = MPI_DOUBLE_COMPLEX;
+ }
+
+ switch(ttop)
+ {
+ case ' ': /* use MPI's reduction by default */
+ i = 1;
+ if (Mpval(ldia) == -1)
+ {
+ ierr=MPI_Op_create(BI_zMPI_amx2, i, &BlacComb);
+ }
+ else
+ {
+ ierr=MPI_Op_create(BI_zMPI_amx, i, &BlacComb);
+ BI_AuxBuff.Len = N; /* set this up for the MPI OP wrappers */
+ }
+
+ if (trdest != -1)
+ {
+ ierr=MPI_Reduce(bp->Buff, bp2->Buff, bp->N, bp->dtype, BlacComb, dest,
+ ctxt->scp->comm);
+ if (ctxt->scp->Iam == dest)
+ {
+ BI_zvmcopy(Mpval(m), Mpval(n), A, tlda, bp2->Buff);
+ if (Mpval(ldia) != -1)
+ BI_TransDist(ctxt, tscope, Mpval(m), Mpval(n), rA, cA, tldia,
+ (BI_DistType *) &bp2->Buff[idist],
+ trdest, Mpval(cdest));
+ }
+ }
+ else
+ {
+ ierr=MPI_Allreduce(bp->Buff, bp2->Buff, bp->N, bp->dtype, BlacComb,
+ ctxt->scp->comm);
+ BI_zvmcopy(Mpval(m), Mpval(n), A, tlda, bp2->Buff);
+ if (Mpval(ldia) != -1)
+ BI_TransDist(ctxt, tscope, Mpval(m), Mpval(n), rA, cA, tldia,
+ (BI_DistType *) &bp2->Buff[idist],
+ trdest, Mpval(cdest));
+ }
+ ierr=MPI_Op_free(&BlacComb);
+ if (Mpval(ldia) != -1)
+#ifdef ZeroByteTypeBug
+ if (N > 0)
+#endif
+ ierr=BI_MPI_TYPE_FREE(&MyType);
+ if (BI_ActiveQ) BI_UpdateBuffs(NULL);
+ return;
+ break;
+ case 'i':
+ BI_MringComb(ctxt, bp, bp2, N, vvop, dest, 1);
+ break;
+ case 'd':
+ BI_MringComb(ctxt, bp, bp2, N, vvop, dest, -1);
+ break;
+ case 's':
+ BI_MringComb(ctxt, bp, bp2, N, vvop, dest, 2);
+ break;
+ case 'm':
+ BI_MringComb(ctxt, bp, bp2, N, vvop, dest, ctxt->Nr_co);
+ break;
+ case '1':
+ case '2':
+ case '3':
+ case '4':
+ case '5':
+ case '6':
+ case '7':
+ case '8':
+ case '9':
+ BI_TreeComb(ctxt, bp, bp2, N, vvop, dest, ttop-47);
+ break;
+ case 'f':
+ BI_TreeComb(ctxt, bp, bp2, N, vvop, dest, FULLCON);
+ break;
+ case 't':
+ BI_TreeComb(ctxt, bp, bp2, N, vvop, dest, ctxt->Nb_co);
+ break;
+ case 'h':
+/*
+ * Use bidirectional exchange if everyone wants answer
+ */
+ if ( (trdest == -1) && !(ctxt->TopsCohrnt) )
+ BI_BeComb(ctxt, bp, bp2, N, vvop);
+ else
+ BI_TreeComb(ctxt, bp, bp2, N, vvop, dest, 2);
+ break;
+ default :
+ BI_BlacsErr(Mpval(ConTxt), __LINE__, __FILE__, "Unknown topology '%c'",
+ ttop);
+ }
+
+ if (Mpval(ldia) != -1)
+#ifdef ZeroByteTypeBug
+ if (N > 0)
+#endif
+ ierr=BI_MPI_TYPE_FREE(&MyType);
+/*
+ * If I am selected to receive answer
+ */
+ if ( (ctxt->scp->Iam == dest) || (dest == -1) )
+ {
+/*
+ * Translate the distances stored in the latter part of bp->Buff into
+ * process grid coordinates, and output these coordinates in the
+ * arrays rA and cA.
+ */
+ if (Mpval(ldia) != -1)
+ BI_TransDist(ctxt, tscope, Mpval(m), Mpval(n), rA, cA, tldia,
+ dist, trdest, Mpval(cdest));
+/*
+ * Unpack the amx array
+ */
+ if (bp != &BI_AuxBuff) BI_zvmcopy(Mpval(m), Mpval(n), A, tlda, bp->Buff);
+ }
+}
diff --git a/BLACS/SRC/zgebr2d_.c b/BLACS/SRC/zgebr2d_.c
new file mode 100644
index 0000000..04ecbb9
--- /dev/null
+++ b/BLACS/SRC/zgebr2d_.c
@@ -0,0 +1,226 @@
+#include "Bdef.h"
+
+#if (INTFACE == C_CALL)
+void Czgebr2d(int ConTxt, char *scope, char *top, int m, int n, double *A,
+ int lda, int rsrc, int csrc)
+#else
+F_VOID_FUNC zgebr2d_(int *ConTxt, F_CHAR scope, F_CHAR top, int *m, int *n,
+ double *A, int *lda, int *rsrc, int *csrc)
+#endif
+/*
+ * -- V1.1 BLACS routine --
+ * University of Tennessee, May 1, 1996
+ * Written by Clint Whaley.
+ *
+ * Purpose
+ * =======
+ * Broadcast/receive for general double complex arrays.
+ *
+ * Arguments
+ * =========
+ *
+ * ConTxt (input) Ptr to int
+ * Index into MyConTxts00 (my contexts array).
+ *
+ * SCOPE (input) Ptr to char
+ * Limit the scope of the operation.
+ * = 'R' : Operation is performed by a process row.
+ * = 'C' : Operation is performed by a process column.
+ * = 'A' : Operation is performed by all processes in grid.
+ *
+ * TOP (input) Ptr to char
+ * Controls fashion in which messages flow within the operation.
+ *
+ * M (input) Ptr to int
+ * The number of rows of the matrix A. M >= 0.
+ *
+ * N (input) Ptr to int
+ * The number of columns of the matrix A. N >= 0.
+ *
+ * A (output) Ptr to double complex two dimensional array
+ * The m by n matrix A. Fortran77 (column-major) storage
+ * assumed.
+ *
+ * LDA (input) Ptr to int
+ * The leading dimension of the array A. LDA >= M.
+ *
+ *
+ * RSRC (input) Ptr to int
+ * The process row of the source of the matrix.
+ *
+ * CSRC (input) Ptr to int
+ * The process column of the source of the matrix.
+ *
+ *
+ * ------------------------------------------------------------------------
+ */
+{
+ void BI_ArgCheck(int, int, char *, char, char, char, int, int, int, int,
+ int *, int *);
+ int BI_HypBR(BLACSCONTEXT *, BLACBUFF *, SDRVPTR, int);
+ void BI_IdringBR(BLACSCONTEXT *, BLACBUFF *, SDRVPTR, int, int);
+ void BI_SringBR(BLACSCONTEXT *, BLACBUFF *, SDRVPTR, int);
+ void BI_MpathBR(BLACSCONTEXT *, BLACBUFF *, SDRVPTR, int, int);
+ void BI_TreeBR(BLACSCONTEXT *, BLACBUFF *, SDRVPTR, int, int);
+ void BI_UpdateBuffs(BLACBUFF *);
+ BLACBUFF *BI_GetBuff(int);
+ int BI_BuffIsFree(BLACBUFF *, int);
+ MPI_Datatype BI_GetMpiGeType(BLACSCONTEXT *, int, int, int,
+ MPI_Datatype, int *);
+ void BI_Unpack(BLACSCONTEXT *, BVOID *, BLACBUFF *, MPI_Datatype);
+ void BI_Ssend(BLACSCONTEXT *, int, int, BLACBUFF *);
+ void BI_Asend(BLACSCONTEXT *, int, int, BLACBUFF *);
+
+ BLACSCONTEXT *ctxt;
+ BLACBUFF *bp=NULL;
+ SDRVPTR send;
+ MPI_Datatype MatTyp;
+ int length, src, tlda, error, one=1;
+ char ttop, tscope;
+ extern BLACBUFF BI_AuxBuff, *BI_ActiveQ;
+
+ MGetConTxt(Mpval(ConTxt), ctxt);
+ ttop = F2C_CharTrans(top);
+ ttop = Mlowcase(ttop);
+ tscope = F2C_CharTrans(scope);
+ tscope = Mlowcase(tscope);
+#if (BlacsDebugLvl > 0)
+ BI_ArgCheck(Mpval(ConTxt), RT_BR, __FILE__, tscope, 'u', 'u', Mpval(m),
+ Mpval(n), Mpval(lda), 1, Mpaddress(rsrc), Mpaddress(csrc));
+#endif
+/*
+ * If the user has set the default broadcast topology, use it instead of
+ * BLACS default
+ */
+#ifdef DefBSTop
+ if (ttop == ' ') ttop = DefBSTop;
+#endif
+ if (Mpval(m) <= Mpval(lda)) tlda = Mpval(lda);
+ else tlda = Mpval(m);
+
+ switch(tscope)
+ {
+ case 'r':
+ ctxt->scp = &ctxt->rscp;
+ src = Mpval(csrc);
+ break;
+ case 'c':
+ ctxt->scp = &ctxt->cscp;
+ src = Mpval(rsrc);
+ break;
+ case 'a':
+ ctxt->scp = &ctxt->ascp;
+ src = Mvkpnum(ctxt, Mpval(rsrc), Mpval(csrc));
+ break;
+ default:
+ BI_BlacsErr(Mpval(ConTxt), __LINE__, __FILE__, "Unknown scope '%c'",
+ tscope);
+ }
+
+ MatTyp = BI_GetMpiGeType(ctxt, Mpval(m), Mpval(n), tlda,
+ MPI_DOUBLE_COMPLEX, &BI_AuxBuff.N);
+/*
+ * If using default topology, use MPI native broadcast
+ */
+ if (ttop == ' ')
+ {
+ error=MPI_Bcast(A, BI_AuxBuff.N, MatTyp, src, ctxt->scp->comm);
+ error=BI_MPI_TYPE_FREE(&MatTyp);
+ if (BI_ActiveQ) BI_UpdateBuffs(NULL);
+ return;
+ }
+/*
+ * If MPI handles non-contiguous buffering well, always use MPI data types
+ * instead of packing
+ */
+#ifndef MpiBuffGood
+/*
+ * If A is contiguous, receive and send directly to/from it
+ */
+ else if ( (tlda == Mpval(m)) || (Mpval(n) == 1) )
+ {
+#endif
+ send = BI_Ssend;
+ BI_AuxBuff.Buff = (char *) A;
+ BI_AuxBuff.dtype = MatTyp;
+ bp = &BI_AuxBuff;
+#ifndef MpiBuffGood
+ }
+/*
+ * If A is not contiguous, we receive message as packed so it can be
+ * forwarded without further system intervention
+ */
+ else
+ {
+ send = BI_Asend;
+ MPI_Pack_size(one, MatTyp, ctxt->scp->comm, &length, error);
+ bp = BI_GetBuff(length);
+ bp->N = length;
+ bp->dtype = MPI_PACKED;
+#if ZeroByteTypeBug
+ if (MatTyp == MPI_BYTE)
+ {
+ send = BI_Ssend;
+ bp->N = 0;
+ bp->dtype = MPI_BYTE;
+ }
+#endif
+ }
+#endif
+
+ switch(ttop)
+ {
+ case 'h':
+ error = BI_HypBR(ctxt, bp, send, src);
+ if (error == NPOW2) BI_TreeBR(ctxt, bp, send, src, 2);
+ break;
+ case '1':
+ case '2':
+ case '3':
+ case '4':
+ case '5':
+ case '6':
+ case '7':
+ case '8':
+ case '9':
+ BI_TreeBR(ctxt, bp, send, src, ttop-47);
+ break;
+ case 't':
+ BI_TreeBR(ctxt, bp, send, src, ctxt->Nb_bs);
+ break;
+ case 'i':
+ BI_IdringBR(ctxt, bp, send, src, 1);
+ break;
+ case 'd':
+ BI_IdringBR(ctxt, bp, send, src, -1);
+ break;
+ case 's':
+ BI_SringBR(ctxt, bp, send, src);
+ break;
+ case 'm':
+ BI_MpathBR(ctxt, bp, send, src, ctxt->Nr_bs);
+ break;
+ case 'f':
+ BI_MpathBR(ctxt, bp, send, src, FULLCON);
+ break;
+ default :
+ BI_BlacsErr(Mpval(ConTxt), __LINE__, __FILE__, "Unknown topology '%c'",
+ ttop);
+ }
+
+/*
+ * If we buffered, unpack.
+ */
+#ifndef MpiBuffGood
+ if (bp != &BI_AuxBuff)
+ {
+ BI_Unpack(ctxt, (BVOID *) A, bp, MatTyp);
+ BI_UpdateBuffs(bp);
+ }
+ else
+#endif
+ {
+ error=BI_MPI_TYPE_FREE(&MatTyp);
+ if (BI_ActiveQ) BI_UpdateBuffs(NULL);
+ }
+}
diff --git a/BLACS/SRC/zgebs2d_.c b/BLACS/SRC/zgebs2d_.c
new file mode 100644
index 0000000..3dbeed8
--- /dev/null
+++ b/BLACS/SRC/zgebs2d_.c
@@ -0,0 +1,195 @@
+#include "Bdef.h"
+
+#if (INTFACE == C_CALL)
+void Czgebs2d(int ConTxt, char *scope, char *top, int m, int n, double *A, int lda)
+#else
+F_VOID_FUNC zgebs2d_(int *ConTxt, F_CHAR scope, F_CHAR top, int *m, int *n,
+ double *A, int *lda)
+#endif
+/*
+ * -- V1.1 BLACS routine --
+ * University of Tennessee, May 1, 1996
+ * Written by Clint Whaley.
+ *
+ * Purpose
+ * =======
+ * Broadcast/send for general double complex arrays.
+ *
+ * Arguments
+ * =========
+ *
+ * ConTxt (input) Ptr to int
+ * Index into MyConTxts00 (my contexts array).
+ *
+ * SCOPE (input) Ptr to char
+ * Limit the scope of the operation.
+ * = 'R' : Operation is performed by a process row.
+ * = 'C' : Operation is performed by a process column.
+ * = 'A' : Operation is performed by all processes in grid.
+ *
+ * TOP (input) Ptr to char
+ * Controls fashion in which messages flow within the operation.
+ *
+ * M (input) Ptr to int
+ * The number of rows of the matrix A. M >= 0.
+ *
+ * N (input) Ptr to int
+ * The number of columns of the matrix A. N >= 0.
+ *
+ * A (input) Ptr to double complex two dimensional array
+ * The m by n matrix A. Fortran77 (column-major) storage
+ * assumed.
+ *
+ * LDA (input) Ptr to int
+ * The leading dimension of the array A. LDA >= M.
+ *
+ * ------------------------------------------------------------------------
+ */
+{
+ void BI_ArgCheck(int, int, char *, char, char, char, int, int, int, int,
+ int *, int *);
+ int BI_HypBS(BLACSCONTEXT *, BLACBUFF *, SDRVPTR);
+ void BI_IdringBS(BLACSCONTEXT *, BLACBUFF *, SDRVPTR, int);
+ void BI_SringBS(BLACSCONTEXT *, BLACBUFF *, SDRVPTR);
+ void BI_MpathBS(BLACSCONTEXT *, BLACBUFF *, SDRVPTR, int);
+ void BI_TreeBS(BLACSCONTEXT *, BLACBUFF *, SDRVPTR, int);
+ void BI_UpdateBuffs(BLACBUFF *);
+ BLACBUFF *BI_GetBuff(int);
+ int BI_BuffIsFree(BLACBUFF *, int);
+ MPI_Datatype BI_GetMpiGeType(BLACSCONTEXT *, int, int, int,
+ MPI_Datatype, int *);
+ BLACBUFF *BI_Pack(BLACSCONTEXT *, BVOID *, BLACBUFF *, MPI_Datatype);
+ void BI_Ssend(BLACSCONTEXT *, int, int, BLACBUFF *);
+ void BI_Asend(BLACSCONTEXT *, int, int, BLACBUFF *);
+
+ char ttop, tscope;
+ int error, tlda;
+ MPI_Datatype MatTyp;
+ SDRVPTR send;
+ BLACBUFF *bp;
+ BLACSCONTEXT *ctxt;
+ extern BLACBUFF BI_AuxBuff, *BI_ActiveQ;
+/*
+ * get context, lowcase char variables, and perform parameter checking
+ */
+ MGetConTxt(Mpval(ConTxt), ctxt);
+ ttop = F2C_CharTrans(top);
+ ttop = Mlowcase(ttop);
+ tscope = F2C_CharTrans(scope);
+ tscope = Mlowcase(tscope);
+#if (BlacsDebugLvl > 0)
+ BI_ArgCheck(Mpval(ConTxt), RT_BS, __FILE__, 'a', 'u', 'u', Mpval(m),
+ Mpval(n), Mpval(lda), 0, NULL, NULL);
+#endif
+/*
+ * If the user has set the default broadcast topology, use it instead of
+ * BLACS default
+ */
+#ifdef DefBSTop
+ if (ttop == ' ') ttop = DefBSTop;
+#endif
+ if (Mpval(lda) < Mpval(m)) tlda = Mpval(m);
+ else tlda = Mpval(lda);
+
+ switch(tscope)
+ {
+ case 'r':
+ ctxt->scp = &ctxt->rscp;
+ break;
+ case 'c':
+ ctxt->scp = &ctxt->cscp;
+ break;
+ case 'a':
+ ctxt->scp = &ctxt->ascp;
+ break;
+ default:
+ BI_BlacsErr(Mpval(ConTxt), __LINE__, __FILE__, "Unknown scope '%c'",
+ tscope);
+ }
+
+ MatTyp = BI_GetMpiGeType(ctxt, Mpval(m), Mpval(n), tlda,
+ MPI_DOUBLE_COMPLEX, &BI_AuxBuff.N);
+/*
+ * If using default topology, use MPI native broadcast
+ */
+ if (ttop == ' ')
+ {
+ error=MPI_Bcast(A, BI_AuxBuff.N, MatTyp, ctxt->scp->Iam, ctxt->scp->comm);
+ error=BI_MPI_TYPE_FREE(&MatTyp);
+ if (BI_ActiveQ) BI_UpdateBuffs(NULL);
+ return;
+ }
+/*
+ * If MPI handles non-contiguous buffering well, always use MPI data types
+ * instead of packing
+ */
+#ifndef MpiBuffGood
+/*
+ * If A is contiguous, send directly from it
+ */
+ else if ( (tlda == Mpval(m)) || (Mpval(n) == 1) )
+ {
+#endif
+ send = BI_Ssend;
+ BI_AuxBuff.Buff = (char *) A;
+ BI_AuxBuff.dtype = MatTyp;
+ bp = &BI_AuxBuff;
+#ifndef MpiBuffGood
+ }
+ else
+ {
+ send = BI_Asend;
+ bp = BI_Pack(ctxt, (BVOID *) A, NULL, MatTyp);
+ }
+#endif
+
+/*
+ * Call correct topology for BS/BR
+ */
+ switch(ttop)
+ {
+ case 'h':
+ error = BI_HypBS(ctxt, bp, send);
+ if (error == NPOW2) BI_TreeBS(ctxt, bp, send, 2);
+ break;
+ case '1':
+ case '2':
+ case '3':
+ case '4':
+ case '5':
+ case '6':
+ case '7':
+ case '8':
+ case '9':
+ BI_TreeBS(ctxt, bp, send, ttop-47);
+ break;
+ case 't':
+ BI_TreeBS(ctxt, bp, send, ctxt->Nb_bs);
+ break;
+ case 'i':
+ BI_IdringBS(ctxt, bp, send, 1);
+ break;
+ case 'd':
+ BI_IdringBS(ctxt, bp, send, -1);
+ break;
+ case 's':
+ BI_SringBS(ctxt, bp, send);
+ break;
+ case 'f':
+ BI_MpathBS(ctxt, bp, send, FULLCON);
+ break;
+ case 'm':
+ BI_MpathBS(ctxt, bp, send, ctxt->Nr_bs);
+ break;
+ default :
+ BI_BlacsErr(Mpval(ConTxt), __LINE__, __FILE__, "Unknown topology '%c'",
+ ttop);
+ }
+
+ error=BI_MPI_TYPE_FREE(&MatTyp);
+ if (bp == &BI_AuxBuff)
+ {
+ if (BI_ActiveQ) BI_UpdateBuffs(NULL);
+ }
+ else BI_UpdateBuffs(bp);
+} /* end zgebs2d_ */
diff --git a/BLACS/SRC/zgerv2d_.c b/BLACS/SRC/zgerv2d_.c
new file mode 100644
index 0000000..a7544d0
--- /dev/null
+++ b/BLACS/SRC/zgerv2d_.c
@@ -0,0 +1,82 @@
+#include "Bdef.h"
+
+#if (INTFACE == C_CALL)
+void Czgerv2d(int ConTxt, int m, int n, double *A, int lda, int rsrc, int csrc)
+#else
+F_VOID_FUNC zgerv2d_(int *ConTxt, int *m, int *n, double *A, int *lda,
+ int *rsrc, int *csrc)
+#endif
+/*
+ * -- V1.1 BLACS routine --
+ * University of Tennessee, May 1, 1996
+ * Written by Clint Whaley.
+ *
+ * Purpose
+ * =======
+ * Globally-blocking point to point general double complex receive.
+ *
+ * Arguments
+ * =========
+ *
+ * ConTxt (input) Ptr to int
+ * Index into MyConTxts00 (my contexts array).
+ *
+ * M (input) Ptr to int
+ * The number of rows of the matrix A. M >= 0.
+ *
+ * N (input) Ptr to int
+ * The number of columns of the matrix A. N >= 0.
+ *
+ * A (output) Ptr to double complex two dimensional array
+ * The m by n matrix A. Fortran77 (column-major) storage
+ * assumed.
+ *
+ * LDA (input) Ptr to int
+ * The leading dimension of the array A. LDA >= M.
+ *
+ *
+ * RSRC (input) Ptr to int
+ * The process row of the source of the matrix.
+ *
+ * CSRC (input) Ptr to int
+ * The process column of the source of the matrix.
+ *
+ *
+ * ------------------------------------------------------------------------
+ */
+{
+/*
+ * Prototypes and variable declarations
+ */
+ void BI_ArgCheck(int, int, char *, char, char, char, int, int, int, int,
+ int *, int *);
+ MPI_Datatype BI_GetMpiGeType(BLACSCONTEXT *, int, int, int,
+ MPI_Datatype, int *);
+ void BI_Unpack(BLACSCONTEXT *, BVOID *, BLACBUFF *, MPI_Datatype);
+ void BI_Srecv(BLACSCONTEXT *, int, int, BLACBUFF *);
+ void BI_UpdateBuffs(BLACBUFF *);
+ BLACBUFF *BI_GetBuff(int);
+ int BI_BuffIsFree(BLACBUFF *, int);
+ int tlda;
+ int ierr;
+ MPI_Datatype MatTyp;
+ BLACSCONTEXT *ctxt;
+ extern BLACBUFF BI_AuxBuff, *BI_ActiveQ;
+
+ MGetConTxt(Mpval(ConTxt), ctxt);
+#if (BlacsDebugLvl > 0)
+ BI_ArgCheck(Mpval(ConTxt), RT_RV, __FILE__, 'a', 'u', 'u', Mpval(m),
+ Mpval(n), Mpval(lda), 1, Mpaddress(rsrc), Mpaddress(csrc));
+#endif
+ if (Mpval(lda) < Mpval(m)) tlda = Mpval(m);
+ else tlda = Mpval(lda);
+ ctxt->scp = &ctxt->pscp;
+
+ MatTyp = BI_GetMpiGeType(ctxt, Mpval(m), Mpval(n), tlda,
+ MPI_DOUBLE_COMPLEX, &BI_AuxBuff.N);
+ BI_AuxBuff.Buff = (char *) A;
+ BI_AuxBuff.dtype = MatTyp;
+ BI_Srecv(ctxt, Mkpnum(ctxt, Mpval(rsrc), Mpval(csrc)), PT2PTID, &BI_AuxBuff);
+ ierr=BI_MPI_TYPE_FREE(&MatTyp);
+ if (BI_ActiveQ) BI_UpdateBuffs(NULL);
+}
diff --git a/BLACS/SRC/zgesd2d_.c b/BLACS/SRC/zgesd2d_.c
new file mode 100644
index 0000000..3dec847
--- /dev/null
+++ b/BLACS/SRC/zgesd2d_.c
@@ -0,0 +1,95 @@
+#include "Bdef.h"
+
+#if (INTFACE == C_CALL)
+void Czgesd2d(int ConTxt, int m, int n, double *A, int lda,
+ int rdest, int cdest)
+#else
+F_VOID_FUNC zgesd2d_(int *ConTxt, int *m, int *n, double *A, int *lda,
+ int *rdest, int *cdest)
+#endif
+/*
+ * -- V1.1 BLACS routine --
+ * University of Tennessee, May 1, 1996
+ * Written by Clint Whaley.
+ *
+ * Purpose
+ * =======
+ * Locally-blocking point-to-point general double complex send.
+ *
+ * Arguments
+ * =========
+ *
+ * ConTxt (input) Ptr to int
+ * Index into MyConTxts00 (my contexts array).
+ *
+ * M (input) Ptr to int
+ * The number of rows of the matrix A. M >= 0.
+ *
+ * N (input) Ptr to int
+ * The number of columns of the matrix A. N >= 0.
+ *
+ * A (input) Ptr to double complex two dimensional array
+ * The m by n matrix A. Fortran77 (column-major) storage
+ * assumed.
+ *
+ * LDA (input) Ptr to int
+ * The leading dimension of the array A. LDA >= M.
+ *
+ * RDEST (input) Ptr to int
+ * The process row of the destination process.
+ *
+ * CDEST (input) Ptr to int
+ * The process column of the destination process.
+ *
+ * ------------------------------------------------------------------------
+ */
+{
+ void BI_ArgCheck(int, int, char *, char, char, char, int, int, int, int,
+ int *, int *);
+ MPI_Datatype BI_GetMpiGeType(BLACSCONTEXT *, int, int, int,
+ MPI_Datatype, int *);
+ BLACBUFF *BI_Pack(BLACSCONTEXT *, BVOID *, BLACBUFF *, MPI_Datatype);
+ void BI_Ssend(BLACSCONTEXT *, int, int, BLACBUFF *);
+ void BI_Asend(BLACSCONTEXT *, int, int, BLACBUFF *);
+ void BI_UpdateBuffs(BLACBUFF *);
+ BLACBUFF *BI_GetBuff(int);
+ int BI_BuffIsFree(BLACBUFF *, int);
+
+ int dest, tlda, ierr;
+ BLACBUFF *bp;
+ BLACSCONTEXT *ctxt;
+ MPI_Datatype MatTyp;
+ extern BLACBUFF BI_AuxBuff, *BI_ActiveQ;
+
+ MGetConTxt(Mpval(ConTxt), ctxt);
+#if (BlacsDebugLvl > 0)
+ BI_ArgCheck(Mpval(ConTxt), RT_SD, "ZGESD2D", 'a', 'u', 'u', Mpval(m),
+ Mpval(n), Mpval(lda), 1, Mpaddress(rdest), Mpaddress(cdest));
+#endif
+ if (Mpval(lda) < Mpval(m)) tlda = Mpval(m);
+ else tlda = Mpval(lda);
+ dest = Mvkpnum(ctxt, Mpval(rdest), Mpval(cdest));
+ ctxt->scp = &ctxt->pscp;
+
+ MatTyp = BI_GetMpiGeType(ctxt, Mpval(m), Mpval(n), tlda,
+ MPI_DOUBLE_COMPLEX, &BI_AuxBuff.N);
+#ifdef SndIsLocBlk
+ BI_AuxBuff.Buff = (char *) A;
+ BI_AuxBuff.dtype = MatTyp;
+ BI_Ssend(ctxt, dest, PT2PTID, &BI_AuxBuff);
+#else
+ bp = BI_Pack(ctxt, (BVOID *) A, NULL, MatTyp);
+ BI_Asend(ctxt, Mkpnum(ctxt, Mpval(rdest), Mpval(cdest)), PT2PTID, bp);
+#endif
+ ierr=BI_MPI_TYPE_FREE(&MatTyp);
+
+/*
+ * Having started the async send, update the buffers (reform links, check if
+ * active buffers have become inactive, etc.)
+ */
+#ifdef SndIsLocBlk
+ if (BI_ActiveQ) BI_UpdateBuffs(NULL);
+#else
+ BI_UpdateBuffs(bp);
+#endif
+} /* end of zgesd2d */
diff --git a/BLACS/SRC/zgsum2d_.c b/BLACS/SRC/zgsum2d_.c
new file mode 100644
index 0000000..a8814b4
--- /dev/null
+++ b/BLACS/SRC/zgsum2d_.c
@@ -0,0 +1,240 @@
+#include "Bdef.h"
+
+
+#if (INTFACE == C_CALL)
+void Czgsum2d(int ConTxt, char *scope, char *top, int m, int n, double *A,
+ int lda, int rdest, int cdest)
+#else
+F_VOID_FUNC zgsum2d_(int *ConTxt, F_CHAR scope, F_CHAR top, int *m, int *n,
+ double *A, int *lda, int *rdest, int *cdest)
+#endif
+/*
+ * -- V1.1 BLACS routine --
+ * University of Tennessee, May 1, 1996
+ * Written by Clint Whaley.
+ *
+ * Purpose
+ * =======
+ * Combine sum operation for double complex rectangular matrices.
+ *
+ * Arguments
+ * =========
+ *
+ * ConTxt (input) Ptr to int
+ * Index into MyConTxts00 (my contexts array).
+ *
+ * SCOPE (input) Ptr to char
+ * Limit the scope of the operation.
+ * = 'R' : Operation is performed by a process row.
+ * = 'C' : Operation is performed by a process column.
+ * = 'A' : Operation is performed by all processes in grid.
+ *
+ * TOP (input) Ptr to char
+ * Controls fashion in which messages flow within the operation.
+ *
+ * M (input) Ptr to int
+ * The number of rows of the matrix A. M >= 0.
+ *
+ * N (input) Ptr to int
+ * The number of columns of the matrix A. N >= 0.
+ *
+ * A (output) Ptr to double complex two dimensional array
+ * The m by n matrix A. Fortran77 (column-major) storage
+ * assumed.
+ *
+ * LDA (input) Ptr to int
+ * The leading dimension of the array A. LDA >= M.
+ *
+ * RDEST (input) Ptr to int
+ * The process row of the destination of the sum.
+ * If rdest == -1, then result is left on all processes in scope.
+ *
+ * CDEST (input) Ptr to int
+ * The process column of the destination of the sum.
+ * If rdest == -1, then CDEST ignored.
+ *
+ * ------------------------------------------------------------------------
+ */
+{
+ void BI_ArgCheck(int, int, char *, char, char, char, int, int, int, int,
+ int *, int *);
+ void BI_UpdateBuffs(BLACBUFF *);
+ BLACBUFF *BI_GetBuff(int);
+ int BI_BuffIsFree(BLACBUFF *, int);
+ MPI_Datatype BI_GetMpiGeType(BLACSCONTEXT *, int, int, int,
+ MPI_Datatype, int *);
+ BLACBUFF *BI_Pack(BLACSCONTEXT *, BVOID *, BLACBUFF *, MPI_Datatype);
+ MPI_Datatype BI_GetMpiGeType(BLACSCONTEXT *, int, int, int,
+ MPI_Datatype, int *);
+ void BI_Unpack(BLACSCONTEXT *, BVOID *, BLACBUFF *, MPI_Datatype);
+ void BI_MringComb(BLACSCONTEXT *, BLACBUFF *, BLACBUFF *, int, VVFUNPTR,
+ int, int);
+ void BI_TreeComb(BLACSCONTEXT *, BLACBUFF *, BLACBUFF *, int, VVFUNPTR,
+ int, int);
+ void BI_BeComb(BLACSCONTEXT *, BLACBUFF *, BLACBUFF *, int, VVFUNPTR);
+ void BI_zvvsum(int, char *, char *);
+ void BI_zMPI_sum(void *, void *, int *, MPI_Datatype *);
+/*
+ * Variable Declarations
+ */
+ BLACBUFF *bp, *bp2;
+ BLACSCONTEXT *ctxt;
+ char ttop, tscope;
+ int N, length, dest, tlda, trdest, ierr;
+ MPI_Op BlacComb;
+ extern BLACBUFF *BI_ActiveQ;
+ extern BLACBUFF BI_AuxBuff;
+
+ MGetConTxt(Mpval(ConTxt), ctxt);
+ ttop = F2C_CharTrans(top);
+ ttop = Mlowcase(ttop);
+ tscope = F2C_CharTrans(scope);
+ tscope = Mlowcase(tscope);
+/*
+ * If the user has set the default combine topology, use it instead of
+ * BLACS default
+ */
+#ifdef DefCombTop
+ if (ttop == ' ') ttop = DefCombTop;
+#endif
+ if (Mpval(cdest) == -1) trdest = -1;
+ else trdest = Mpval(rdest);
+#if (BlacsDebugLvl > 0)
+ BI_ArgCheck(Mpval(ConTxt), RT_COMB, __FILE__, tscope, 'u', 'u', Mpval(m),
+ Mpval(n), Mpval(lda), 1, &trdest, Mpaddress(cdest));
+#endif
+ if (Mpval(lda) >= Mpval(m)) tlda = Mpval(lda);
+ else tlda = Mpval(m);
+ switch(tscope)
+ {
+ case 'r':
+ ctxt->scp = &ctxt->rscp;
+ if (trdest == -1) dest = -1;
+ else dest = Mpval(cdest);
+ break;
+ case 'c':
+ ctxt->scp = &ctxt->cscp;
+ dest = trdest;
+ break;
+ case 'a':
+ ctxt->scp = &ctxt->ascp;
+ if (trdest == -1) dest = -1;
+ else dest = Mvkpnum(ctxt, trdest, Mpval(cdest));
+ break;
+ default:
+ BI_BlacsErr(Mpval(ConTxt), __LINE__, __FILE__, "Unknown scope '%c'",
+ tscope);
+ }
+
+
+/*
+ * It's not defined how MPI reacts to 0 element reductions, so use BLACS 1-tree
+ * topology if we've got one. Also, we can't use MPI functions if we need to
+ * guarantee repeatability.
+ */
+ if (ttop == ' ')
+ if ( (Mpval(m) < 1) || (Mpval(n) < 1) || (ctxt->TopsRepeat) ) ttop = '1';
+ N = Mpval(m) * Mpval(n);
+ length = N * sizeof(DCOMPLEX);
+/*
+ * If A is contiguous, we can use it as one of the buffers
+ */
+ if ( (Mpval(m) == tlda) || (Mpval(n) == 1) )
+ {
+ bp = &BI_AuxBuff;
+ bp->Buff = (char *) A;
+ bp2 = BI_GetBuff(length);
+ }
+/*
+ * Otherwise, we must allocate both buffers
+ */
+ else
+ {
+ bp = BI_GetBuff(length*2);
+ bp2 = &BI_AuxBuff;
+ bp2->Buff = &bp->Buff[length];
+ BI_zmvcopy(Mpval(m), Mpval(n), A, tlda, bp->Buff);
+ }
+ bp->dtype = bp2->dtype = MPI_DOUBLE_COMPLEX;
+ bp->N = bp2->N = N;
+
+ switch(ttop)
+ {
+ case ' ': /* use MPI's reduction by default */
+ length = 1;
+ ierr=MPI_Op_create(BI_zMPI_sum, length, &BlacComb);
+ if (dest != -1)
+ {
+ ierr=MPI_Reduce(bp->Buff, bp2->Buff, bp->N, bp->dtype, BlacComb,
+ dest, ctxt->scp->comm);
+ if (ctxt->scp->Iam == dest)
+ BI_zvmcopy(Mpval(m), Mpval(n), A, tlda, bp2->Buff);
+ }
+ else
+ {
+ ierr=MPI_Allreduce(bp->Buff, bp2->Buff, bp->N, bp->dtype, BlacComb,
+ ctxt->scp->comm);
+ BI_zvmcopy(Mpval(m), Mpval(n), A, tlda, bp2->Buff);
+ }
+ ierr=MPI_Op_free(&BlacComb);
+ if (BI_ActiveQ) BI_UpdateBuffs(NULL);
+ return;
+ break;
+ case 'i':
+ BI_MringComb(ctxt, bp, bp2, N, BI_zvvsum, dest, 1);
+ break;
+ case 'd':
+ BI_MringComb(ctxt, bp, bp2, N, BI_zvvsum, dest, -1);
+ break;
+ case 's':
+ BI_MringComb(ctxt, bp, bp2, N, BI_zvvsum, dest, 2);
+ break;
+ case 'm':
+ BI_MringComb(ctxt, bp, bp2, N, BI_zvvsum, dest, ctxt->Nr_co);
+ break;
+ case '1':
+ case '2':
+ case '3':
+ case '4':
+ case '5':
+ case '6':
+ case '7':
+ case '8':
+ case '9':
+ BI_TreeComb(ctxt, bp, bp2, N, BI_zvvsum, dest, ttop-47);
+ break;
+ case 'f':
+ BI_TreeComb(ctxt, bp, bp2, N, BI_zvvsum, dest, FULLCON);
+ break;
+ case 't':
+ BI_TreeComb(ctxt, bp, bp2, N, BI_zvvsum, dest, ctxt->Nb_co);
+ break;
+ case 'h':
+/*
+ * Use bidirectional exchange if everyone wants answer
+ */
+ if ( (trdest == -1) && !(ctxt->TopsCohrnt) )
+ BI_BeComb(ctxt, bp, bp2, N, BI_zvvsum);
+ else
+ BI_TreeComb(ctxt, bp, bp2, N, BI_zvvsum, dest, 2);
+ break;
+ default :
+ BI_BlacsErr(Mpval(ConTxt), __LINE__, __FILE__, "Unknown topology '%c'",
+ ttop);
+ }
+
+/*
+ * If I am selected to receive answer
+ */
+ if (bp != &BI_AuxBuff)
+ {
+ if ( (ctxt->scp->Iam == dest) || (dest == -1) )
+ BI_zvmcopy(Mpval(m), Mpval(n), A, tlda, bp->Buff);
+ BI_UpdateBuffs(bp);
+ }
+ else
+ {
+ if (BI_ActiveQ) BI_UpdateBuffs(NULL);
+ BI_BuffIsFree(bp, 1);
+ }
+}
diff --git a/BLACS/SRC/ztrbr2d_.c b/BLACS/SRC/ztrbr2d_.c
new file mode 100644
index 0000000..06771ab
--- /dev/null
+++ b/BLACS/SRC/ztrbr2d_.c
@@ -0,0 +1,224 @@
+#include "Bdef.h"
+
+#if (INTFACE == C_CALL)
+void Cztrbr2d(int ConTxt, char *scope, char *top, char *uplo, char *diag,
+ int m, int n, double *A, int lda, int rsrc, int csrc)
+#else
+F_VOID_FUNC ztrbr2d_(int *ConTxt, F_CHAR scope, F_CHAR top, F_CHAR uplo,
+ F_CHAR diag, int *m, int *n, double *A, int *lda,
+ int *rsrc, int *csrc)
+#endif
+/*
+ * -- V1.1 BLACS routine --
+ * University of Tennessee, May 1, 1996
+ * Written by Clint Whaley.
+ *
+ * Purpose
+ * =======
+ * Broadcast/receive for trapezoidal double complex arrays.
+ *
+ * Arguments
+ * =========
+ *
+ * ConTxt (input) Ptr to int
+ * Index into MyConTxts00 (my contexts array).
+ *
+ * SCOPE (input) Ptr to char
+ * Limit the scope of the operation.
+ * = 'R' : Operation is performed by a process row.
+ * = 'C' : Operation is performed by a process column.
+ * = 'A' : Operation is performed by all processes in grid.
+ *
+ * TOP (input) Ptr to char
+ * Controls fashion in which messages flow within the operation.
+ *
+ * UPLO (input) Ptr to char
+ * Specifies the part of the matrix to be sent.
+ * = 'U': Upper trapezoidal part
+ * ELSE : Lower trapezoidal part
+ *
+ * DIAG (input) Ptr to char
+ * Specifies whether the matrix is unit diagonal or not.
+ * = 'U': Matrix is unit diagonal, diagonal not communicated.
+ * ELSE : Matrix is not unit diagonal, diagonal is communicated.
+ *
+ * M (input) Ptr to int
+ * The number of rows of the matrix A. M >= 0.
+ *
+ * N (input) Ptr to int
+ * The number of columns of the matrix A. N >= 0.
+ *
+ * A (output) Ptr to double complex two dimensional array
+ * The m by n matrix A. Fortran77 (column-major) storage
+ * assumed.
+ * If UPLO = 'U', only the upper trapezoid is accessed;
+ * if UPLO = 'L', only the lower trapezoid is accessed.
+ *
+ * LDA (input) Ptr to int
+ * The leading dimension of the array A. LDA >= M.
+ *
+ *
+ * RSRC (input) Ptr to int
+ * The process row of the source of the matrix.
+ *
+ * CSRC (input) Ptr to int
+ * The process column of the source of the matrix.
+ *
+ *
+ * ------------------------------------------------------------------------
+ */
+{
+ void BI_ArgCheck(int, int, char *, char, char, char, int, int, int, int,
+ int *, int *);
+ int BI_HypBR(BLACSCONTEXT *, BLACBUFF *, SDRVPTR, int);
+ void BI_IdringBR(BLACSCONTEXT *, BLACBUFF *, SDRVPTR, int, int);
+ void BI_SringBR(BLACSCONTEXT *, BLACBUFF *, SDRVPTR, int);
+ void BI_MpathBR(BLACSCONTEXT *, BLACBUFF *, SDRVPTR, int, int);
+ void BI_TreeBR(BLACSCONTEXT *, BLACBUFF *, SDRVPTR, int, int);
+ void BI_UpdateBuffs(BLACBUFF *);
+ BLACBUFF *BI_GetBuff(int);
+ int BI_BuffIsFree(BLACBUFF *, int);
+ MPI_Datatype BI_GetMpiTrType(BLACSCONTEXT *, char, char, int, int, int,
+ MPI_Datatype, int *);
+ void BI_Unpack(BLACSCONTEXT *, BVOID *, BLACBUFF *, MPI_Datatype);
+ void BI_Ssend(BLACSCONTEXT *, int, int, BLACBUFF *);
+ void BI_Asend(BLACSCONTEXT *, int, int, BLACBUFF *);
+
+ BLACSCONTEXT *ctxt;
+ BLACBUFF *bp=NULL;
+ SDRVPTR send;
+ MPI_Datatype MatTyp;
+ int length, src, tlda, error, one=1;
+ char ttop, tscope, tuplo, tdiag;
+ extern BLACBUFF BI_AuxBuff, *BI_ActiveQ;
+
+ MGetConTxt(Mpval(ConTxt), ctxt);
+ ttop = F2C_CharTrans(top);
+ ttop = Mlowcase(ttop);
+ tscope = F2C_CharTrans(scope);
+ tscope = Mlowcase(tscope);
+ tdiag = F2C_CharTrans(diag);
+ tdiag = Mlowcase(tdiag);
+ tuplo = F2C_CharTrans(uplo);
+ tuplo = Mlowcase(tuplo);
+#if (BlacsDebugLvl > 0)
+ BI_ArgCheck(Mpval(ConTxt), RT_BR, __FILE__, tscope, tuplo, tdiag, Mpval(m),
+ Mpval(n), Mpval(lda), 1, Mpaddress(rsrc), Mpaddress(csrc));
+#endif
+/*
+ * If the user has set the default broadcast topology, use it instead of
+ * BLACS default
+ */
+#ifdef DefBSTop
+ if (ttop == ' ') ttop = DefBSTop;
+#endif
+ if (Mpval(m) <= Mpval(lda)) tlda = Mpval(lda);
+ else tlda = Mpval(m);
+
+ switch(tscope)
+ {
+ case 'r':
+ ctxt->scp = &ctxt->rscp;
+ src = Mpval(csrc);
+ break;
+ case 'c':
+ ctxt->scp = &ctxt->cscp;
+ src = Mpval(rsrc);
+ break;
+ case 'a':
+ ctxt->scp = &ctxt->ascp;
+ src = Mvkpnum(ctxt, Mpval(rsrc), Mpval(csrc));
+ break;
+ default:
+ BI_BlacsErr(Mpval(ConTxt), __LINE__, __FILE__, "Unknown scope '%c'",
+ tscope);
+ }
+
+ MatTyp = BI_GetMpiTrType(ctxt, tuplo, tdiag, Mpval(m), Mpval(n), tlda,
+ MPI_DOUBLE_COMPLEX, &BI_AuxBuff.N);
+/*
+ * If using default topology, use MPI native broadcast
+ */
+ if (ttop == ' ')
+ {
+ error=MPI_Bcast(A, BI_AuxBuff.N, MatTyp, src, ctxt->scp->comm);
+ error=BI_MPI_TYPE_FREE(&MatTyp);
+ if (BI_ActiveQ) BI_UpdateBuffs(NULL);
+ return;
+ }
+/*
+ * If MPI handles non-contiguous buffering well, always use MPI data types
+ * instead of packing
+ */
+#ifdef MpiBuffGood
+ send = BI_Ssend;
+ BI_AuxBuff.Buff = (char *) A;
+ BI_AuxBuff.dtype = MatTyp;
+ bp = &BI_AuxBuff;
+#else
+
+ send = BI_Asend;
+ MPI_Pack_size(one, MatTyp, ctxt->scp->comm, &length, error);
+ bp = BI_GetBuff(length);
+ bp->N = length;
+ bp->dtype = MPI_PACKED;
+#if ZeroByteTypeBug
+ if (MatTyp == MPI_BYTE)
+ {
+ send = BI_Ssend;
+ bp->N = 0;
+ bp->dtype = MPI_BYTE;
+ }
+#endif
+
+#endif
+
+ switch(ttop)
+ {
+ case 'h':
+ error = BI_HypBR(ctxt, bp, send, src);
+ if (error == NPOW2) BI_TreeBR(ctxt, bp, send, src, 2);
+ break;
+ case '1':
+ case '2':
+ case '3':
+ case '4':
+ case '5':
+ case '6':
+ case '7':
+ case '8':
+ case '9':
+ BI_TreeBR(ctxt, bp, send, src, ttop-47);
+ break;
+ case 't':
+ BI_TreeBR(ctxt, bp, send, src, ctxt->Nb_bs);
+ break;
+ case 'i':
+ BI_IdringBR(ctxt, bp, send, src, 1);
+ break;
+ case 'd':
+ BI_IdringBR(ctxt, bp, send, src, -1);
+ break;
+ case 's':
+ BI_SringBR(ctxt, bp, send, src);
+ break;
+ case 'm':
+ BI_MpathBR(ctxt, bp, send, src, ctxt->Nr_bs);
+ break;
+ case 'f':
+ BI_MpathBR(ctxt, bp, send, src, FULLCON);
+ break;
+ default :
+ BI_BlacsErr(Mpval(ConTxt), __LINE__, __FILE__, "Unknown topology '%c'",
+ ttop);
+ }
+
+#ifdef MpiBuffGood
+ error=BI_MPI_TYPE_FREE(&MatTyp);
+ if (BI_ActiveQ) BI_UpdateBuffs(NULL);
+#endif
+#ifndef MpiBuffGood
+ BI_Unpack(ctxt, (BVOID *) A, bp, MatTyp);
+ BI_UpdateBuffs(bp);
+#endif
+}
diff --git a/BLACS/SRC/ztrbs2d_.c b/BLACS/SRC/ztrbs2d_.c
new file mode 100644
index 0000000..b911773
--- /dev/null
+++ b/BLACS/SRC/ztrbs2d_.c
@@ -0,0 +1,206 @@
+#include "Bdef.h"
+
+#if (INTFACE == C_CALL)
+void Cztrbs2d(int ConTxt, char *scope, char *top, char *uplo, char *diag,
+ int m, int n, double *A, int lda)
+#else
+F_VOID_FUNC ztrbs2d_(int *ConTxt, F_CHAR scope, F_CHAR top, F_CHAR uplo,
+ F_CHAR diag, int *m, int *n, double *A, int *lda)
+#endif
+/*
+ * -- V1.1 BLACS routine --
+ * University of Tennessee, May 1, 1996
+ * Written by Clint Whaley.
+ *
+ * Purpose
+ * =======
+ * Broadcast/send for trapezoidal double complex arrays.
+ *
+ * Arguments
+ * =========
+ *
+ * ConTxt (input) Ptr to int
+ * Index into MyConTxts00 (my contexts array).
+ *
+ * SCOPE (input) Ptr to char
+ * Limit the scope of the operation.
+ * = 'R' : Operation is performed by a process row.
+ * = 'C' : Operation is performed by a process column.
+ * = 'A' : Operation is performed by all processes in grid.
+ *
+ * TOP (input) Ptr to char
+ * Controls fashion in which messages flow within the operation.
+ *
+ * UPLO (input) Ptr to char
+ * Specifies the part of the matrix to be sent.
+ * = 'U': Upper trapezoidal part
+ * ELSE : Lower trapezoidal part
+ *
+ * DIAG (input) Ptr to char
+ * Specifies whether the matrix is unit diagonal or not.
+ * = 'U': Matrix is unit diagonal, diagonal not communicated.
+ * ELSE : Matrix is not unit diagonal, diagonal is communicated.
+ *
+ * M (input) Ptr to int
+ * The number of rows of the matrix A. M >= 0.
+ *
+ * N (input) Ptr to int
+ * The number of columns of the matrix A. N >= 0.
+ *
+ * A (input) Ptr to double complex two dimensional array
+ * The m by n matrix A. Fortran77 (column-major) storage
+ * assumed.
+ * If UPLO = 'U', only the upper trapezoid is accessed;
+ * if UPLO = 'L', only the lower trapezoid is accessed.
+ *
+ * LDA (input) Ptr to int
+ * The leading dimension of the array A. LDA >= M.
+ *
+ * ------------------------------------------------------------------------
+ */
+{
+ void BI_ArgCheck(int, int, char *, char, char, char, int, int, int, int,
+ int *, int *);
+ int BI_HypBS(BLACSCONTEXT *, BLACBUFF *, SDRVPTR);
+ void BI_IdringBS(BLACSCONTEXT *, BLACBUFF *, SDRVPTR, int);
+ void BI_SringBS(BLACSCONTEXT *, BLACBUFF *, SDRVPTR);
+ void BI_MpathBS(BLACSCONTEXT *, BLACBUFF *, SDRVPTR, int);
+ void BI_TreeBS(BLACSCONTEXT *, BLACBUFF *, SDRVPTR, int);
+ void BI_UpdateBuffs(BLACBUFF *);
+ BLACBUFF *BI_GetBuff(int);
+ int BI_BuffIsFree(BLACBUFF *, int);
+ MPI_Datatype BI_GetMpiTrType(BLACSCONTEXT *, char, char, int, int, int,
+ MPI_Datatype, int *);
+ BLACBUFF *BI_Pack(BLACSCONTEXT *, BVOID *, BLACBUFF *, MPI_Datatype);
+ void BI_Ssend(BLACSCONTEXT *, int, int, BLACBUFF *);
+ void BI_Asend(BLACSCONTEXT *, int, int, BLACBUFF *);
+
+ char ttop, tscope, tuplo, tdiag;
+ int error, tlda;
+ MPI_Datatype MatTyp;
+ SDRVPTR send;
+ BLACBUFF *bp;
+ BLACSCONTEXT *ctxt;
+ extern BLACBUFF BI_AuxBuff, *BI_ActiveQ;
+/*
+ * get context, lowcase char variables, and perform parameter checking
+ */
+ MGetConTxt(Mpval(ConTxt), ctxt);
+ ttop = F2C_CharTrans(top);
+ ttop = Mlowcase(ttop);
+ tscope = F2C_CharTrans(scope);
+ tscope = Mlowcase(tscope);
+ tuplo = F2C_CharTrans(uplo);
+ tuplo = Mlowcase(tuplo);
+ tdiag = F2C_CharTrans(diag);
+ tdiag = Mlowcase(tdiag);
+#if (BlacsDebugLvl > 0)
+ BI_ArgCheck(Mpval(ConTxt), RT_BS, __FILE__, 'a', tuplo, tdiag, Mpval(m),
+ Mpval(n), Mpval(lda), 0, NULL, NULL);
+#endif
+/*
+ * If the user has set the default broadcast topology, use it instead of
+ * BLACS default
+ */
+#ifdef DefBSTop
+ if (ttop == ' ') ttop = DefBSTop;
+#endif
+ if (Mpval(lda) < Mpval(m)) tlda = Mpval(m);
+ else tlda = Mpval(lda);
+
+ switch(tscope)
+ {
+ case 'r':
+ ctxt->scp = &ctxt->rscp;
+ break;
+ case 'c':
+ ctxt->scp = &ctxt->cscp;
+ break;
+ case 'a':
+ ctxt->scp = &ctxt->ascp;
+ break;
+ default:
+ BI_BlacsErr(Mpval(ConTxt), __LINE__, __FILE__, "Unknown scope '%c'",
+ tscope);
+ }
+ MatTyp = BI_GetMpiTrType(ctxt, tuplo, tdiag, Mpval(m), Mpval(n), tlda,
+ MPI_DOUBLE_COMPLEX, &BI_AuxBuff.N);
+/*
+ * If using default topology, use MPI native broadcast
+ */
+ if (ttop == ' ')
+ {
+ error=MPI_Bcast(A, BI_AuxBuff.N, MatTyp, ctxt->scp->Iam, ctxt->scp->comm);
+ error=BI_MPI_TYPE_FREE(&MatTyp);
+ if (BI_ActiveQ) BI_UpdateBuffs(NULL);
+ return;
+ }
+/*
+ * If MPI handles non-contiguous buffering well, always use MPI data types
+ * instead of packing
+ */
+#ifdef MpiBuffGood
+ send = BI_Ssend;
+ BI_AuxBuff.Buff = (char *) A;
+ BI_AuxBuff.dtype = MatTyp;
+ bp = &BI_AuxBuff;
+#endif
+/*
+ * Pack and use non-blocking sends for broadcast if MPI's data types aren't
+ * more efficient
+ */
+#ifndef MpiBuffGood
+ send = BI_Asend;
+ bp = BI_Pack(ctxt, (BVOID *) A, NULL, MatTyp);
+#endif
+
+/*
+ * Call correct topology for BS/BR
+ */
+ switch(ttop)
+ {
+ case 'h':
+ error = BI_HypBS(ctxt, bp, send);
+ if (error == NPOW2) BI_TreeBS(ctxt, bp, send, 2);
+ break;
+ case '1':
+ case '2':
+ case '3':
+ case '4':
+ case '5':
+ case '6':
+ case '7':
+ case '8':
+ case '9':
+ BI_TreeBS(ctxt, bp, send, ttop-47);
+ break;
+ case 't':
+ BI_TreeBS(ctxt, bp, send, ctxt->Nb_bs);
+ break;
+ case 'i':
+ BI_IdringBS(ctxt, bp, send, 1);
+ break;
+ case 'd':
+ BI_IdringBS(ctxt, bp, send, -1);
+ break;
+ case 's':
+ BI_SringBS(ctxt, bp, send);
+ break;
+ case 'f':
+ BI_MpathBS(ctxt, bp, send, FULLCON);
+ break;
+ case 'm':
+ BI_MpathBS(ctxt, bp, send, ctxt->Nr_bs);
+ break;
+ default :
+ BI_BlacsErr(Mpval(ConTxt), __LINE__, __FILE__, "Unknown topology '%c'",
+ ttop);
+ }
+
+ error=BI_MPI_TYPE_FREE(&MatTyp);
+ if (bp == &BI_AuxBuff)
+ {
+ if (BI_ActiveQ) BI_UpdateBuffs(NULL);
+ }
+ else BI_UpdateBuffs(bp);
+} /* end ztrbs2d_ */
diff --git a/BLACS/SRC/ztrrv2d_.c b/BLACS/SRC/ztrrv2d_.c
new file mode 100644
index 0000000..95ca9a6
--- /dev/null
+++ b/BLACS/SRC/ztrrv2d_.c
@@ -0,0 +1,101 @@
+#include "Bdef.h"
+
+#if (INTFACE == C_CALL)
+void Cztrrv2d(int ConTxt, char *uplo, char *diag, int m, int n, double *A,
+ int lda, int rsrc, int csrc)
+#else
+F_VOID_FUNC ztrrv2d_(int *ConTxt, F_CHAR uplo, F_CHAR diag, int *m, int *n,
+ double *A, int *lda, int *rsrc, int *csrc)
+#endif
+/*
+ * -- V1.1 BLACS routine --
+ * University of Tennessee, May 1, 1996
+ * Written by Clint Whaley.
+ *
+ * Purpose
+ * =======
+ * Globally-blocking point to point trapezoidal double complex receive.
+ *
+ * Arguments
+ * =========
+ *
+ * ConTxt (input) Ptr to int
+ * Index into MyConTxts00 (my contexts array).
+ *
+ * UPLO (input) Ptr to char
+ * Specifies the part of the matrix to be sent.
+ * = 'U': Upper trapezoidal part
+ * ELSE : Lower trapezoidal part
+ *
+ * DIAG (input) Ptr to char
+ * Specifies whether the matrix is unit diagonal or not.
+ * = 'U': Matrix is unit diagonal, diagonal not communicated.
+ * ELSE : Matrix is not unit diagonal, diagonal is communicated.
+ *
+ * M (input) Ptr to int
+ * The number of rows of the matrix A. M >= 0.
+ *
+ * N (input) Ptr to int
+ * The number of columns of the matrix A. N >= 0.
+ *
+ * A (output) Ptr to double complex two dimensional array
+ * The m by n matrix A. Fortran77 (column-major) storage
+ * assumed.
+ * If UPLO = 'U', only the upper trapezoid is accessed;
+ * if UPLO = 'L', only the lower trapezoid is accessed.
+ *
+ * LDA (input) Ptr to int
+ * The leading dimension of the array A. LDA >= M.
+ *
+ *
+ * RSRC (input) Ptr to int
+ * The process row of the source of the matrix.
+ *
+ * CSRC (input) Ptr to int
+ * The process column of the source of the matrix.
+ *
+ *
+ * ------------------------------------------------------------------------
+ */
+{
+/*
+ * Prototypes and variable declarations
+ */
+ void BI_ArgCheck(int, int, char *, char, char, char, int, int, int, int,
+ int *, int *);
+ MPI_Datatype BI_GetMpiTrType(BLACSCONTEXT *, char, char, int, int, int,
+ MPI_Datatype, int *);
+ void BI_Unpack(BLACSCONTEXT *, BVOID *, BLACBUFF *, MPI_Datatype);
+ void BI_Srecv(BLACSCONTEXT *, int, int, BLACBUFF *);
+ void BI_UpdateBuffs(BLACBUFF *);
+ BLACBUFF *BI_GetBuff(int);
+ int BI_BuffIsFree(BLACBUFF *, int);
+ int tuplo, tdiag, tlda;
+ int ierr, length;
+ BLACBUFF *bp;
+ MPI_Datatype MatTyp;
+ BLACSCONTEXT *ctxt;
+ extern BLACBUFF BI_AuxBuff, *BI_ActiveQ;
+
+ MGetConTxt(Mpval(ConTxt), ctxt);
+ tdiag = F2C_CharTrans(diag);
+ tuplo = F2C_CharTrans(uplo);
+ tdiag = Mlowcase(tdiag);
+ tuplo = Mlowcase(tuplo);
+
+#if (BlacsDebugLvl > 0)
+ BI_ArgCheck(Mpval(ConTxt), RT_RV, __FILE__, 'a', tuplo, tdiag, Mpval(m),
+ Mpval(n), Mpval(lda), 1, Mpaddress(rsrc), Mpaddress(csrc));
+#endif
+ if (Mpval(lda) < Mpval(m)) tlda = Mpval(m);
+ else tlda = Mpval(lda);
+ ctxt->scp = &ctxt->pscp;
+
+ MatTyp = BI_GetMpiTrType(ctxt, tuplo, tdiag, Mpval(m), Mpval(n), tlda,
+ MPI_DOUBLE_COMPLEX, &BI_AuxBuff.N);
+ BI_AuxBuff.Buff = (char *) A;
+ BI_AuxBuff.dtype = MatTyp;
+ BI_Srecv(ctxt, Mkpnum(ctxt, Mpval(rsrc), Mpval(csrc)), PT2PTID, &BI_AuxBuff);
+ ierr=BI_MPI_TYPE_FREE(&MatTyp);
+ if (BI_ActiveQ) BI_UpdateBuffs(NULL);
+}
diff --git a/BLACS/SRC/ztrsd2d_.c b/BLACS/SRC/ztrsd2d_.c
new file mode 100644
index 0000000..b71af0c
--- /dev/null
+++ b/BLACS/SRC/ztrsd2d_.c
@@ -0,0 +1,113 @@
+#include "Bdef.h"
+
+#if (INTFACE == C_CALL)
+void Cztrsd2d(int ConTxt, char *uplo, char *diag, int m, int n, double *A,
+ int lda, int rdest, int cdest)
+#else
+F_VOID_FUNC ztrsd2d_(int *ConTxt, F_CHAR uplo, F_CHAR diag, int *m, int *n,
+ double *A, int *lda, int *rdest, int *cdest)
+#endif
+/*
+ * -- V1.1 BLACS routine --
+ * University of Tennessee, May 1, 1996
+ * Written by Clint Whaley.
+ *
+ * Purpose
+ * =======
+ * Locally-blocking point-to-point trapezoidal double complex send.
+ *
+ * Arguments
+ * =========
+ *
+ * ConTxt (input) Ptr to int
+ * Index into MyConTxts00 (my contexts array).
+ *
+ * UPLO (input) Ptr to char
+ * Specifies the part of the matrix to be sent.
+ * = 'U': Upper trapezoidal part
+ * ELSE : Lower trapezoidal part
+ *
+ * DIAG (input) Ptr to char
+ * Specifies whether the matrix is unit diagonal or not.
+ * = 'U': Matrix is unit diagonal, diagonal not communicated.
+ * ELSE : Matrix is not unit diagonal, diagonal is communicated.
+ *
+ * M (input) Ptr to int
+ * The number of rows of the matrix A. M >= 0.
+ *
+ * N (input) Ptr to int
+ * The number of columns of the matrix A. N >= 0.
+ *
+ * A (input) Ptr to double complex two dimensional array
+ * The m by n matrix A. Fortran77 (column-major) storage
+ * assumed.
+ * If UPLO = 'U', only the upper trapezoid is accessed;
+ * if UPLO = 'L', only the lower trapezoid is accessed.
+ *
+ * LDA (input) Ptr to int
+ * The leading dimension of the array A. LDA >= M.
+ *
+ * RDEST (input) Ptr to int
+ * The process row of the destination process.
+ *
+ * CDEST (input) Ptr to int
+ * The process column of the destination process.
+ *
+ * ------------------------------------------------------------------------
+ */
+{
+ void BI_ArgCheck(int, int, char *, char, char, char, int, int, int, int,
+ int *, int *);
+ MPI_Datatype BI_GetMpiTrType(BLACSCONTEXT *, char, char, int, int, int,
+ MPI_Datatype, int *);
+ BLACBUFF *BI_Pack(BLACSCONTEXT *, BVOID *, BLACBUFF *, MPI_Datatype);
+ void BI_Ssend(BLACSCONTEXT *, int, int, BLACBUFF *);
+ void BI_Asend(BLACSCONTEXT *, int, int, BLACBUFF *);
+ void BI_UpdateBuffs(BLACBUFF *);
+ BLACBUFF *BI_GetBuff(int);
+ int BI_BuffIsFree(BLACBUFF *, int);
+
+ char tuplo, tdiag;
+ int dest, length, tlda, ierr;
+ BLACBUFF *bp;
+ BLACSCONTEXT *ctxt;
+ MPI_Datatype MatTyp;
+ extern BLACBUFF BI_AuxBuff, *BI_ActiveQ;
+
+ MGetConTxt(Mpval(ConTxt), ctxt);
+ tuplo = F2C_CharTrans(uplo);
+ tdiag = F2C_CharTrans(diag);
+ tuplo = Mlowcase(tuplo);
+ tdiag = Mlowcase(tdiag);
+
+#if (BlacsDebugLvl > 0)
+ BI_ArgCheck(Mpval(ConTxt), RT_SD, "ZTRSD2D", 'a', tuplo, tdiag, Mpval(m),
+ Mpval(n), Mpval(lda), 1, Mpaddress(rdest), Mpaddress(cdest));
+#endif
+ if (Mpval(lda) < Mpval(m)) tlda = Mpval(m);
+ else tlda = Mpval(lda);
+ dest = Mvkpnum(ctxt, Mpval(rdest), Mpval(cdest));
+ ctxt->scp = &ctxt->pscp;
+
+ MatTyp = BI_GetMpiTrType(ctxt, tuplo, tdiag, Mpval(m), Mpval(n), tlda,
+ MPI_DOUBLE_COMPLEX, &BI_AuxBuff.N);
+#ifdef SndIsLocBlk
+ BI_AuxBuff.Buff = (char *) A;
+ BI_AuxBuff.dtype = MatTyp;
+ BI_Ssend(ctxt, dest, PT2PTID, &BI_AuxBuff);
+#else
+ bp = BI_Pack(ctxt, (BVOID *) A, NULL, MatTyp);
+ BI_Asend(ctxt, Mkpnum(ctxt, Mpval(rdest), Mpval(cdest)), PT2PTID, bp);
+#endif
+ ierr=BI_MPI_TYPE_FREE(&MatTyp);
+
+/*
+ * Having started the async send, update the buffers (reform links, check if
+ * active buffers have become inactive, etc.)
+ */
+#ifdef SndIsLocBlk
+ if (BI_ActiveQ) BI_UpdateBuffs(NULL);
+#else
+ BI_UpdateBuffs(bp);
+#endif
+} /* end of ztrsd2d */
diff --git a/BLACS/TESTING/CMakeLists.txt b/BLACS/TESTING/CMakeLists.txt
new file mode 100644
index 0000000..d8846b5
--- /dev/null
+++ b/BLACS/TESTING/CMakeLists.txt
@@ -0,0 +1,49 @@
+set(FTestObj
+ blacstest.f btprim.f tools.f)
+
+add_executable(xFbtest ${FTestObj})
+target_link_libraries(xFbtest scalapack)
+
+set(CTestObj
+ Cbt.c)
+
+set_property(
+ SOURCE Cbt.c
+ APPEND PROPERTY COMPILE_DEFINITIONS BTCINTFACE
+ )
+
+add_executable(xCbtest ${CTestObj} ${FTestObj})
+target_link_libraries(xCbtest scalapack)
+
+file(COPY bsbr.dat DESTINATION ${SCALAPACK_BINARY_DIR}/BLACS/TESTING)
+file(COPY bt.dat DESTINATION ${SCALAPACK_BINARY_DIR}/BLACS/TESTING)
+file(COPY comb.dat DESTINATION ${SCALAPACK_BINARY_DIR}/BLACS/TESTING)
+file(COPY sdrv.dat DESTINATION ${SCALAPACK_BINARY_DIR}/BLACS/TESTING)
+
+# We could run the BLACS TESTING the following way
+# But BLACS TESTING are TESTING anormal exit so even if they pass,
+# CTest will determine they fail
+#add_test(xFbtest0 ${MPIEXEC} ${MPIEXEC_NUMPROC_FLAG} 4 ./xFbtest)
+#add_test(xCbtest0 ${MPIEXEC} ${MPIEXEC_NUMPROC_FLAG} 4 ./xCbtest)
+
+add_test(xCbtest
+ ${CMAKE_COMMAND}
+ -DMPIEXEC=${MPIEXEC}
+ -DMPIEXEC_NUMPROC_FLAG=${MPIEXEC_NUMPROC_FLAG}
+ -DTEST_PROG=xCbtest
+ -DOUTPUTDIR=${SCALAPACK_BINARY_DIR}/BLACS/TESTING
+ -DRUNTIMEDIR=${CMAKE_RUNTIME_OUTPUT_DIRECTORY}
+ -DSOURCEDIR=${CMAKE_CURRENT_SOURCE_DIR}
+ -P ${CMAKE_CURRENT_SOURCE_DIR}/runtest.cmake
+ )
+
+add_test(xFbtest
+ ${CMAKE_COMMAND}
+ -DMPIEXEC=${MPIEXEC}
+ -DMPIEXEC_NUMPROC_FLAG=${MPIEXEC_NUMPROC_FLAG}
+ -DTEST_PROG=xFbtest
+ -DOUTPUTDIR=${SCALAPACK_BINARY_DIR}/BLACS/TESTING
+ -DRUNTIMEDIR=${CMAKE_RUNTIME_OUTPUT_DIRECTORY}
+ -DSOURCEDIR=${CMAKE_CURRENT_SOURCE_DIR}
+ -P ${CMAKE_CURRENT_SOURCE_DIR}/runtest.cmake
+ )
\ No newline at end of file
diff --git a/BLACS/TESTING/Cbt.c b/BLACS/TESTING/Cbt.c
new file mode 100644
index 0000000..138786b
--- /dev/null
+++ b/BLACS/TESTING/Cbt.c
@@ -0,0 +1,973 @@
+#ifdef BTCINTFACE
+#include "Cbt.h"
+
+void blacs_gridinit_(ConTxt, order, nprow, npcol)
+int *ConTxt;
+char *order;
+int *nprow;
+int *npcol;
+{
+ void Cblacs_gridinit();
+
+ Cblacs_gridinit(ConTxt, order, *nprow, *npcol);
+}
+
+void blacs_setup_(mypnum, nprocs)
+int *mypnum;
+int *nprocs;
+{
+ void Cblacs_setup();
+ Cblacs_setup(mypnum, nprocs);
+}
+
+void blacs_pinfo_(mypnum, nprocs)
+int *mypnum;
+int *nprocs;
+{
+ void Cblacs_pinfo();
+ Cblacs_pinfo(mypnum, nprocs);
+}
+
+void blacs_gridmap_(ConTxt, usermap, ldup, nprow, npcol)
+int *ConTxt;
+int *usermap;
+int *ldup;
+int *nprow;
+int *npcol;
+{
+ void Cblacs_gridmap();
+ Cblacs_gridmap(ConTxt, usermap, *ldup, *nprow, *npcol);
+}
+
+void blacs_gridexit_(ConTxt)
+int *ConTxt;
+{
+ void Cblacs_gridexit();
+ Cblacs_gridexit(*ConTxt);
+}
+
+void blacs_abort_(ConTxt, ErrNo)
+int *ConTxt;
+int *ErrNo;
+{
+ void Cblacs_abort();
+ Cblacs_abort(*ConTxt, *ErrNo);
+}
+
+void blacs_exit_(NotDone)
+int *NotDone;
+{
+ void Cblacs_exit();
+ Cblacs_exit(*NotDone);
+}
+
+void blacs_freebuff_(ConTxt, Wait)
+int *ConTxt;
+int *Wait;
+{
+ void Cblacs_freebuff();
+ Cblacs_freebuff(*ConTxt, *Wait);
+}
+
+void blacs_gridinfo_(ConTxt, nprow, npcol, myrow, mycol)
+int *ConTxt;
+int *nprow;
+int *npcol;
+int *myrow;
+int *mycol;
+{
+ void Cblacs_gridinfo();
+ Cblacs_gridinfo(*ConTxt, nprow, npcol, myrow, mycol);
+}
+
+void blacs_barrier_(ConTxt, scope)
+int *ConTxt;
+char *scope;
+{
+ void Cblacs_barrier();
+ Cblacs_barrier(*ConTxt, scope);
+}
+
+int blacs_pnum_(ConTxt, prow, pcol)
+int *ConTxt;
+int *prow;
+int *pcol;
+{
+ int Cblacs_pnum();
+ return( Cblacs_pnum(*ConTxt, *prow, *pcol) );
+}
+
+void blacs_pcoord_(ConTxt, nodenum, prow, pcol)
+int *ConTxt;
+int *nodenum;
+int *prow;
+int *pcol;
+{
+ void Cblacs_pcoord();
+ Cblacs_pcoord(*ConTxt, *nodenum, prow, pcol);
+}
+
+void blacs_get_(ConTxt, what, I)
+int *ConTxt;
+int *what;
+int *I;
+{
+ void Cblacs_get();
+ Cblacs_get(*ConTxt, *what, I);
+}
+
+void blacs_set_(ConTxt, what, I)
+int *ConTxt;
+int *what;
+int *I;
+{
+ void Cblacs_set();
+ Cblacs_set(*ConTxt, *what, I);
+}
+
+
+void igesd2d_(ConTxt, m, n, A, lda, rdest, cdest)
+int *ConTxt;
+int *m;
+int *n;
+int *A;
+int *lda;
+int *rdest;
+int *cdest;
+{
+ void Cigesd2d();
+ Cigesd2d(*ConTxt, *m, *n, A, *lda, *rdest, *cdest);
+}
+
+void igerv2d_(ConTxt, m, n, A, lda, rsrc, csrc)
+int *ConTxt;
+int *m;
+int *n;
+int *A;
+int *lda;
+int *rsrc;
+int *csrc;
+{
+ void Cigerv2d();
+ Cigerv2d(*ConTxt, *m, *n, A, *lda, *rsrc, *csrc);
+}
+
+void igebs2d_(ConTxt, scope, top, m, n, A, lda)
+int *ConTxt;
+char *scope;
+char *top;
+int *m;
+int *n;
+int *A;
+int *lda;
+{
+ void Cigebs2d();
+ Cigebs2d(*ConTxt, scope, top, *m, *n, A, *lda);
+}
+
+void igebr2d_(ConTxt, scope, top, m, n, A, lda, rsrc, csrc)
+int *ConTxt;
+char *scope;
+char *top;
+int *m;
+int *n;
+int *A;
+int *lda;
+int *rsrc;
+int *csrc;
+{
+ void Cigebr2d();
+ Cigebr2d(*ConTxt, scope, top, *m, *n, A, *lda, *rsrc, *csrc);
+}
+
+void itrsd2d_(ConTxt, uplo, diag, m, n, A, lda, rdest, cdest)
+int *ConTxt;
+char *uplo;
+char *diag;
+int *m;
+int *n;
+int *A;
+int *lda;
+int *rdest;
+int *cdest;
+{
+ void Citrsd2d();
+ Citrsd2d(*ConTxt, uplo, diag, *m, *n, A, *lda, *rdest, *cdest);
+}
+
+void itrrv2d_(ConTxt, uplo, diag, m, n, A, lda, rsrc, csrc)
+int *ConTxt;
+char *uplo;
+char *diag;
+int *m;
+int *n;
+int *A;
+int *lda;
+int *rsrc;
+int *csrc;
+{
+ void Citrrv2d();
+ Citrrv2d(*ConTxt, uplo, diag, *m, *n, A, *lda, *rsrc, *csrc);
+}
+
+void itrbs2d_(ConTxt, scope, top, uplo, diag, m, n, A, lda)
+int *ConTxt;
+char *scope;
+char *top;
+char *uplo;
+char *diag;
+int *m;
+int *n;
+int *A;
+int *lda;
+{
+ void Citrbs2d();
+ Citrbs2d(*ConTxt, scope, top, uplo, diag, *m, *n, A, *lda);
+}
+
+void itrbr2d_(ConTxt, scope, top, uplo, diag, m, n, A, lda, rsrc, csrc)
+int *ConTxt;
+char *scope;
+char *top;
+char *uplo;
+char *diag;
+int *m;
+int *n;
+int *A;
+int *lda;
+int *rsrc;
+int *csrc;
+{
+ void Citrbr2d();
+ Citrbr2d(*ConTxt, scope, top, uplo, diag, *m, *n, A, *lda, *rsrc, *csrc);
+}
+
+void igsum2d_(ConTxt, scope, top, m, n, A, lda, rdest, cdest)
+int *ConTxt;
+char *scope;
+char *top;
+int *m;
+int *n;
+int *A;
+int *lda;
+int *rdest;
+int *cdest;
+{
+ void Cigsum2d();
+ Cigsum2d(*ConTxt, scope, top, *m, *n, A, *lda, *rdest, *cdest);
+}
+
+void igamx2d_(ConTxt, scope, top, m, n, A, lda, rA, cA, ldia, rdest, cdest)
+int *ConTxt;
+char *scope;
+char *top;
+int *m;
+int *n;
+int *A;
+int *lda;
+int *rA;
+int *cA;
+int *ldia;
+int *rdest;
+int *cdest;
+{
+ void Cigamx2d();
+ Cigamx2d(*ConTxt, scope, top, *m, *n, A, *lda, rA, cA, *ldia,
+ *rdest, *cdest);
+}
+
+void igamn2d_(ConTxt, scope, top, m, n, A, lda, rA, cA, ldia, rdest, cdest)
+int *ConTxt;
+char *scope;
+char *top;
+int *m;
+int *n;
+int *A;
+int *lda;
+int *rA;
+int *cA;
+int *ldia;
+int *rdest;
+int *cdest;
+{
+ void Cigamn2d();
+ Cigamn2d(*ConTxt, scope, top, *m, *n, A, *lda, rA, cA, *ldia,
+ *rdest, *cdest);
+}
+
+void dgesd2d_(ConTxt, m, n, A, lda, rdest, cdest)
+int *ConTxt;
+int *m;
+int *n;
+double *A;
+int *lda;
+int *rdest;
+int *cdest;
+{
+ void Cdgesd2d();
+ Cdgesd2d(*ConTxt, *m, *n, A, *lda, *rdest, *cdest);
+}
+
+void dgerv2d_(ConTxt, m, n, A, lda, rsrc, csrc)
+int *ConTxt;
+int *m;
+int *n;
+double *A;
+int *lda;
+int *rsrc;
+int *csrc;
+{
+ void Cdgerv2d();
+ Cdgerv2d(*ConTxt, *m, *n, A, *lda, *rsrc, *csrc);
+}
+
+void dgebs2d_(ConTxt, scope, top, m, n, A, lda)
+int *ConTxt;
+char *scope;
+char *top;
+int *m;
+int *n;
+double *A;
+int *lda;
+{
+ void Cdgebs2d();
+ Cdgebs2d(*ConTxt, scope, top, *m, *n, A, *lda);
+}
+
+void dgebr2d_(ConTxt, scope, top, m, n, A, lda, rsrc, csrc)
+int *ConTxt;
+char *scope;
+char *top;
+int *m;
+int *n;
+double *A;
+int *lda;
+int *rsrc;
+int *csrc;
+{
+ void Cdgebr2d();
+ Cdgebr2d(*ConTxt, scope, top, *m, *n, A, *lda, *rsrc, *csrc);
+}
+
+void dtrsd2d_(ConTxt, uplo, diag, m, n, A, lda, rdest, cdest)
+int *ConTxt;
+char *uplo;
+char *diag;
+int *m;
+int *n;
+double *A;
+int *lda;
+int *rdest;
+int *cdest;
+{
+ void Cdtrsd2d();
+ Cdtrsd2d(*ConTxt, uplo, diag, *m, *n, A, *lda, *rdest, *cdest);
+}
+
+void dtrrv2d_(ConTxt, uplo, diag, m, n, A, lda, rsrc, csrc)
+int *ConTxt;
+char *uplo;
+char *diag;
+int *m;
+int *n;
+double *A;
+int *lda;
+int *rsrc;
+int *csrc;
+{
+ void Cdtrrv2d();
+ Cdtrrv2d(*ConTxt, uplo, diag, *m, *n, A, *lda, *rsrc, *csrc);
+}
+
+void dtrbs2d_(ConTxt, scope, top, uplo, diag, m, n, A, lda)
+int *ConTxt;
+char *scope;
+char *top;
+char *uplo;
+char *diag;
+int *m;
+int *n;
+double *A;
+int *lda;
+{
+ void Cdtrbs2d();
+ Cdtrbs2d(*ConTxt, scope, top, uplo, diag, *m, *n, A, *lda);
+}
+
+void dtrbr2d_(ConTxt, scope, top, uplo, diag, m, n, A, lda, rsrc, csrc)
+int *ConTxt;
+char *scope;
+char *top;
+char *uplo;
+char *diag;
+int *m;
+int *n;
+double *A;
+int *lda;
+int *rsrc;
+int *csrc;
+{
+ void Cdtrbr2d();
+ Cdtrbr2d(*ConTxt, scope, top, uplo, diag, *m, *n, A, *lda, *rsrc, *csrc);
+}
+
+void dgsum2d_(ConTxt, scope, top, m, n, A, lda, rdest, cdest)
+int *ConTxt;
+char *scope;
+char *top;
+int *m;
+int *n;
+double *A;
+int *lda;
+int *rdest;
+int *cdest;
+{
+ void Cdgsum2d();
+ Cdgsum2d(*ConTxt, scope, top, *m, *n, A, *lda, *rdest, *cdest);
+}
+
+void dgamx2d_(ConTxt, scope, top, m, n, A, lda, rA, cA, ldia, rdest, cdest)
+int *ConTxt;
+char *scope;
+char *top;
+int *m;
+int *n;
+double *A;
+int *lda;
+int *rA;
+int *cA;
+int *ldia;
+int *rdest;
+int *cdest;
+{
+ void Cdgamx2d();
+ Cdgamx2d(*ConTxt, scope, top, *m, *n, A, *lda, rA, cA, *ldia,
+ *rdest, *cdest);
+}
+
+void dgamn2d_(ConTxt, scope, top, m, n, A, lda, rA, cA, ldia, rdest, cdest)
+int *ConTxt;
+char *scope;
+char *top;
+int *m;
+int *n;
+double *A;
+int *lda;
+int *rA;
+int *cA;
+int *ldia;
+int *rdest;
+int *cdest;
+{
+ void Cdgamn2d();
+ Cdgamn2d(*ConTxt, scope, top, *m, *n, A, *lda, rA, cA, *ldia,
+ *rdest, *cdest);
+}
+
+void sgesd2d_(ConTxt, m, n, A, lda, rdest, cdest)
+int *ConTxt;
+int *m;
+int *n;
+float *A;
+int *lda;
+int *rdest;
+int *cdest;
+{
+ void Csgesd2d();
+ Csgesd2d(*ConTxt, *m, *n, A, *lda, *rdest, *cdest);
+}
+
+void sgerv2d_(ConTxt, m, n, A, lda, rsrc, csrc)
+int *ConTxt;
+int *m;
+int *n;
+float *A;
+int *lda;
+int *rsrc;
+int *csrc;
+{
+ void Csgerv2d();
+ Csgerv2d(*ConTxt, *m, *n, A, *lda, *rsrc, *csrc);
+}
+
+void sgebs2d_(ConTxt, scope, top, m, n, A, lda)
+int *ConTxt;
+char *scope;
+char *top;
+int *m;
+int *n;
+float *A;
+int *lda;
+{
+ void Csgebs2d();
+ Csgebs2d(*ConTxt, scope, top, *m, *n, A, *lda);
+}
+
+void sgebr2d_(ConTxt, scope, top, m, n, A, lda, rsrc, csrc)
+int *ConTxt;
+char *scope;
+char *top;
+int *m;
+int *n;
+float *A;
+int *lda;
+int *rsrc;
+int *csrc;
+{
+ void Csgebr2d();
+ Csgebr2d(*ConTxt, scope, top, *m, *n, A, *lda, *rsrc, *csrc);
+}
+
+void strsd2d_(ConTxt, uplo, diag, m, n, A, lda, rdest, cdest)
+int *ConTxt;
+char *uplo;
+char *diag;
+int *m;
+int *n;
+float *A;
+int *lda;
+int *rdest;
+int *cdest;
+{
+ void Cstrsd2d();
+ Cstrsd2d(*ConTxt, uplo, diag, *m, *n, A, *lda, *rdest, *cdest);
+}
+
+void strrv2d_(ConTxt, uplo, diag, m, n, A, lda, rsrc, csrc)
+int *ConTxt;
+char *uplo;
+char *diag;
+int *m;
+int *n;
+float *A;
+int *lda;
+int *rsrc;
+int *csrc;
+{
+ void Cstrrv2d();
+ Cstrrv2d(*ConTxt, uplo, diag, *m, *n, A, *lda, *rsrc, *csrc);
+}
+
+void strbs2d_(ConTxt, scope, top, uplo, diag, m, n, A, lda)
+int *ConTxt;
+char *scope;
+char *top;
+char *uplo;
+char *diag;
+int *m;
+int *n;
+float *A;
+int *lda;
+{
+ void Cstrbs2d();
+ Cstrbs2d(*ConTxt, scope, top, uplo, diag, *m, *n, A, *lda);
+}
+
+void strbr2d_(ConTxt, scope, top, uplo, diag, m, n, A, lda, rsrc, csrc)
+int *ConTxt;
+char *scope;
+char *top;
+char *uplo;
+char *diag;
+int *m;
+int *n;
+float *A;
+int *lda;
+int *rsrc;
+int *csrc;
+{
+ void Cstrbr2d();
+ Cstrbr2d(*ConTxt, scope, top, uplo, diag, *m, *n, A, *lda, *rsrc, *csrc);
+}
+
+void sgsum2d_(ConTxt, scope, top, m, n, A, lda, rdest, cdest)
+int *ConTxt;
+char *scope;
+char *top;
+int *m;
+int *n;
+float *A;
+int *lda;
+int *rdest;
+int *cdest;
+{
+ void Csgsum2d();
+ Csgsum2d(*ConTxt, scope, top, *m, *n, A, *lda, *rdest, *cdest);
+}
+
+void sgamx2d_(ConTxt, scope, top, m, n, A, lda, rA, cA, ldia, rdest, cdest)
+int *ConTxt;
+char *scope;
+char *top;
+int *m;
+int *n;
+float *A;
+int *lda;
+int *rA;
+int *cA;
+int *ldia;
+int *rdest;
+int *cdest;
+{
+ void Csgamx2d();
+ Csgamx2d(*ConTxt, scope, top, *m, *n, A, *lda, rA, cA, *ldia,
+ *rdest, *cdest);
+}
+
+void sgamn2d_(ConTxt, scope, top, m, n, A, lda, rA, cA, ldia, rdest, cdest)
+int *ConTxt;
+char *scope;
+char *top;
+int *m;
+int *n;
+float *A;
+int *lda;
+int *rA;
+int *cA;
+int *ldia;
+int *rdest;
+int *cdest;
+{
+ void Csgamn2d();
+ Csgamn2d(*ConTxt, scope, top, *m, *n, A, *lda, rA, cA, *ldia,
+ *rdest, *cdest);
+}
+
+void cgesd2d_(ConTxt, m, n, A, lda, rdest, cdest)
+int *ConTxt;
+int *m;
+int *n;
+float *A;
+int *lda;
+int *rdest;
+int *cdest;
+{
+ void Ccgesd2d();
+ Ccgesd2d(*ConTxt, *m, *n, A, *lda, *rdest, *cdest);
+}
+
+void cgerv2d_(ConTxt, m, n, A, lda, rsrc, csrc)
+int *ConTxt;
+int *m;
+int *n;
+float *A;
+int *lda;
+int *rsrc;
+int *csrc;
+{
+ void Ccgerv2d();
+ Ccgerv2d(*ConTxt, *m, *n, A, *lda, *rsrc, *csrc);
+}
+
+void cgebs2d_(ConTxt, scope, top, m, n, A, lda)
+int *ConTxt;
+char *scope;
+char *top;
+int *m;
+int *n;
+float *A;
+int *lda;
+{
+ void Ccgebs2d();
+ Ccgebs2d(*ConTxt, scope, top, *m, *n, A, *lda);
+}
+
+void cgebr2d_(ConTxt, scope, top, m, n, A, lda, rsrc, csrc)
+int *ConTxt;
+char *scope;
+char *top;
+int *m;
+int *n;
+float *A;
+int *lda;
+int *rsrc;
+int *csrc;
+{
+ void Ccgebr2d();
+ Ccgebr2d(*ConTxt, scope, top, *m, *n, A, *lda, *rsrc, *csrc);
+}
+
+void ctrsd2d_(ConTxt, uplo, diag, m, n, A, lda, rdest, cdest)
+int *ConTxt;
+char *uplo;
+char *diag;
+int *m;
+int *n;
+float *A;
+int *lda;
+int *rdest;
+int *cdest;
+{
+ void Cctrsd2d();
+ Cctrsd2d(*ConTxt, uplo, diag, *m, *n, A, *lda, *rdest, *cdest);
+}
+
+void ctrrv2d_(ConTxt, uplo, diag, m, n, A, lda, rsrc, csrc)
+int *ConTxt;
+char *uplo;
+char *diag;
+int *m;
+int *n;
+float *A;
+int *lda;
+int *rsrc;
+int *csrc;
+{
+ void Cctrrv2d();
+ Cctrrv2d(*ConTxt, uplo, diag, *m, *n, A, *lda, *rsrc, *csrc);
+}
+
+void ctrbs2d_(ConTxt, scope, top, uplo, diag, m, n, A, lda)
+int *ConTxt;
+char *scope;
+char *top;
+char *uplo;
+char *diag;
+int *m;
+int *n;
+float *A;
+int *lda;
+{
+ void Cctrbs2d();
+ Cctrbs2d(*ConTxt, scope, top, uplo, diag, *m, *n, A, *lda);
+}
+
+void ctrbr2d_(ConTxt, scope, top, uplo, diag, m, n, A, lda, rsrc, csrc)
+int *ConTxt;
+char *scope;
+char *top;
+char *uplo;
+char *diag;
+int *m;
+int *n;
+float *A;
+int *lda;
+int *rsrc;
+int *csrc;
+{
+ void Cctrbr2d();
+ Cctrbr2d(*ConTxt, scope, top, uplo, diag, *m, *n, A, *lda, *rsrc, *csrc);
+}
+
+void cgsum2d_(ConTxt, scope, top, m, n, A, lda, rdest, cdest)
+int *ConTxt;
+char *scope;
+char *top;
+int *m;
+int *n;
+float *A;
+int *lda;
+int *rdest;
+int *cdest;
+{
+ void Ccgsum2d();
+ Ccgsum2d(*ConTxt, scope, top, *m, *n, A, *lda, *rdest, *cdest);
+}
+
+void cgamx2d_(ConTxt, scope, top, m, n, A, lda, rA, cA, ldia, rdest, cdest)
+int *ConTxt;
+char *scope;
+char *top;
+int *m;
+int *n;
+float *A;
+int *lda;
+int *rA;
+int *cA;
+int *ldia;
+int *rdest;
+int *cdest;
+{
+ void Ccgamx2d();
+ Ccgamx2d(*ConTxt, scope, top, *m, *n, A, *lda, rA, cA, *ldia,
+ *rdest, *cdest);
+}
+
+void cgamn2d_(ConTxt, scope, top, m, n, A, lda, rA, cA, ldia, rdest, cdest)
+int *ConTxt;
+char *scope;
+char *top;
+int *m;
+int *n;
+float *A;
+int *lda;
+int *rA;
+int *cA;
+int *ldia;
+int *rdest;
+int *cdest;
+{
+ void Ccgamn2d();
+ Ccgamn2d(*ConTxt, scope, top, *m, *n, A, *lda, rA, cA, *ldia,
+ *rdest, *cdest);
+}
+
+void zgesd2d_(ConTxt, m, n, A, lda, rdest, cdest)
+int *ConTxt;
+int *m;
+int *n;
+double *A;
+int *lda;
+int *rdest;
+int *cdest;
+{
+ void Czgesd2d();
+ Czgesd2d(*ConTxt, *m, *n, A, *lda, *rdest, *cdest);
+}
+
+void zgerv2d_(ConTxt, m, n, A, lda, rsrc, csrc)
+int *ConTxt;
+int *m;
+int *n;
+double *A;
+int *lda;
+int *rsrc;
+int *csrc;
+{
+ void Czgerv2d();
+ Czgerv2d(*ConTxt, *m, *n, A, *lda, *rsrc, *csrc);
+}
+
+void zgebs2d_(ConTxt, scope, top, m, n, A, lda)
+int *ConTxt;
+char *scope;
+char *top;
+int *m;
+int *n;
+double *A;
+int *lda;
+{
+ void Czgebs2d();
+ Czgebs2d(*ConTxt, scope, top, *m, *n, A, *lda);
+}
+
+void zgebr2d_(ConTxt, scope, top, m, n, A, lda, rsrc, csrc)
+int *ConTxt;
+char *scope;
+char *top;
+int *m;
+int *n;
+double *A;
+int *lda;
+int *rsrc;
+int *csrc;
+{
+ void Czgebr2d();
+ Czgebr2d(*ConTxt, scope, top, *m, *n, A, *lda, *rsrc, *csrc);
+}
+
+void ztrsd2d_(ConTxt, uplo, diag, m, n, A, lda, rdest, cdest)
+int *ConTxt;
+char *uplo;
+char *diag;
+int *m;
+int *n;
+double *A;
+int *lda;
+int *rdest;
+int *cdest;
+{
+ void Cztrsd2d();
+ Cztrsd2d(*ConTxt, uplo, diag, *m, *n, A, *lda, *rdest, *cdest);
+}
+
+void ztrrv2d_(ConTxt, uplo, diag, m, n, A, lda, rsrc, csrc)
+int *ConTxt;
+char *uplo;
+char *diag;
+int *m;
+int *n;
+double *A;
+int *lda;
+int *rsrc;
+int *csrc;
+{
+ void Cztrrv2d();
+ Cztrrv2d(*ConTxt, uplo, diag, *m, *n, A, *lda, *rsrc, *csrc);
+}
+
+void ztrbs2d_(ConTxt, scope, top, uplo, diag, m, n, A, lda)
+int *ConTxt;
+char *scope;
+char *top;
+char *uplo;
+char *diag;
+int *m;
+int *n;
+double *A;
+int *lda;
+{
+ void Cztrbs2d();
+ Cztrbs2d(*ConTxt, scope, top, uplo, diag, *m, *n, A, *lda);
+}
+
+void ztrbr2d_(ConTxt, scope, top, uplo, diag, m, n, A, lda, rsrc, csrc)
+int *ConTxt;
+char *scope;
+char *top;
+char *uplo;
+char *diag;
+int *m;
+int *n;
+double *A;
+int *lda;
+int *rsrc;
+int *csrc;
+{
+ void Cztrbr2d();
+ Cztrbr2d(*ConTxt, scope, top, uplo, diag, *m, *n, A, *lda, *rsrc, *csrc);
+}
+
+void zgsum2d_(ConTxt, scope, top, m, n, A, lda, rdest, cdest)
+int *ConTxt;
+char *scope;
+char *top;
+int *m;
+int *n;
+double *A;
+int *lda;
+int *rdest;
+int *cdest;
+{
+ void Czgsum2d();
+ Czgsum2d(*ConTxt, scope, top, *m, *n, A, *lda, *rdest, *cdest);
+}
+
+void zgamx2d_(ConTxt, scope, top, m, n, A, lda, rA, cA, ldia, rdest, cdest)
+int *ConTxt;
+char *scope;
+char *top;
+int *m;
+int *n;
+double *A;
+int *lda;
+int *rA;
+int *cA;
+int *ldia;
+int *rdest;
+int *cdest;
+{
+ void Czgamx2d();
+ Czgamx2d(*ConTxt, scope, top, *m, *n, A, *lda, rA, cA, *ldia,
+ *rdest, *cdest);
+}
+
+void zgamn2d_(ConTxt, scope, top, m, n, A, lda, rA, cA, ldia, rdest, cdest)
+int *ConTxt;
+char *scope;
+char *top;
+int *m;
+int *n;
+double *A;
+int *lda;
+int *rA;
+int *cA;
+int *ldia;
+int *rdest;
+int *cdest;
+{
+ void Czgamn2d();
+ Czgamn2d(*ConTxt, scope, top, *m, *n, A, *lda, rA, cA, *ldia,
+ *rdest, *cdest);
+}
+#endif
diff --git a/BLACS/TESTING/Cbt.h b/BLACS/TESTING/Cbt.h
new file mode 100644
index 0000000..1b33efb
--- /dev/null
+++ b/BLACS/TESTING/Cbt.h
@@ -0,0 +1,19 @@
+#define ADD_ 0
+#define NOCHANGE 1
+#define UPCASE 2
+
+#ifdef UpCase
+#define F77_CALL_C UPCASE
+#endif
+
+#ifdef NoChange
+#define F77_CALL_C NOCHANGE
+#endif
+
+#ifdef Add_
+#define F77_CALL_C ADD_
+#endif
+
+#ifndef F77_CALL_C
+#define F77_CALL_C ADD_
+#endif
diff --git a/BLACS/TESTING/Makefile b/BLACS/TESTING/Makefile
new file mode 100644
index 0000000..4bfdd94
--- /dev/null
+++ b/BLACS/TESTING/Makefile
@@ -0,0 +1,48 @@
+include ../../SLmake.inc
+
+# ---------------------------------------------------------------------
+# The file tools.f contains some LAPACK routines that the tester calls.
+# If you have ScaLAPACK, you may point to your tools library instead
+# of compiling this file.
+# ---------------------------------------------------------------------
+tools = tools.o
+
+exe : all
+ctest : xCbtest
+ftest : xFbtest
+all : xCbtest xFbtest
+
+obj = blacstest.o btprim.o
+
+xCbtest: $(obj) $(tools)
+ $(CC) -c $(CDEFS) $(CCFLAGS) -DBTCINTFACE Cbt.c
+ $(FCLOADER) $(FCLOADFLAGS) -o $@ $(obj) $(tools) Cbt.o ../../$(SCALAPACKLIB)
+
+xFbtest: $(obj) $(tools)
+ $(FCLOADER) $(FCLOADFLAGS) -o $@ $(obj) $(tools) ../../$(SCALAPACKLIB)
+
+# --------------------------------------------------------------------
+# The files tools.f and blacstest.f are compiled without optimization.
+# Tools.f contains the LAPACK routines slamch and dlamch, which only
+# operate correctly for low-levels of optimization. Blacstest.f is
+# extremely large, and optimizing it takes a long time. More
+# importantly, the sun's f77 compiler seems to produce errors in
+# trying to optimize such a large file. We therefore insist that it
+# also not be optimized.
+# --------------------------------------------------------------------
+tools.o : tools.f
+ $(FC) $(NOOPT) -c $*.f
+
+blacstest.o : blacstest.f
+ $(FC) $(NOOPT) -c $*.f
+
+btprim.o : btprim.f
+ $(FC) -c $(FCFLAGS) $*.f
+
+clean :
+ rm -f $(obj) tools.o Cbt.o xCbtest xFbtest
+
+.f.o: ; $(FC) -c $(FCFLAGS) $*.f
+
+.c.o:
+ $(CC) -c $(CDEFS) $(CCFLAGS) $<
diff --git a/BLACS/TESTING/README b/BLACS/TESTING/README
new file mode 100644
index 0000000..f926973
--- /dev/null
+++ b/BLACS/TESTING/README
@@ -0,0 +1,11 @@
+(1) To compile, just type "make". You must first edit and correct the
+ file BLACS/Bmake.inc. Sample Bmake.inc's can be found in the
+ BLACS/BMAKES directories. See the paper "Installing and testing the BLACS"
+ for details.
+
+(2) Type "make clean" to get rid of old .o files.
+
+(3) The file blacstest.f is extremely large (roughly 20,000 lines),
+ and this may be too large to compile on some systems. If you have this
+ problem, a slight modification to the BLACS/TESTING Makefile should allow
+ you to split blacstest.f into smaller files.
diff --git a/BLACS/TESTING/blacstest.f b/BLACS/TESTING/blacstest.f
new file mode 100644
index 0000000..228f527
--- /dev/null
+++ b/BLACS/TESTING/blacstest.f
@@ -0,0 +1,21722 @@
+ PROGRAM BLACSTEST
+*
+* -- BLACS tester (version 1.0) --
+* University of Tennessee
+* December 15, 1994
+*
+* Purpose
+* =======
+* This is the driver for the BLACS test suite.
+*
+* Arguments
+* =========
+* None. Input is done via the data files indicated below.
+*
+* Input Files
+* ===========
+* The following input files must reside in the current working
+* directory:
+*
+* bt.dat -- input parameters for the test run as a whole
+* sdrv.dat -- input parameters for point-to-point testing
+* bsbr.dat -- input parameters for broadcast testing
+* comb.dat -- input parameters for combine testing
+*
+* Output Files
+* ============
+* Test results are generated and sent to output file as
+* specified by the user in bt.dat.
+*
+* ===================================================================
+*
+* .. Parameters ..
+ INTEGER CMEMSIZ, MEMELTS
+ PARAMETER( MEMELTS = 250000 )
+ PARAMETER( CMEMSIZ = 10000 )
+* ..
+* .. External Functions ..
+ LOGICAL ALLPASS
+ INTEGER IBTMSGID, IBTSIZEOF
+ REAL SBTEPS
+ DOUBLE PRECISION DBTEPS
+ EXTERNAL ALLPASS, IBTMSGID, SBTEPS, DBTEPS, IBTSIZEOF
+* ..
+* .. External Subroutines ..
+ EXTERNAL BLACS_PINFO, BTSETUP, RDBTIN
+* ..
+* .. Local Scalars ..
+ INTEGER I, IAM, NNODES, VERB, OUTNUM, MEMLEN, NPREC, ISIZE, DSIZE
+ LOGICAL TESTSDRV, TESTBSBR, TESTCOMB, TESTAUX
+* ..
+* .. Local Arrays ..
+ CHARACTER*1 CMEM(CMEMSIZ), PREC(9)
+ INTEGER IPREC(9), ITMP(2)
+ DOUBLE PRECISION MEM(MEMELTS)
+* ..
+* .. Executable Statements ..
+*
+ ISIZE = IBTSIZEOF('I')
+ DSIZE = IBTSIZEOF('D')
+*
+* Get initial process information, and initialize message IDs
+*
+ CALL BLACS_PINFO( IAM, NNODES )
+ ITMP(1) = IBTMSGID()
+*
+* Call BLACS_GRIDINIT so BLACS set up some system stuff: should
+* make it possible for the user to print, read input files, etc.
+*
+ IF( NNODES .GT. 0 ) THEN
+ CALL BLACS_GET( 0, 0, ITMP )
+ CALL BLACS_GRIDINIT(ITMP, 'c', 1, NNODES)
+ CALL BLACS_GRIDEXIT(ITMP)
+ END IF
+*
+* Read in what tests to do
+*
+ IF( IAM .EQ. 0 )
+ $ CALL RDBTIN( TESTSDRV, TESTBSBR, TESTCOMB, TESTAUX, NPREC,
+ $ PREC, VERB, OUTNUM )
+*
+ MEMLEN = (MEMELTS * DSIZE) / ISIZE
+*
+* Get process info for communication, and create virtual machine
+* if necessary
+*
+ CALL BTSETUP( MEM, MEMLEN, CMEM, CMEMSIZ, OUTNUM, TESTSDRV,
+ $ TESTBSBR, TESTCOMB, TESTAUX, IAM, NNODES )
+*
+* Send out RDBTIN information
+*
+ IF( IAM .EQ. 0 ) THEN
+*
+* Store test info in back of precision array
+*
+ ITMP(1) = NPREC
+ ITMP(2) = VERB
+ CALL BTSEND( 3, 2, ITMP, -1, IBTMSGID() )
+ DO 10 I = 1, 9
+ IPREC(I) = 0
+ 10 CONTINUE
+ DO 20 I = 1, NPREC
+ IF( PREC(I) .EQ. 'I' ) THEN
+ IPREC(I) = 1
+ ELSE IF( PREC(I) .EQ. 'S' ) THEN
+ IPREC(I) = 2
+ ELSE IF( PREC(I) .EQ. 'D' ) THEN
+ IPREC(I) = 3
+ ELSE IF( PREC(I) .EQ. 'C' ) THEN
+ IPREC(I) = 4
+ ELSE IF( PREC(I) .EQ. 'Z' ) THEN
+ IPREC(I) = 5
+ END IF
+ 20 CONTINUE
+ IF( TESTSDRV ) IPREC(6) = 1
+ IF( TESTBSBR ) IPREC(7) = 1
+ IF( TESTCOMB ) IPREC(8) = 1
+ IF( TESTAUX ) IPREC(9) = 1
+ CALL BTSEND( 3, 9, IPREC, -1, IBTMSGID()+1 )
+ ELSE
+ CALL BTRECV( 3, 2, ITMP, 0, IBTMSGID() )
+ NPREC = ITMP(1)
+ VERB = ITMP(2)
+ CALL BTRECV( 3, 9, IPREC, 0, IBTMSGID()+1 )
+ DO 30 I = 1, NPREC
+ IF( IPREC(I) .EQ. 1 ) THEN
+ PREC(I) = 'I'
+ ELSE IF( IPREC(I) .EQ. 2 ) THEN
+ PREC(I) = 'S'
+ ELSE IF( IPREC(I) .EQ. 3 ) THEN
+ PREC(I) = 'D'
+ ELSE IF( IPREC(I) .EQ. 4 ) THEN
+ PREC(I) = 'C'
+ ELSE IF( IPREC(I) .EQ. 5 ) THEN
+ PREC(I) = 'Z'
+ END IF
+ 30 CONTINUE
+ TESTSDRV = ( IPREC(6) .EQ. 1 )
+ TESTBSBR = ( IPREC(7) .EQ. 1 )
+ TESTCOMB = ( IPREC(8) .EQ. 1 )
+ TESTAUX = ( IPREC(9) .EQ. 1 )
+ ENDIF
+*
+ IF( TESTSDRV .OR. TESTBSBR .OR. TESTCOMB .OR. TESTAUX ) THEN
+*
+* Find maximal machine epsilon for single and double precision
+*
+ ITMP(1) = INT( SBTEPS() )
+ ITMP(1) = INT( DBTEPS() )
+*
+ CALL RUNTESTS( MEM, MEMLEN, CMEM, CMEMSIZ, PREC, NPREC, OUTNUM,
+ $ VERB, TESTSDRV, TESTBSBR, TESTCOMB, TESTAUX )
+*
+ END IF
+*
+ IF( IAM .EQ. 0 ) THEN
+ WRITE(OUTNUM,*) ' '
+ WRITE(OUTNUM,1000)
+ WRITE(OUTNUM,1000)
+ IF( ALLPASS(.TRUE.) ) THEN
+ WRITE(OUTNUM,2000) 'NO'
+ ELSE
+ WRITE(OUTNUM,2000) ' '
+ END IF
+ WRITE(OUTNUM,1000)
+ WRITE(OUTNUM,1000)
+ IF( OUTNUM.NE.0 .AND. OUTNUM.NE.6 ) CLOSE(OUTNUM)
+ ENDIF
+*
+ CALL BLACS_EXIT(0)
+ 1000 FORMAT('=======================================')
+ 2000 FORMAT('THERE WERE ',A2,' FAILURES IN THIS TEST RUN')
+ STOP
+*
+* End BLACSTESTER
+*
+ END
+*
+ SUBROUTINE RUNTESTS( MEM, MEMLEN, CMEM, CMEMLEN, PREC, NPREC,
+ $ OUTNUM, VERB, TESTSDRV, TESTBSBR, TESTCOMB,
+ $ TESTAUX )
+*
+* .. Scalar Arguments ..
+ INTEGER MEMLEN, CMEMLEN, NPREC, OUTNUM, VERB, IAM, NNODES
+ LOGICAL TESTSDRV, TESTBSBR, TESTCOMB, TESTAUX
+* ..
+* .. Array Arguments ..
+ CHARACTER*1 CMEM(CMEMLEN), PREC(NPREC)
+ INTEGER MEM(MEMLEN)
+* ..
+* .. External Functions ..
+ INTEGER IBTNPROCS, IBTMYPROC, IBTMSGID, IBTSIZEOF, SAFEINDEX
+ EXTERNAL IBTNPROCS, IBTMYPROC, IBTMSGID, IBTSIZEOF, SAFEINDEX
+* ..
+* .. External Subroutines ..
+ EXTERNAL CSDRVTEST, DSDRVTEST, ISDRVTEST, SSDRVTEST, ZSDRVTEST
+ EXTERNAL CBSBRTEST, DBSBRTEST, IBSBRTEST, SBSBRTEST, ZBSBRTEST
+ EXTERNAL ISUMTEST, SSUMTEST, DSUMTEST, CSUMTEST, ZSUMTEST
+ EXTERNAL IAMXTEST, SAMXTEST, DAMXTEST, CAMXTEST, ZAMXTEST
+ EXTERNAL IAMNTEST, SAMNTEST, DAMNTEST, CAMNTEST, ZAMNTEST
+ EXTERNAL AUXTEST, BTSEND, BTRECV, BTINFO
+* ..
+* .. Local Scalars ..
+ INTEGER NSCOPE, NOP, NTOP, NSHAPE, NMAT, NSRC, NDEST, NGRID
+ INTEGER TREP, TCOH, OPPTR, SCOPEPTR, TOPPTR, UPLOPTR, DIAGPTR
+ INTEGER MPTR, NPTR, LDSPTR, LDDPTR, LDIPTR
+ INTEGER RSRCPTR, CSRCPTR, RDESTPTR, CDESTPTR, PPTR, QPTR
+ INTEGER ISEEDPTR, RAPTR, CAPTR, CTXTPTR, WORKPTR, WORKLEN
+ INTEGER MEMUSED, CMEMUSED, I, J, K
+ INTEGER ISIZE, SSIZE, DSIZE, CSIZE, ZSIZE
+* ..
+* .. Local Arrays ..
+ INTEGER ITMP(4)
+* ..
+* .. Executable Statements ..
+*
+ IAM = IBTMYPROC()
+ NNODES = IBTNPROCS()
+ ISIZE = IBTSIZEOF('I')
+ SSIZE = IBTSIZEOF('S')
+ DSIZE = IBTSIZEOF('D')
+ CSIZE = IBTSIZEOF('C')
+ ZSIZE = IBTSIZEOF('Z')
+*
+ IF( IAM.EQ.0 ) THEN
+ CALL BLACS_GET( 0, 2, I )
+ WRITE(OUTNUM,3000)
+ WRITE(OUTNUM,3000)
+ WRITE(OUTNUM,2000) I
+ WRITE(OUTNUM,3000)
+ WRITE(OUTNUM,3000)
+ END IF
+*
+ IF( TESTAUX ) THEN
+*
+* Each process will make sure that BLACS_PINFO returns
+* the same value as BLACS_SETUP, and send a packet
+* to node 0 saying whether it was.
+*
+ CALL BLACS_PINFO( ITMP(1), ITMP(3) )
+ CALL BLACS_SETUP( ITMP(2), ITMP(4) )
+ IF( IAM .EQ. 0 ) THEN
+ DO 35 I = 0, NNODES-1
+ IF( I .NE. 0 )
+ $ CALL BTRECV( 3, 4, ITMP, I, IBTMSGID()+2 )
+ IF( ITMP(1) .NE. ITMP(2) )
+ $ WRITE( OUTNUM, 1000 ) ITMP(1), ITMP(2)
+ IF( (ITMP(3).NE.ITMP(4)) .OR. (ITMP(3).NE.NNODES) )
+ $ WRITE( OUTNUM, 1000 ) ITMP(3), ITMP(4), NNODES
+ 35 CONTINUE
+ ELSE
+ CALL BTSEND( 3, 4, ITMP, 0, IBTMSGID()+2 )
+ ENDIF
+ ENDIF
+*
+* Run point-to-point tests as appropriate
+*
+ IF( TESTSDRV ) THEN
+*
+* Get test info
+*
+ CALL BTINFO( 'SDRV', MEMUSED, MEM, MEMLEN, CMEMUSED, CMEM,
+ $ CMEMLEN, OUTNUM, NOP, NSCOPE, TREP, TCOH, NTOP,
+ $ NSHAPE, NMAT, NSRC, NGRID, OPPTR, SCOPEPTR,
+ $ TOPPTR, UPLOPTR, DIAGPTR, MPTR, NPTR, LDSPTR,
+ $ LDDPTR, LDIPTR, RSRCPTR, CSRCPTR, RDESTPTR,
+ $ CDESTPTR, PPTR, QPTR )
+*
+* iseedptr used as tests passed/failed array, so it must
+* be of size NTESTS -- It's not used unless VERB < 2
+*
+ CTXTPTR = MEMUSED + 1
+ ISEEDPTR = CTXTPTR + NGRID
+ MEMUSED = ISEEDPTR - 1
+ IF( VERB .LT. 2 )
+ $ MEMUSED = MEMUSED + NSHAPE * NMAT * NSRC * NGRID
+*
+ CALL MAKEGRIDS( MEM(CTXTPTR), OUTNUM, NGRID, MEM(PPTR),
+ $ MEM(QPTR) )
+*
+* Call individual tests as appropriate.
+*
+ DO 10 I = 1, NPREC
+ IF( PREC(I) .EQ. 'I' ) THEN
+*
+ WORKPTR = SAFEINDEX(MEMUSED + 1, ISIZE, ISIZE)
+ WORKLEN = ( DSIZE * (MEMLEN - WORKPTR + 1) ) / ISIZE
+ CALL ISDRVTEST(OUTNUM, VERB, NSHAPE, CMEM(UPLOPTR),
+ $ CMEM(DIAGPTR), NMAT, MEM(MPTR),
+ $ MEM(NPTR), MEM(LDSPTR), MEM(LDDPTR),
+ $ NSRC, MEM(RSRCPTR), MEM(CSRCPTR),
+ $ MEM(RDESTPTR), MEM(CDESTPTR),
+ $ NGRID, MEM(CTXTPTR), MEM(PPTR), MEM(QPTR),
+ $ MEM(ISEEDPTR), MEM(WORKPTR), WORKLEN)
+*
+ ELSE IF( PREC(I) .EQ. 'S' ) THEN
+*
+ WORKPTR = SAFEINDEX(MEMUSED + 1, ISIZE, SSIZE)
+ WORKLEN = ( DSIZE * (MEMLEN - WORKPTR + 1) ) / SSIZE
+ CALL SSDRVTEST(OUTNUM, VERB, NSHAPE, CMEM(UPLOPTR),
+ $ CMEM(DIAGPTR), NMAT, MEM(MPTR),
+ $ MEM(NPTR), MEM(LDSPTR), MEM(LDDPTR),
+ $ NSRC, MEM(RSRCPTR), MEM(CSRCPTR),
+ $ MEM(RDESTPTR), MEM(CDESTPTR),
+ $ NGRID, MEM(CTXTPTR), MEM(PPTR), MEM(QPTR),
+ $ MEM(ISEEDPTR), MEM(WORKPTR), WORKLEN)
+*
+ ELSE IF( PREC(I) .EQ. 'D' ) THEN
+*
+ WORKPTR = SAFEINDEX(MEMUSED + 1, ISIZE, DSIZE)
+ WORKLEN = ( DSIZE * (MEMLEN - WORKPTR + 1) ) / DSIZE
+ CALL DSDRVTEST(OUTNUM, VERB, NSHAPE, CMEM(UPLOPTR),
+ $ CMEM(DIAGPTR), NMAT, MEM(MPTR),
+ $ MEM(NPTR), MEM(LDSPTR), MEM(LDDPTR),
+ $ NSRC, MEM(RSRCPTR), MEM(CSRCPTR),
+ $ MEM(RDESTPTR), MEM(CDESTPTR),
+ $ NGRID, MEM(CTXTPTR), MEM(PPTR), MEM(QPTR),
+ $ MEM(ISEEDPTR), MEM(WORKPTR), WORKLEN)
+*
+ ELSE IF( PREC(I) .EQ. 'C' ) THEN
+*
+ WORKPTR = SAFEINDEX(MEMUSED + 1, ISIZE, CSIZE)
+ WORKLEN = ( DSIZE * (MEMLEN - WORKPTR + 1) ) / CSIZE
+ CALL CSDRVTEST(OUTNUM, VERB, NSHAPE, CMEM(UPLOPTR),
+ $ CMEM(DIAGPTR), NMAT, MEM(MPTR),
+ $ MEM(NPTR), MEM(LDSPTR), MEM(LDDPTR),
+ $ NSRC, MEM(RSRCPTR), MEM(CSRCPTR),
+ $ MEM(RDESTPTR), MEM(CDESTPTR),
+ $ NGRID, MEM(CTXTPTR), MEM(PPTR), MEM(QPTR),
+ $ MEM(ISEEDPTR), MEM(WORKPTR), WORKLEN)
+*
+ ELSE IF( PREC(I) .EQ. 'Z' ) THEN
+*
+ WORKPTR = SAFEINDEX(MEMUSED + 1, ISIZE, ZSIZE)
+ WORKLEN = ( DSIZE * (MEMLEN - WORKPTR + 1) ) / ZSIZE
+ CALL ZSDRVTEST(OUTNUM, VERB, NSHAPE, CMEM(UPLOPTR),
+ $ CMEM(DIAGPTR), NMAT, MEM(MPTR),
+ $ MEM(NPTR), MEM(LDSPTR), MEM(LDDPTR),
+ $ NSRC, MEM(RSRCPTR), MEM(CSRCPTR),
+ $ MEM(RDESTPTR), MEM(CDESTPTR),
+ $ NGRID, MEM(CTXTPTR), MEM(PPTR), MEM(QPTR),
+ $ MEM(ISEEDPTR), MEM(WORKPTR), WORKLEN)
+ END IF
+ 10 CONTINUE
+ CALL FREEGRIDS( NGRID, MEM(CTXTPTR) )
+ END IF
+*
+ IF( TESTBSBR ) THEN
+*
+* Get test info
+*
+ CALL BTINFO( 'BSBR', MEMUSED, MEM, MEMLEN, CMEMUSED, CMEM,
+ $ CMEMLEN, OUTNUM, NOP, NSCOPE, TREP, TCOH, NTOP,
+ $ NSHAPE, NMAT, NSRC, NGRID, OPPTR, SCOPEPTR,
+ $ TOPPTR, UPLOPTR, DIAGPTR, MPTR, NPTR, LDSPTR,
+ $ LDDPTR, LDIPTR, RSRCPTR, CSRCPTR, RDESTPTR,
+ $ CDESTPTR, PPTR, QPTR )
+*
+* iseedptr used as tests passed/failed array, so it must
+* be of size NTESTS -- It's not used unless VERB < 2
+*
+ CTXTPTR = MEMUSED + 1
+ ISEEDPTR = CTXTPTR + NGRID
+ MEMUSED = ISEEDPTR - 1
+ IF( VERB .LT. 2 )
+ $ MEMUSED = MEMUSED + NSCOPE*NTOP*NSHAPE*NMAT*NSRC*NGRID
+*
+ CALL MAKEGRIDS( MEM(CTXTPTR), OUTNUM, NGRID, MEM(PPTR),
+ $ MEM(QPTR) )
+*
+* Call individual tests as appropriate.
+*
+ DO 20 I = 1, NPREC
+ IF( PREC(I) .EQ. 'I' ) THEN
+*
+ WORKPTR = SAFEINDEX(MEMUSED + 1, ISIZE, ISIZE)
+ WORKLEN = ( DSIZE * (MEMLEN - WORKPTR + 1) ) / ISIZE
+ CALL IBSBRTEST(OUTNUM, VERB, NSCOPE, CMEM(SCOPEPTR),
+ $ NTOP, CMEM(TOPPTR), NSHAPE, CMEM(UPLOPTR),
+ $ CMEM(DIAGPTR), NMAT, MEM(MPTR),
+ $ MEM(NPTR), MEM(LDSPTR), MEM(LDDPTR),
+ $ NSRC, MEM(RSRCPTR), MEM(CSRCPTR),
+ $ NGRID, MEM(CTXTPTR), MEM(PPTR), MEM(QPTR),
+ $ MEM(ISEEDPTR), MEM(WORKPTR), WORKLEN)
+*
+ ELSE IF( PREC(I) .EQ. 'S' ) THEN
+*
+ WORKPTR = SAFEINDEX(MEMUSED + 1, ISIZE, SSIZE)
+ WORKLEN = ( DSIZE * (MEMLEN - WORKPTR + 1) ) / SSIZE
+ CALL SBSBRTEST(OUTNUM, VERB, NSCOPE, CMEM(SCOPEPTR),
+ $ NTOP, CMEM(TOPPTR), NSHAPE, CMEM(UPLOPTR),
+ $ CMEM(DIAGPTR), NMAT, MEM(MPTR),
+ $ MEM(NPTR), MEM(LDSPTR), MEM(LDDPTR),
+ $ NSRC, MEM(RSRCPTR), MEM(CSRCPTR),
+ $ NGRID, MEM(CTXTPTR), MEM(PPTR), MEM(QPTR),
+ $ MEM(ISEEDPTR), MEM(WORKPTR), WORKLEN)
+*
+ ELSE IF( PREC(I) .EQ. 'D' ) THEN
+*
+ WORKPTR = SAFEINDEX(MEMUSED + 1, ISIZE, DSIZE)
+ WORKLEN = ( DSIZE * (MEMLEN - WORKPTR + 1) ) / DSIZE
+ CALL DBSBRTEST(OUTNUM, VERB, NSCOPE, CMEM(SCOPEPTR),
+ $ NTOP, CMEM(TOPPTR), NSHAPE, CMEM(UPLOPTR),
+ $ CMEM(DIAGPTR), NMAT, MEM(MPTR),
+ $ MEM(NPTR), MEM(LDSPTR), MEM(LDDPTR),
+ $ NSRC, MEM(RSRCPTR), MEM(CSRCPTR),
+ $ NGRID, MEM(CTXTPTR), MEM(PPTR), MEM(QPTR),
+ $ MEM(ISEEDPTR), MEM(WORKPTR), WORKLEN)
+*
+ ELSE IF( PREC(I) .EQ. 'C' ) THEN
+*
+ WORKPTR = SAFEINDEX(MEMUSED + 1, ISIZE, CSIZE)
+ WORKLEN = ( DSIZE * (MEMLEN - WORKPTR + 1) ) / CSIZE
+ CALL CBSBRTEST(OUTNUM, VERB, NSCOPE, CMEM(SCOPEPTR),
+ $ NTOP, CMEM(TOPPTR), NSHAPE, CMEM(UPLOPTR),
+ $ CMEM(DIAGPTR), NMAT, MEM(MPTR),
+ $ MEM(NPTR), MEM(LDSPTR), MEM(LDDPTR),
+ $ NSRC, MEM(RSRCPTR), MEM(CSRCPTR),
+ $ NGRID, MEM(CTXTPTR), MEM(PPTR), MEM(QPTR),
+ $ MEM(ISEEDPTR), MEM(WORKPTR), WORKLEN)
+*
+ ELSE IF( PREC(I) .EQ. 'Z' ) THEN
+*
+ WORKPTR = SAFEINDEX(MEMUSED + 1, ISIZE, ZSIZE)
+ WORKLEN = ( DSIZE * (MEMLEN - WORKPTR + 1) ) / ZSIZE
+ CALL ZBSBRTEST(OUTNUM, VERB, NSCOPE, CMEM(SCOPEPTR),
+ $ NTOP, CMEM(TOPPTR), NSHAPE, CMEM(UPLOPTR),
+ $ CMEM(DIAGPTR), NMAT, MEM(MPTR),
+ $ MEM(NPTR), MEM(LDSPTR), MEM(LDDPTR),
+ $ NSRC, MEM(RSRCPTR), MEM(CSRCPTR),
+ $ NGRID, MEM(CTXTPTR), MEM(PPTR), MEM(QPTR),
+ $ MEM(ISEEDPTR), MEM(WORKPTR), WORKLEN)
+*
+ END IF
+*
+ 20 CONTINUE
+ CALL FREEGRIDS( NGRID, MEM(CTXTPTR) )
+ END IF
+ IF( TESTCOMB ) THEN
+*
+* Get test info
+*
+ CALL BTINFO( 'COMB', MEMUSED, MEM, MEMLEN, CMEMUSED, CMEM,
+ $ CMEMLEN, OUTNUM, NOP, NSCOPE, TREP, TCOH, NTOP,
+ $ NSHAPE, NMAT, NDEST, NGRID, OPPTR, SCOPEPTR,
+ $ TOPPTR, UPLOPTR, DIAGPTR, MPTR, NPTR, LDSPTR,
+ $ LDDPTR, LDIPTR, RSRCPTR, CSRCPTR, RDESTPTR,
+ $ CDESTPTR, PPTR, QPTR )
+ CTXTPTR = MEMUSED + 1
+ MEMUSED = CTXTPTR + NGRID - 1
+*
+* Find space required by RA and CA arrays
+*
+ K = 0
+ DO 40 J = 0, NOP-1
+ IF( CMEM(OPPTR+J).EQ.'>' .OR. CMEM(OPPTR+J).EQ.'<' ) THEN
+ DO 30 I = 0, NMAT
+*
+* NOTE: here we assume ipre+ipost = 4*M
+*
+ K = MAX0( K, 4*MEM(MPTR+I) )
+ IF ( MEM(LDIPTR+I) .NE. -1 )
+ $ K = MAX0( K, MEM(NPTR+I)*MEM(LDIPTR+I) +
+ $ 4*MEM(MPTR+I) )
+ 30 CONTINUE
+ END IF
+ 40 CONTINUE
+ RAPTR = MEMUSED + 1
+ CAPTR = RAPTR + K
+*
+* iseed array also used as tests passed/failed array, so it must
+* be of size MAX( 4*NNODES, NTESTS )
+*
+ ISEEDPTR = CAPTR + K
+ I = 0
+ IF( VERB.LT.2 ) I = NSCOPE * NTOP * NMAT * NDEST * NGRID
+ MEMUSED = ISEEDPTR + MAX( 4*NNODES, I )
+*
+ CALL MAKEGRIDS( MEM(CTXTPTR), OUTNUM, NGRID, MEM(PPTR),
+ $ MEM(QPTR) )
+*
+* Call individual tests as appropriate.
+*
+ DO 60 I = 1, NPREC
+ DO 50 J = 0, NOP-1
+ IF( PREC(I) .EQ. 'I' ) THEN
+ WORKPTR = SAFEINDEX(MEMUSED, ISIZE, ISIZE)
+ WORKLEN = ( DSIZE * (MEMLEN - WORKPTR + 1) ) / ISIZE
+ IF( CMEM(OPPTR+J) .EQ. '+' ) THEN
+ CALL ISUMTEST(OUTNUM, VERB, TREP, TCOH, NSCOPE,
+ $ CMEM(SCOPEPTR), NTOP, CMEM(TOPPTR),
+ $ NMAT, MEM(MPTR), MEM(NPTR),
+ $ MEM(LDSPTR), MEM(LDDPTR), NDEST,
+ $ MEM(RDESTPTR), MEM(CDESTPTR), NGRID,
+ $ MEM(CTXTPTR), MEM(PPTR), MEM(QPTR),
+ $ MEM(ISEEDPTR), MEM(WORKPTR),
+ $ WORKLEN)
+ ELSE IF( CMEM(OPPTR+J) .EQ. '>' ) THEN
+ CALL IAMXTEST(OUTNUM, VERB, TREP, TCOH, NSCOPE,
+ $ CMEM(SCOPEPTR), NTOP, CMEM(TOPPTR),
+ $ NMAT, MEM(MPTR), MEM(NPTR),
+ $ MEM(LDSPTR), MEM(LDDPTR),
+ $ MEM(LDIPTR), NDEST, MEM(RDESTPTR),
+ $ MEM(CDESTPTR), NGRID, MEM(CTXTPTR),
+ $ MEM(PPTR), MEM(QPTR), MEM(ISEEDPTR),
+ $ MEM(RAPTR), MEM(CAPTR), K,
+ $ MEM(WORKPTR), WORKLEN)
+ ELSE IF( CMEM(OPPTR+J) .EQ. '<' ) THEN
+ CALL IAMNTEST(OUTNUM, VERB, TREP, TCOH, NSCOPE,
+ $ CMEM(SCOPEPTR), NTOP, CMEM(TOPPTR),
+ $ NMAT, MEM(MPTR), MEM(NPTR),
+ $ MEM(LDSPTR), MEM(LDDPTR),
+ $ MEM(LDIPTR), NDEST, MEM(RDESTPTR),
+ $ MEM(CDESTPTR), NGRID, MEM(CTXTPTR),
+ $ MEM(PPTR), MEM(QPTR), MEM(ISEEDPTR),
+ $ MEM(RAPTR), MEM(CAPTR), K,
+ $ MEM(WORKPTR), WORKLEN)
+ END IF
+ ELSE IF( PREC(I) .EQ. 'S' ) THEN
+ WORKPTR = SAFEINDEX(MEMUSED, ISIZE, SSIZE)
+ WORKLEN = ( DSIZE * (MEMLEN - WORKPTR + 1) ) / SSIZE
+ IF( CMEM(OPPTR+J) .EQ. '+' ) THEN
+ CALL SSUMTEST(OUTNUM, VERB, TREP, TCOH, NSCOPE,
+ $ CMEM(SCOPEPTR), NTOP, CMEM(TOPPTR),
+ $ NMAT, MEM(MPTR), MEM(NPTR),
+ $ MEM(LDSPTR), MEM(LDDPTR), NDEST,
+ $ MEM(RDESTPTR), MEM(CDESTPTR), NGRID,
+ $ MEM(CTXTPTR), MEM(PPTR), MEM(QPTR),
+ $ MEM(ISEEDPTR), MEM(WORKPTR),
+ $ WORKLEN)
+ ELSE IF( CMEM(OPPTR+J) .EQ. '>' ) THEN
+ CALL SAMXTEST(OUTNUM, VERB, TREP, TCOH, NSCOPE,
+ $ CMEM(SCOPEPTR), NTOP, CMEM(TOPPTR),
+ $ NMAT, MEM(MPTR), MEM(NPTR),
+ $ MEM(LDSPTR), MEM(LDDPTR),
+ $ MEM(LDIPTR), NDEST, MEM(RDESTPTR),
+ $ MEM(CDESTPTR), NGRID, MEM(CTXTPTR),
+ $ MEM(PPTR), MEM(QPTR), MEM(ISEEDPTR),
+ $ MEM(RAPTR), MEM(CAPTR), K,
+ $ MEM(WORKPTR), WORKLEN)
+ ELSE IF( CMEM(OPPTR+J) .EQ. '<' ) THEN
+ CALL SAMNTEST(OUTNUM, VERB, TREP, TCOH, NSCOPE,
+ $ CMEM(SCOPEPTR), NTOP, CMEM(TOPPTR),
+ $ NMAT, MEM(MPTR), MEM(NPTR),
+ $ MEM(LDSPTR), MEM(LDDPTR),
+ $ MEM(LDIPTR), NDEST, MEM(RDESTPTR),
+ $ MEM(CDESTPTR), NGRID, MEM(CTXTPTR),
+ $ MEM(PPTR), MEM(QPTR), MEM(ISEEDPTR),
+ $ MEM(RAPTR), MEM(CAPTR), K,
+ $ MEM(WORKPTR), WORKLEN)
+ END IF
+ ELSE IF( PREC(I) .EQ. 'C' ) THEN
+ WORKPTR = SAFEINDEX(MEMUSED, ISIZE, CSIZE)
+ WORKLEN = ( DSIZE * (MEMLEN - WORKPTR + 1) ) / CSIZE
+ IF( CMEM(OPPTR+J) .EQ. '+' ) THEN
+ CALL CSUMTEST(OUTNUM, VERB, TREP, TCOH, NSCOPE,
+ $ CMEM(SCOPEPTR), NTOP, CMEM(TOPPTR),
+ $ NMAT, MEM(MPTR), MEM(NPTR),
+ $ MEM(LDSPTR), MEM(LDDPTR), NDEST,
+ $ MEM(RDESTPTR), MEM(CDESTPTR), NGRID,
+ $ MEM(CTXTPTR), MEM(PPTR), MEM(QPTR),
+ $ MEM(ISEEDPTR), MEM(WORKPTR),
+ $ WORKLEN)
+ ELSE IF( CMEM(OPPTR+J) .EQ. '>' ) THEN
+ CALL CAMXTEST(OUTNUM, VERB, TREP, TCOH, NSCOPE,
+ $ CMEM(SCOPEPTR), NTOP, CMEM(TOPPTR),
+ $ NMAT, MEM(MPTR), MEM(NPTR),
+ $ MEM(LDSPTR), MEM(LDDPTR),
+ $ MEM(LDIPTR), NDEST, MEM(RDESTPTR),
+ $ MEM(CDESTPTR), NGRID, MEM(CTXTPTR),
+ $ MEM(PPTR), MEM(QPTR), MEM(ISEEDPTR),
+ $ MEM(RAPTR), MEM(CAPTR), K,
+ $ MEM(WORKPTR), WORKLEN)
+ ELSE IF( CMEM(OPPTR+J) .EQ. '<' ) THEN
+ CALL CAMNTEST(OUTNUM, VERB, TREP, TCOH, NSCOPE,
+ $ CMEM(SCOPEPTR), NTOP, CMEM(TOPPTR),
+ $ NMAT, MEM(MPTR), MEM(NPTR),
+ $ MEM(LDSPTR), MEM(LDDPTR),
+ $ MEM(LDIPTR), NDEST, MEM(RDESTPTR),
+ $ MEM(CDESTPTR), NGRID, MEM(CTXTPTR),
+ $ MEM(PPTR), MEM(QPTR), MEM(ISEEDPTR),
+ $ MEM(RAPTR), MEM(CAPTR), K,
+ $ MEM(WORKPTR), WORKLEN)
+ END IF
+ ELSE IF( PREC(I) .EQ. 'Z' ) THEN
+ WORKPTR = SAFEINDEX(MEMUSED, ISIZE, ZSIZE)
+ WORKLEN = ( DSIZE * (MEMLEN - WORKPTR + 1) ) / ZSIZE
+ IF( CMEM(OPPTR+J) .EQ. '+' ) THEN
+ CALL ZSUMTEST(OUTNUM, VERB, TREP, TCOH, NSCOPE,
+ $ CMEM(SCOPEPTR), NTOP, CMEM(TOPPTR),
+ $ NMAT, MEM(MPTR), MEM(NPTR),
+ $ MEM(LDSPTR), MEM(LDDPTR), NDEST,
+ $ MEM(RDESTPTR), MEM(CDESTPTR), NGRID,
+ $ MEM(CTXTPTR), MEM(PPTR), MEM(QPTR),
+ $ MEM(ISEEDPTR), MEM(WORKPTR),
+ $ WORKLEN)
+ ELSE IF( CMEM(OPPTR+J) .EQ. '>' ) THEN
+ CALL ZAMXTEST(OUTNUM, VERB, TREP, TCOH, NSCOPE,
+ $ CMEM(SCOPEPTR), NTOP, CMEM(TOPPTR),
+ $ NMAT, MEM(MPTR), MEM(NPTR),
+ $ MEM(LDSPTR), MEM(LDDPTR),
+ $ MEM(LDIPTR), NDEST, MEM(RDESTPTR),
+ $ MEM(CDESTPTR), NGRID, MEM(CTXTPTR),
+ $ MEM(PPTR), MEM(QPTR), MEM(ISEEDPTR),
+ $ MEM(RAPTR), MEM(CAPTR), K,
+ $ MEM(WORKPTR), WORKLEN)
+ ELSE IF( CMEM(OPPTR+J) .EQ. '<' ) THEN
+ CALL ZAMNTEST(OUTNUM, VERB, TREP, TCOH, NSCOPE,
+ $ CMEM(SCOPEPTR), NTOP, CMEM(TOPPTR),
+ $ NMAT, MEM(MPTR), MEM(NPTR),
+ $ MEM(LDSPTR), MEM(LDDPTR),
+ $ MEM(LDIPTR), NDEST, MEM(RDESTPTR),
+ $ MEM(CDESTPTR), NGRID, MEM(CTXTPTR),
+ $ MEM(PPTR), MEM(QPTR), MEM(ISEEDPTR),
+ $ MEM(RAPTR), MEM(CAPTR), K,
+ $ MEM(WORKPTR), WORKLEN)
+ END IF
+ END IF
+ 50 CONTINUE
+ 60 CONTINUE
+ CALL FREEGRIDS( NGRID, MEM(CTXTPTR) )
+ END IF
+*
+ IF( TESTAUX ) THEN
+ CALL AUXTEST( OUTNUM, MEM, MEMLEN )
+ END IF
+*
+ 1000 FORMAT('AUXILIARY ERROR - IAM MISMATCH: BLACS_PINFO RETURNED',I4,
+ $ /,' BLACS_SETUP RETURNED',I4,'.')
+ 1500 FORMAT('AUXILIARY ERROR - NPROC MISMATCH: BLACS_PINFO RETURNED',
+ $ I4,/,' BLACS_SETUP RETURNED',I4,', TESTER THINKS',I4,'.')
+ 2000 FORMAT('BEGINNING BLACS TESTING, BLACS DEBUG LEVEL =',I2)
+ 3000 FORMAT('==============================================')
+ RETURN
+*
+* End of RUNTESTS
+*
+ END
+*
+ SUBROUTINE MAKEGRIDS( CONTEXTS, OUTNUM, NGRIDS, P, Q )
+ INTEGER NGRIDS, OUTNUM
+ INTEGER CONTEXTS(NGRIDS), P(NGRIDS), Q(NGRIDS)
+ INTEGER IBTMYPROC
+ EXTERNAL IBTMYPROC
+ INTEGER NPROW, NPCOL, MYROW, MYCOL, I
+*
+ DO 10 I = 1, NGRIDS
+ CALL BLACS_GET( 0, 0, CONTEXTS(I) )
+ CALL BLACS_GRIDINIT( CONTEXTS(I), 'r', P(I), Q(I) )
+ 10 CONTINUE
+*
+ DO 20 I = 1, NGRIDS
+ CALL BLACS_GRIDINFO( CONTEXTS(I), NPROW, NPCOL, MYROW, MYCOL )
+ IF( NPROW .GT. 0 ) THEN
+ IF( NPROW.NE.P(I) .OR. NPCOL.NE.Q(I) ) THEN
+ IF( IBTMYPROC() .NE. 0 ) OUTNUM = 6
+ WRITE(OUTNUM,1000) I
+ IF( OUTNUM .NE. 6 .AND. OUTNUM .NE. 0 ) CLOSE(OUTNUM)
+ CALL BLACS_ABORT( CONTEXTS(I), -1 )
+ END IF
+ END IF
+ 20 CONTINUE
+*
+ 1000 FORMAT('Grid creation error trying to create grid #',I3)
+ RETURN
+ END
+*
+ SUBROUTINE FREEGRIDS( NGRIDS, CONTEXTS )
+ INTEGER NGRIDS
+ INTEGER CONTEXTS(NGRIDS)
+ INTEGER I, NPROW, NPCOL, MYROW, MYCOL
+*
+ DO 10 I = 1, NGRIDS
+ CALL BLACS_GRIDINFO( CONTEXTS(I), NPROW, NPCOL, MYROW, MYCOL )
+ IF( MYROW.LT.NPROW .AND. MYCOL.LT.NPCOL )
+ $ CALL BLACS_GRIDEXIT( CONTEXTS(I) )
+ 10 CONTINUE
+ RETURN
+ END
+*
+ SUBROUTINE AUXTEST( OUTNUM, MEM, MEMLEN )
+*
+* .. Scalar Arguments ..
+ INTEGER OUTNUM, MEMLEN
+* ..
+* .. Array Arguments ..
+ INTEGER MEM(MEMLEN)
+* ..
+* .. External Functions ..
+ LOGICAL ALLPASS
+ INTEGER IBTMYPROC, IBTMSGID, BLACS_PNUM
+ DOUBLE PRECISION DWALLTIME00
+ EXTERNAL ALLPASS, IBTMYPROC, IBTMSGID, BLACS_PNUM
+ EXTERNAL DWALLTIME00
+* ..
+* .. External Subroutines ..
+ EXTERNAL BLACS_PINFO, BLACS_GRIDINIT, BLACS_GRIDMAP
+ EXTERNAL BLACS_FREEBUFF, BLACS_GRIDEXIT, BLACS_ABORT
+ EXTERNAL BLACS_GRIDINFO, BLACS_PCOORD, BLACS_BARRIER
+ EXTERNAL BLACS_SET
+* ..
+* .. Local Scalars ..
+ LOGICAL AUXPASSED, PASSED, IPRINT
+ INTEGER NPROCS, NPROW, NPCOL, MYROW, MYCOL, CTXT, CTXT2, LDA
+ INTEGER I, J, K
+ DOUBLE PRECISION DTIME, DEPS
+* ..
+* .. Local Arrays ..
+ DOUBLE PRECISION START(2), STST(2), KEEP(2)
+* ..
+* .. Executable Statements ..
+*
+ IPRINT = ( IBTMYPROC() .EQ. 0 )
+ IF( IPRINT ) THEN
+ WRITE(OUTNUM,*) ' '
+ WRITE(OUTNUM,1000)
+ WRITE(OUTNUM,*) ' '
+ END IF
+ CALL BLACS_PINFO( I, NPROCS )
+ IF( NPROCS .LT. 2 ) THEN
+ IF( IPRINT )
+ $ WRITE(OUTNUM,*) 'NOT ENOUGH PROCESSES TO PERFORM AUXTESTS'
+ RETURN
+ END IF
+*
+* Make sure BLACS_PNUM and BLACS_PCOORD are inverses of each other
+*
+ IF( IPRINT ) THEN
+ WRITE(OUTNUM,*) ' '
+ WRITE(OUTNUM,*) 'RUNNING BLACS_PNUM/BLACS_PCOORD TEST'
+ END IF
+ PASSED = .TRUE.
+ NPROCS = NPROCS - MOD(NPROCS,2)
+ CALL BLACS_GET( 0, 0, CTXT )
+ CALL BLACS_GRIDINIT( CTXT, 'r', 1, NPROCS )
+ CALL BLACS_GRIDINFO( CTXT, NPROW, NPCOL, MYROW, MYCOL )
+ IF( MYROW.GE.NPROW .OR. MYCOL.GE.NPCOL ) GOTO 100
+ DO 10 I = 1, NPROCS
+ K = BLACS_PNUM( CTXT, 0, I-1 )
+ CALL BLACS_PCOORD( CTXT, BLACS_PNUM( CTXT, 0, I-1 ), J, K )
+ IF( PASSED ) PASSED = ( J.EQ.0 .AND. K.EQ.I-1 )
+ 10 CONTINUE
+ K = 1
+ IF( PASSED ) K = 0
+ CALL IGSUM2D( CTXT, 'a', ' ', 1, 1, K, 1, -1, 0 )
+ PASSED = ( K .EQ. 0 )
+ AUXPASSED = PASSED
+ IF( IPRINT ) THEN
+ IF( PASSED ) THEN
+ WRITE(OUTNUM,*) 'PASSED BLACS_PNUM/BLACS_PCOORD TEST'
+ ELSE
+ WRITE(OUTNUM,*) 'FAILED BLACS_PNUM/BLACS_PCOORD TEST'
+ END IF
+ WRITE(OUTNUM,*) ' '
+ END IF
+*
+* Test to see if DGSUM2D is repeatable when repeatability flag is set
+* Skip test if DGSUM2D is repeatable when repeatability flag is not set
+* NOTE: do not change the EPS calculation loop; it is figured in this
+* strange way so that it ports across platforms
+*
+ IF( IPRINT ) WRITE(OUTNUM,*) 'RUNNING REPEATABLE SUM TEST'
+ J = 0
+ 12 CONTINUE
+ PASSED = .TRUE.
+ START(1) = 1.0D0
+ 15 CONTINUE
+ DEPS = START(1)
+ START(1) = START(1) / 2.0D0
+ STST(1) = 1.0D0 + START(1)
+ IF (STST(1) .NE. 1.0D0) GOTO 15
+*
+ START(1) = DEPS / DBLE(NPCOL-1)
+ IF (MYCOL .EQ. 3) START(1) = 1.0D0
+ START(2) = 7.00005D0 * NPCOL
+ STST(1) = START(1)
+ STST(2) = START(2)
+ CALL BLACS_SET(CTXT, 15, J)
+ CALL DGSUM2D(CTXT, 'a', 'f', 2, 1, STST, 2, -1, 0)
+ KEEP(1) = STST(1)
+ KEEP(2) = STST(2)
+ DO 30 I = 1, 3
+*
+* Have a different guy waste time so he enters combine last
+*
+ IF (MYCOL .EQ. I) THEN
+ DTIME = DWALLTIME00()
+ 20 CONTINUE
+ IF (DWALLTIME00() - DTIME .LT. 2.0D0) GOTO 20
+ END IF
+ STST(1) = START(1)
+ STST(2) = START(2)
+ CALL DGSUM2D(CTXT, 'a', 'f', 2, 1, STST, 2, -1, 0)
+ IF ( (KEEP(1).NE.STST(1)) .OR. (KEEP(2).NE.STST(2)) )
+ $ PASSED = .FALSE.
+ 30 CONTINUE
+ K = 1
+ IF (PASSED) K = 0
+ CALL IGSUM2D( CTXT, 'a', ' ', 1, 1, K, 1, -1, 0 )
+ PASSED = (K .EQ. 0)
+ IF (J .EQ. 0) THEN
+ IF (.NOT.PASSED) THEN
+ J = 1
+ GOTO 12
+ ELSE IF( IPRINT ) THEN
+ WRITE(OUTNUM,*) 'SKIPPED REPEATABLE SUM TEST'
+ WRITE(OUTNUM,*) ' '
+ END IF
+ END IF
+*
+ IF (J .EQ. 1) THEN
+ AUXPASSED = AUXPASSED .AND. PASSED
+ IF( IPRINT ) THEN
+ IF( PASSED ) THEN
+ WRITE(OUTNUM,*) 'PASSED REPEATABLE SUM TEST'
+ ELSE
+ WRITE(OUTNUM,*) 'FAILED REPEATABLE SUM TEST'
+ END IF
+ WRITE(OUTNUM,*) ' '
+ END IF
+ END IF
+*
+* Test BLACS_GRIDMAP: force a column major ordering, starting at an
+* arbitrary processor
+*
+ PASSED = .TRUE.
+ IF( IPRINT ) WRITE(OUTNUM,*) 'RUNNING BLACS_GRIDMAP TEST'
+ NPROW = 2
+ NPCOL = NPROCS / NPROW
+ DO 40 I = 0, NPROCS-1
+ MEM(I+1) = BLACS_PNUM( CTXT, 0, MOD(I+NPCOL, NPROCS) )
+ 40 CONTINUE
+ CALL BLACS_GET( CTXT, 10, CTXT2 )
+ CALL BLACS_GRIDMAP( CTXT2, MEM, NPROW, NPROW, NPCOL )
+ CALL BLACS_GRIDINFO( CTXT2, NPROW, NPCOL, MYROW, MYCOL )
+ PASSED = ( NPROW.EQ.2 .AND. NPCOL.EQ.NPROCS/2 )
+*
+* Fan in pids for final check: Note we assume SD/RV working
+*
+ IF( PASSED ) THEN
+ K = BLACS_PNUM( CTXT2, MYROW, MYCOL )
+ IF( MYROW.EQ.0 .AND. MYCOL.EQ.0 ) THEN
+ DO 60 J = 0, NPCOL-1
+ DO 50 I = 0, NPROW-1
+ IF( I.NE.0 .OR. J.NE.0 )
+ $ CALL IGERV2D( CTXT2, 1, 1, K, 1, I, J )
+ IF ( PASSED )
+ $ PASSED = ( K .EQ. BLACS_PNUM(CTXT2, I, J) )
+ 50 CONTINUE
+ 60 CONTINUE
+ ELSE
+ CALL IGESD2D( CTXT2, 1, 1, K, 1, 0, 0 )
+ END IF
+ END IF
+ K = 1
+ IF ( PASSED ) K = 0
+ CALL IGSUM2D( CTXT, 'a', ' ', 1, 1, K, 1, -1, 0 )
+ PASSED = ( K .EQ. 0 )
+ AUXPASSED = AUXPASSED .AND. PASSED
+ IF( IPRINT ) THEN
+ IF( PASSED ) THEN
+ WRITE(OUTNUM,*) 'PASSED BLACS_GRIDMAP TEST'
+ ELSE
+ WRITE(OUTNUM,*) 'FAILED BLACS_GRIDMAP TEST'
+ END IF
+ WRITE(OUTNUM,*) ' '
+ END IF
+*
+ IF( IPRINT ) WRITE(OUTNUM,*) 'CALL BLACS_FREEBUFF'
+ CALL BLACS_FREEBUFF( CTXT, 0 )
+ CALL BLACS_FREEBUFF( CTXT, 1 )
+ J = 0
+ CALL IGSUM2D( CTXT2, 'All', ' ', 1, 1, J, 1, -1, MYCOL )
+ IF( IPRINT ) THEN
+ WRITE(OUTNUM,*) 'DONE BLACS_FREEBUFF'
+ WRITE(OUTNUM,*) ' '
+ END IF
+*
+* Make sure barriers don't interfere with each other
+*
+ IF( IPRINT ) WRITE(OUTNUM,*) 'CALL BARRIER'
+ CALL BLACS_BARRIER(CTXT2, 'A')
+ CALL BLACS_BARRIER(CTXT2, 'R')
+ CALL BLACS_BARRIER(CTXT2, 'C')
+ CALL BLACS_BARRIER(CTXT2, 'R')
+ CALL BLACS_BARRIER(CTXT2, 'A')
+ CALL BLACS_BARRIER(CTXT2, 'C')
+ CALL BLACS_BARRIER(CTXT2, 'C')
+ CALL BLACS_BARRIER(CTXT2, 'R')
+ CALL BLACS_BARRIER(CTXT2, 'A')
+ J = 0
+ CALL IGSUM2D( CTXT2, 'All', ' ', 1, 1, J, 1, -1, MYCOL )
+ IF( IPRINT ) THEN
+ WRITE(OUTNUM,*) 'DONE BARRIER'
+ WRITE(OUTNUM,*) ' '
+ END IF
+*
+* Ensure contiguous sends are locally-blocking
+*
+ IF( IPRINT ) THEN
+ WRITE(OUTNUM,*) 'The following tests will hang if your BLACS'//
+ $ ' are not locally blocking:'
+ WRITE(OUTNUM,*) 'RUNNING LOCALLY-BLOCKING CONTIGUOUS SEND TEST'
+ END IF
+ K = MIN( MEMLEN, 50000 )
+*
+* Initialize send buffer
+*
+ DO 70 J = 1, K
+ MEM(J) = 1
+ 70 CONTINUE
+*
+ IF( MYROW.EQ.0 .AND. MYCOL.EQ.0 ) THEN
+ CALL IGESD2D( CTXT2, K, 1, MEM, K, NPROW-1, NPCOL-1 )
+ CALL IGESD2D( CTXT2, K, 1, MEM, K, NPROW-1, NPCOL-1 )
+ CALL IGESD2D( CTXT2, K, 1, MEM, K, NPROW-1, NPCOL-1 )
+ CALL IGERV2D( CTXT2, K, 1, MEM, K, NPROW-1, NPCOL-1 )
+ CALL IGERV2D( CTXT2, K, 1, MEM, K, NPROW-1, NPCOL-1 )
+ CALL IGERV2D( CTXT2, K, 1, MEM, K, NPROW-1, NPCOL-1 )
+ ELSE IF( MYROW.EQ.NPROW-1 .AND. MYCOL.EQ.NPCOL-1 ) THEN
+ CALL IGESD2D( CTXT2, K, 1, MEM, K, 0, 0 )
+ CALL IGESD2D( CTXT2, K, 1, MEM, K, 0, 0 )
+ CALL IGESD2D( CTXT2, K, 1, MEM, K, 0, 0 )
+ CALL IGERV2D( CTXT2, K, 1, MEM, K, 0, 0 )
+ CALL IGERV2D( CTXT2, K, 1, MEM, K, 0, 0 )
+ CALL IGERV2D( CTXT2, K, 1, MEM, K, 0, 0 )
+ END IF
+ J = 0
+ CALL IGSUM2D( CTXT2, 'All', ' ', 1, 1, J, 1, -1, MYCOL )
+ IF( IPRINT )
+ $ WRITE(OUTNUM,*) 'PASSED LOCALLY-BLOCKING CONTIGUOUS SEND TEST'
+*
+* Ensure non-contiguous sends are locally-blocking
+*
+ J = 4
+ LDA = K / J
+ I = MAX( 2, LDA / 4 )
+ IF( IPRINT )
+ $ WRITE(OUTNUM,*) 'RUNNING LOCALLY-BLOCKING NON-CONTIGUOUS '//
+ $ 'SEND TEST'
+ IF( MYROW.EQ.0 .AND. MYCOL.EQ.0 ) THEN
+ CALL IGESD2D( CTXT2, I, J, MEM, LDA, NPROW-1, NPCOL-1 )
+ CALL IGESD2D( CTXT2, I, J, MEM, LDA, NPROW-1, NPCOL-1 )
+ CALL IGESD2D( CTXT2, I, J, MEM, LDA, NPROW-1, NPCOL-1 )
+ CALL IGERV2D( CTXT2, I, J, MEM, LDA, NPROW-1, NPCOL-1 )
+ CALL IGERV2D( CTXT2, I, J, MEM, LDA, NPROW-1, NPCOL-1 )
+ CALL IGERV2D( CTXT2, I, J, MEM, LDA, NPROW-1, NPCOL-1 )
+ ELSE IF( MYROW.EQ.NPROW-1 .AND. MYCOL.EQ.NPCOL-1 ) THEN
+ CALL IGESD2D( CTXT2, I, J, MEM, LDA, 0, 0 )
+ CALL IGESD2D( CTXT2, I, J, MEM, LDA, 0, 0 )
+ CALL IGESD2D( CTXT2, I, J, MEM, LDA, 0, 0 )
+ CALL IGERV2D( CTXT2, I, J, MEM, LDA, 0, 0 )
+ CALL IGERV2D( CTXT2, I, J, MEM, LDA, 0, 0 )
+ CALL IGERV2D( CTXT2, I, J, MEM, LDA, 0, 0 )
+ END IF
+ CALL IGSUM2D( CTXT2, 'All', ' ', 1, 1, J, 1, -1, MYCOL )
+ IF( IPRINT ) THEN
+ WRITE(OUTNUM,*)'PASSED LOCALLY-BLOCKING NON-CONTIGUOUS '//
+ $ 'SEND TEST'
+ WRITE(OUTNUM,*) ' '
+ END IF
+*
+* Note that we already tested the message ID setting/getting in
+* first call to IBTMSGID()
+*
+ IF( IPRINT ) WRITE(OUTNUM,*) 'RUNNING BLACS_SET/BLACS_GET TESTS'
+ J = 0
+ CALL BLACS_SET( CTXT2, 11, 3 )
+ CALL BLACS_SET( CTXT2, 12, 2 )
+ CALL BLACS_GET( CTXT2, 12, I )
+ CALL BLACS_GET( CTXT2, 11, K )
+ IF( K.NE.3 ) J = J + 1
+ IF( I.NE.2 ) J = J + 1
+ CALL BLACS_SET( CTXT2, 13, 3 )
+ CALL BLACS_SET( CTXT2, 14, 2 )
+ CALL BLACS_GET( CTXT2, 14, I )
+ CALL BLACS_GET( CTXT2, 13, K )
+ IF( K.NE.3 ) J = J + 1
+ IF( I.NE.2 ) J = J + 1
+*
+* See if anyone had error, and print result
+*
+ CALL IGSUM2D( CTXT2, 'All', ' ', 1, 1, J, 1, -1, MYCOL )
+ PASSED = (J .EQ. 0)
+ AUXPASSED = AUXPASSED .AND. PASSED
+ IF( IPRINT ) THEN
+ IF( PASSED ) THEN
+ WRITE(OUTNUM,*) 'PASSED BLACS_SET/BLACS_GET TESTS'
+ ELSE
+ WRITE(OUTNUM,*) 'FAILED BLACS_SET/BLACS_GET TESTS'
+ END IF
+ WRITE(OUTNUM,*) ' '
+ END IF
+*
+ IF( IPRINT ) WRITE(OUTNUM,*) 'CALL BLACS_GRIDEXIT'
+ CALL BLACS_GRIDEXIT(CTXT)
+ CALL BLACS_GRIDEXIT(CTXT2)
+ IF( IPRINT ) THEN
+ WRITE(OUTNUM,*) 'DONE BLACS_GRIDEXIT'
+ WRITE(OUTNUM,*) ' '
+ END IF
+*
+ 100 CONTINUE
+*
+ PASSED = ALLPASS(AUXPASSED)
+ IF( IPRINT ) THEN
+ WRITE(OUTNUM,*) 'The final auxiliary test is for BLACS_ABORT.'
+ WRITE(OUTNUM,*) 'Immediately after this message, all '//
+ $ 'processes should be killed.'
+ WRITE(OUTNUM,*) 'If processes survive the call, your BLACS_'//
+ $ 'ABORT is incorrect.'
+ END IF
+ CALL BLACS_PINFO( I, NPROCS )
+ CALL BLACS_GET( 0, 0, CTXT )
+ CALL BLACS_GRIDINIT( CTXT, 'r', 1, NPROCS )
+ CALL BLACS_BARRIER(CTXT, 'A')
+ CALL BLACS_GRIDINFO( CTXT, NPROW, NPCOL, MYROW, MYCOL )
+*
+* Test BLACS_ABORT
+*
+ IF( MYROW.EQ.NPROW/2 .AND. MYCOL.EQ.NPCOL/2 ) THEN
+ CALL BLACS_ABORT( CTXT, -1 )
+*
+* Other procs try to cause a hang: should be killed by BLACS_ABORT
+*
+ ELSE
+ I = 1
+110 CONTINUE
+ I = I + 3
+ I = I - 2
+ I = I - 1
+ IF( I.EQ.1 ) GOTO 110
+ end if
+*
+ 1000 FORMAT('AUXILIARY TESTS: BEGIN.')
+ RETURN
+ END
+*
+ SUBROUTINE BTTRANSCHAR(TRANSTO, N, CMEM, IMEM)
+ CHARACTER TRANSTO
+ INTEGER N
+ CHARACTER*1 CMEM(N)
+ INTEGER IMEM(N)
+ INTEGER I
+*
+ IF( TRANSTO .EQ. 'I' ) THEN
+ DO 10 I = 1, N
+ IMEM(I) = ICHAR( CMEM(I) )
+ 10 CONTINUE
+ ELSE
+ DO 20 I = 1, N
+ CMEM(I) = CHAR( IMEM(I) )
+ 20 CONTINUE
+ END IF
+ RETURN
+ END
+*
+ SUBROUTINE BTINFO( TEST, MEMUSED, MEM, MEMLEN, CMEMUSED, CMEM,
+ $ CMEMLEN, OUTNUM, NOP, NSCOPE, TREP, TCOH, NTOP,
+ $ NSHAPE, NMAT, NSRC, NGRID, OPPTR, SCOPEPTR,
+ $ TOPPTR, UPLOPTR, DIAGPTR, MPTR, NPTR, LDSPTR,
+ $ LDDPTR, LDIPTR, RSRCPTR, CSRCPTR, RDESTPTR,
+ $ CDESTPTR, PPTR, QPTR )
+*
+* .. Scalar Arguments ..
+ CHARACTER*1 TEST
+ INTEGER CDESTPTR, CMEMLEN, CMEMUSED, CSRCPTR, DIAGPTR, LDDPTR,
+ $ LDIPTR, LDSPTR, MEMLEN, MEMUSED, MPTR, NGRID, NMAT, NOP,
+ $ NPTR, NSCOPE, NSHAPE, NSRC, NTOP, OPPTR, OUTNUM, PPTR,
+ $ QPTR, RDESTPTR, RSRCPTR, SCOPEPTR, TCOH, TOPPTR, TREP,
+ $ UPLOPTR
+* ..
+* .. Array Arguments ..
+ CHARACTER*1 CMEM(CMEMLEN)
+ INTEGER MEM(MEMLEN)
+* ..
+* .. External Functions ..
+ INTEGER IBTMYPROC, IBTMSGID, IBTSIZEOF
+ EXTERNAL IBTMYPROC, IBTMSGID, IBTSIZEOF
+* ..
+* .. Local Scalars ..
+ INTEGER IAM, ISIZE, DSIZE
+* ..
+* .. Local Arrays ..
+ INTEGER ITMP(2)
+* ..
+* .. Executable Statements ..
+*
+ IAM = IBTMYPROC()
+ IF( IAM .EQ. 0 ) THEN
+ IF( TEST .EQ. 'S' ) THEN
+ CALL RDSDRV( MEMUSED, MEM, MEMLEN, CMEMUSED, CMEM, CMEMLEN,
+ $ OUTNUM )
+ ELSE IF( TEST .EQ. 'B' ) THEN
+ CALL RDBSBR( MEMUSED, MEM, MEMLEN, CMEMUSED, CMEM, CMEMLEN,
+ $ OUTNUM )
+ ELSE
+ CALL RDCOMB( MEMUSED, MEM, MEMLEN, CMEMUSED, CMEM, CMEMLEN,
+ $ OUTNUM )
+ END IF
+ ITMP(1) = MEMUSED
+ ITMP(2) = CMEMUSED
+ CALL BTSEND( 3, 2, ITMP, -1, IBTMSGID()+3 )
+ IF( MEMLEN .GE. MEMUSED + CMEMUSED ) THEN
+ CALL BTTRANSCHAR( 'I', CMEMUSED, CMEM, MEM(MEMUSED+1) )
+ ELSE
+ ISIZE = IBTSIZEOF('I')
+ DSIZE = IBTSIZEOF('D')
+ WRITE(OUTNUM,1000) ( (MEMUSED+CMEMUSED)*ISIZE + DSIZE-1 )
+ $ / DSIZE
+ CALL BLACS_ABORT(-1, -1)
+ END IF
+ CALL BTSEND( 3, MEMUSED+CMEMUSED, MEM, -1, IBTMSGID()+4 )
+ ELSE
+ CALL BTRECV( 3, 2, ITMP, 0, IBTMSGID()+3 )
+ MEMUSED = ITMP(1)
+ CMEMUSED = ITMP(2)
+ IF( MEMLEN .GE. MEMUSED + CMEMUSED ) THEN
+ CALL BTRECV( 3, MEMUSED+CMEMUSED, MEM, 0, IBTMSGID()+4 )
+ CALL BTTRANSCHAR( 'C', CMEMUSED, CMEM, MEM(MEMUSED+1) )
+ ELSE
+ ISIZE = IBTSIZEOF('I')
+ DSIZE = IBTSIZEOF('D')
+ WRITE(OUTNUM,1000) ( (MEMUSED+CMEMUSED)*ISIZE + DSIZE-1 )
+ $ / DSIZE
+ CALL BLACS_ABORT(-1, -1)
+ END IF
+ END IF
+ CALL BTUNPACK( TEST, MEM, MEMUSED, NOP, NSCOPE, TREP, TCOH, NTOP,
+ $ NSHAPE, NMAT, NSRC, NGRID, OPPTR, SCOPEPTR, TOPPTR,
+ $ UPLOPTR, DIAGPTR, MPTR, NPTR, LDSPTR, LDDPTR,
+ $ LDIPTR, RSRCPTR, CSRCPTR, RDESTPTR, CDESTPTR, PPTR,
+ $ QPTR)
+*
+ 1000 FORMAT('MEM array too short to pack CMEM; increase to at least',
+ $ I7)
+*
+ RETURN
+*
+* End BTINFO
+*
+ END
+*
+ SUBROUTINE RDBTIN( TESTSDRV, TESTBSBR, TESTCOMB, TESTAUX, NPREC,
+ $ PREC, VERB, OUTNUM )
+*
+* -- BLACS tester (version 1.0) --
+* University of Tennessee
+* December 15, 1994
+*
+*
+* .. Scalar Arguments ..
+ LOGICAL TESTSDRV, TESTBSBR, TESTCOMB, TESTAUX
+ INTEGER NPREC, OUTNUM, VERB
+* ..
+* .. Array Arguments ..
+ CHARACTER*1 PREC(*)
+* ..
+*
+* Purpose
+* =======
+* RDBTIN: Read and process the top-level input file BT.dat.
+*
+* Arguments
+* =========
+* TESTSDRV (output) LOGICAL
+* Run any point-to-point tests?
+*
+* TESTBSBR (output) LOGICAL
+* Run any broadcast tests?
+*
+* TESTCOMB (output) LOGICAL
+* Run any combine-operation tests (e.g. MAX)
+*
+* TESTAUX (output) LOGICAL
+* Run any auxiliary tests?
+*
+* NPREC (output) INTEGER
+* Number of different precisions to test. (up to 5, as determined
+* by the parameter PRECMAX down in the code.)
+*
+* PREC (output) CHARACTER*1 array, dimension 5
+* Prefix letter of each precision to test, from the set
+* {'C', 'D', 'I', 'S', 'Z'}
+*
+* VERB (output) INTEGER
+* Output verbosity for this test run.
+* 0 = Print only "BEGIN [SDRV/BSBR/COMB]", followed by PASSED
+* or FAILED message
+* 1 = Same as 0, but also prints out header explaining all tests
+* to be run.
+* 2 = Prints out info before and after every individual test.
+*
+* OUTNUM (output) INTEGER
+* Unit number for output file.
+* ======================================================================
+*
+*
+* .. Parameters ..
+ INTEGER PRECMAX, VERBMAX, IN
+ PARAMETER ( PRECMAX = 5, VERBMAX = 2, IN = 11 )
+* ..
+* .. Local Scalars ..
+ INTEGER I
+ CHARACTER*1 CH
+ LOGICAL READERROR
+* ..
+* .. Local Arrays ..
+ CHARACTER*80 HEADER, OUTNAME
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. Executable Statements
+*
+* Open and read the file blacstest.dat. Expected format is
+* -----
+* 'One line of free text intended as a comment for each test run'
+* integer Unit number of output file
+* string Name of output file (ignored if unit = 6)
+* {'T'|'F'} Run any point to point tests?
+* {'T'|'F'} Run any broadcast tests?
+* {'T'|'F'} Run any combine-operator tests?
+* {'T'|'F'} Run the auxiliary tests?
+* integer Number of precisions to test - up to 99
+* array of CHAR*1's Specific precisions to test
+* integer Output verb (1-n, n=most verbose)
+* integer Number of nodes required by largest test case
+* -----
+* Note that the comments to the right of each line are present
+* in the sample blacstest.dat file included with this
+* distribution, but they are not required.
+*
+* The array of CHAR*1's is expected to have length equal to the
+* integer in the previous line - if it is shorter, problems may
+* occur later; if it is longer, the trailing elements will just
+* be ignored. The verb is expected to be an integer
+* between 1 and n inclusive and will be set to 1 if outside
+* this range.
+*
+* Only process 0 should be calling this routine
+*
+ READERROR = .FALSE.
+ OPEN( UNIT = IN, FILE = 'bt.dat', STATUS = 'OLD' )
+ READ(IN, *) HEADER
+ READ(IN, *) OUTNUM
+ READ(IN, *) OUTNAME
+*
+* Open and prepare output file
+*
+ IF( OUTNUM.NE.6 .AND. OUTNUM.NE.0 )
+ $ OPEN( UNIT = OUTNUM, FILE = OUTNAME, STATUS = 'UNKNOWN' )
+ WRITE(OUTNUM, *) HEADER
+*
+* Determine which tests to run
+*
+ READ(IN, *) CH
+ IF( LSAME(CH, 'T') ) THEN
+ TESTSDRV = .TRUE.
+ ELSE IF( LSAME(CH, 'F') ) THEN
+ TESTSDRV = .FALSE.
+ ELSE
+ WRITE(OUTNUM, 1000) 'SDRV', CH
+ READERROR = .TRUE.
+ END IF
+*
+ READ(IN, *) CH
+ IF( LSAME(CH, 'T') ) THEN
+ TESTBSBR = .TRUE.
+ ELSE IF(LSAME( CH, 'F') ) THEN
+ TESTBSBR = .FALSE.
+ ELSE
+ WRITE(OUTNUM, 1000) 'BSBR', CH
+ READERROR = .TRUE.
+ END IF
+*
+ READ(IN, *) CH
+ IF( LSAME(CH, 'T') ) THEN
+ TESTCOMB = .TRUE.
+ ELSE IF( LSAME(CH, 'F') ) THEN
+ TESTCOMB = .FALSE.
+ ELSE
+ WRITE(OUTNUM, 1000) 'COMB', CH
+ READERROR = .TRUE.
+ END IF
+*
+ READ(IN, *) CH
+ IF( LSAME(CH, 'T') ) THEN
+ TESTAUX = .TRUE.
+ ELSE IF( LSAME(CH, 'F') ) THEN
+ TESTAUX = .FALSE.
+ ELSE
+ WRITE(OUTNUM, 1000) 'AUX ', CH
+ READERROR = .TRUE.
+ END IF
+*
+* Get # of precisions, and precisions to test
+*
+ READ(IN, *) NPREC
+ IF( NPREC .LT. 0 ) THEN
+ NPREC = 0
+ ELSE IF( NPREC. GT. PRECMAX ) THEN
+ WRITE(OUTNUM, 2000) NPREC, PRECMAX, PRECMAX
+ NPREC = PRECMAX
+ END IF
+*
+ READ(IN, *) ( PREC(I), I = 1, NPREC )
+ DO 100 I = 1, NPREC
+ IF( LSAME(PREC(I), 'C') ) THEN
+ PREC(I) = 'C'
+ ELSE IF( LSAME(PREC(I), 'D') ) THEN
+ PREC(I) = 'D'
+ ELSE IF( LSAME(PREC(I), 'I') ) THEN
+ PREC(I) = 'I'
+ ELSE IF( LSAME(PREC(I), 'S') ) THEN
+ PREC(I) = 'S'
+ ELSE IF( LSAME(PREC(I), 'Z') ) THEN
+ PREC(I) = 'Z'
+ ELSE
+ WRITE(OUTNUM, 3000) PREC(I)
+ READERROR = .TRUE.
+ END IF
+ 100 CONTINUE
+*
+ READ(IN, *) VERB
+*
+ IF( VERB .GT. VERBMAX ) THEN
+ WRITE(OUTNUM, 4000) VERB, VERBMAX, VERBMAX
+ VERB = VERBMAX
+ ELSE IF( VERB .LT. 0 ) THEN
+ WRITE(OUTNUM, 5000) VERB
+ VERB = 0
+ END IF
+*
+* Abort if there was a fatal error
+*
+ IF( READERROR ) THEN
+ WRITE(OUTNUM, 6000)
+ IF( OUTNUM .NE. 6 .AND. OUTNUM .NE. 0 ) CLOSE( OUTNUM )
+ STOP
+ END IF
+*
+ 1000 FORMAT( 'INVALID CHARACTER FOR ',A4,' TESTS ''', A1,
+ $ ''' (EXPECTED T/F)' )
+ 2000 FORMAT( 'NUMBER OF PRECISIONS ', I6, ' GREATER THAN ', I6,
+ $ ' - SETTING TO ', I6, '.')
+ 3000 FORMAT( 'UNRECOGNIZABLE PRECISION ENTRY ''', A1,
+ $ ''' - EXPECTED ''C'', ''D'', ''I'', ''S'', OR ''Z''.')
+ 4000 FORMAT( 'VERBOSITY ', I4, ' GREATER THAN ',I4,
+ $ ' - SETTING TO ',I4,'.')
+ 5000 FORMAT( 'VERBOSITY ', I4, ' LESS THAN 0 - SETTING TO 0' )
+ 6000 FORMAT( 'FATAL INPUT FILE ERROR - ABORTING RUN.' )
+*
+ RETURN
+*
+* End of RDBTIN
+*
+ END
+*
+ INTEGER FUNCTION IBTMSGID()
+*
+* -- BLACS tester (version 1.0) --
+* University of Tennessee
+* December 15, 1994
+*
+*
+* PURPOSE
+* =======
+* IBTMSGID : returns a ID for tester communication.
+*
+ INTEGER MINID
+ INTEGER ITMP(2)
+ SAVE MINID
+ DATA MINID /-1/
+*
+* On first call, reserve 1st 1000 IDs for tester use
+*
+ IF (MINID .EQ. -1) THEN
+ CALL BLACS_GET( -1, 1, ITMP )
+ MINID = ITMP(1)
+ ITMP(1) = ITMP(1) + 1000
+ CALL BLACS_SET( -1, 1, ITMP )
+ END IF
+*
+* return the minimum allowable ID
+*
+ IBTMSGID = MINID
+*
+ RETURN
+ END
+*
+ SUBROUTINE BTUNPACK(TEST, MEM, MEMLEN, NOP, NSCOPE, TREP, TCOH,
+ $ NTOP, NSHAPE, NMAT, NSRC, NGRID, OPPTR,
+ $ SCOPEPTR, TOPPTR, UPLOPTR, DIAGPTR, MPTR,
+ $ NPTR, LDSPTR, LDDPTR, LDIPTR, RSRCPTR,
+ $ CSRCPTR, RDESTPTR, CDESTPTR, PPTR, QPTR)
+*
+* -- BLACS tester (version 1.0) --
+* University of Tennessee
+* December 15, 1994
+*
+*
+* .. Scalar Arguments ..
+ CHARACTER*1 TEST
+ INTEGER CDESTPTR, CSRCPTR, DIAGPTR, LDDPTR, LDIPTR, LDSPTR,
+ $ MEMLEN, MPTR, NGRID, NMAT, NOP, NPTR, NSCOPE, NSHAPE,
+ $ NSRC, NTOP, OPPTR, PPTR, QPTR, RDESTPTR, RSRCPTR,
+ $ SCOPEPTR, TCOH, TOPPTR, TREP, UPLOPTR
+* ..
+* .. Array Arguments ..
+ INTEGER MEM(MEMLEN)
+* ..
+*
+* Purpose
+* =======
+* BTUNPACK: Figure pointers into MEM where the various input values
+* are stored.
+*
+* Arguments
+* =========
+* TEST (input) CHARACTER*1
+* The test we're unpacking for:
+* = 'S' : SDRV test
+* = 'B' : BSBR test
+* = 'C' : Combine test
+*
+* MEM (input) INTEGER array of dimension MEMLEN
+* Memory containing values and number of items.
+*
+* MEMLEN (input/output) INTEGER
+* The number of elements that are used in MEM.
+*
+* .
+* .
+* .
+*
+* =====================================================================
+*
+* .. Local Scalars ..
+ INTEGER NDEST, NLDI
+* ..
+* .. Executable Statements ..
+*
+* Test is SDRV
+*
+ IF( TEST .EQ. 'S' ) THEN
+ NOP = 0
+ NSHAPE = MEM(MEMLEN-3)
+ NSCOPE = 0
+ TREP = 0
+ TCOH = 0
+ NTOP = 0
+ NMAT = MEM(MEMLEN-2)
+ NLDI = 0
+ NSRC = MEM(MEMLEN-1)
+ NDEST = NSRC
+ NGRID = MEM(MEMLEN)
+ MEMLEN = MEMLEN - 3
+*
+* Test is BSBR
+*
+ ELSE IF ( TEST .EQ. 'B' ) THEN
+ NOP = 0
+ NSCOPE = MEM(MEMLEN-5)
+ TREP = 0
+ TCOH = 0
+ NTOP = MEM(MEMLEN-4)
+ NSHAPE = MEM(MEMLEN-3)
+ NMAT = MEM(MEMLEN-2)
+ NLDI = 0
+ NSRC = MEM(MEMLEN-1)
+ NDEST = 0
+ NGRID = MEM(MEMLEN)
+ MEMLEN = MEMLEN - 5
+*
+* Test is COMB
+*
+ ELSE
+ NOP = MEM(MEMLEN-7)
+ NSCOPE = MEM(MEMLEN-6)
+ TREP = MEM(MEMLEN-5)
+ TCOH = MEM(MEMLEN-4)
+ NTOP = MEM(MEMLEN-3)
+ NSHAPE = 0
+ NMAT = MEM(MEMLEN-2)
+ NLDI = NMAT
+ NSRC = 0
+ NDEST = MEM(MEMLEN-1)
+ NGRID = MEM(MEMLEN)
+ MEMLEN = MEMLEN - 6
+ END IF
+ OPPTR = 1
+ SCOPEPTR = OPPTR + NOP
+ TOPPTR = SCOPEPTR + NSCOPE
+ UPLOPTR = TOPPTR + NTOP
+ DIAGPTR = UPLOPTR + NSHAPE
+ MPTR = 1
+ NPTR = MPTR + NMAT
+ LDSPTR = NPTR + NMAT
+ LDDPTR = LDSPTR + NMAT
+ LDIPTR = LDDPTR + NMAT
+ RSRCPTR = LDIPTR + NLDI
+ CSRCPTR = RSRCPTR + NSRC
+ RDESTPTR = CSRCPTR + NSRC
+ CDESTPTR = RDESTPTR + NDEST
+ PPTR = CDESTPTR + NDEST
+ QPTR = PPTR + NGRID
+ IF( NSRC .EQ. 0 ) NSRC = NDEST
+*
+ RETURN
+*
+* End of BTUNPACK
+*
+ END
+*
+ INTEGER FUNCTION SAFEINDEX(INDX, SIZE1, SIZE2)
+*
+* .. Scalar Arguments ..
+ INTEGER INDX, SIZE1, SIZE2
+* ..
+*
+* If you have an array with elements of SIZE1 bytes, of which you
+* have used INDX-1 elements, returns the index necessary to keep it
+* on a SIZE2 boundary (assuming it was SIZE2 aligned in the first place).
+*
+* .. Local scalars ..
+ INTEGER I
+* ..
+* .. Executable Statements ..
+*
+* Take into account that Fortran starts arrays at 1, not 0
+*
+ I = INDX - 1
+ 10 CONTINUE
+ IF( MOD(I*SIZE1, SIZE2) .EQ. 0 ) GOTO 20
+ I = I + 1
+ GOTO 10
+ 20 CONTINUE
+*
+ SAFEINDEX = I + 1
+*
+ RETURN
+ END
+*
+*
+ SUBROUTINE RDSDRV( MEMUSED, MEM, MEMLEN, CMEMUSED, CMEM, CMEMLEN,
+ $ OUTNUM )
+*
+* -- BLACS tester (version 1.0) --
+* University of Tennessee
+* December 15, 1994
+*
+*
+* .. Scalar Arguments ..
+ INTEGER MEMUSED, MEMLEN, CMEMUSED, CMEMLEN, OUTNUM
+* ..
+* .. Array Arguments ..
+ CHARACTER*1 CMEM(CMEMLEN)
+ INTEGER MEM(MEMLEN)
+* ..
+*
+* Purpose
+* =======
+* RDSDRV: Read and process the input file SDRV.dat.
+*
+* Arguments
+* =========
+* MEMUSED (output) INTEGER
+* Number of elements in MEM that this subroutine ends up using.
+*
+* MEM (output) INTEGER array of dimension memlen
+* On output, holds information read in from sdrv.dat.
+*
+* MEMLEN (input) INTEGER
+* Number of elements of MEM that this subroutine
+* may safely write into.
+*
+* CMEMUSED (output) INTEGER
+* Number of elements in CMEM that this subroutine ends up using.
+*
+* CMEM (output) CHARACTER*1 array of dimension cmemlen
+* On output, holds the values for UPLO and DIAG.
+*
+* CMEMLEN (input) INTEGER
+* Number of elements of CMEM that this subroutine
+* may safely write into.
+*
+* OUTNUM (input) INTEGER
+* Unit number of the output file.
+*
+* =================================================================
+*
+* .. Parameters ..
+ INTEGER SDIN
+ PARAMETER( SDIN = 12 )
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. Local Scalars ..
+ INTEGER NSHAPE, NMAT, NSRC, NGRID, I, J
+ INTEGER UPLOPTR, DIAGPTR, MPTR, NPTR, LDSPTR, LDDPTR, RSRCPTR
+ INTEGER CSRCPTR, RDESTPTR, CDESTPTR, PPTR, QPTR
+* ..
+* .. Executable Statements
+*
+* Open and read the file sdrv.dat. The expected format is
+* below.
+*
+*------
+*integer number of shapes of the matrix
+*array of CHAR*1's UPLO
+*array of CHAR*1's DIAG: unit diagonal or not?
+*integer number of nmat
+*array of integers M: number of rows in matrix
+*array of integers N: number of columns in matrix
+*integer LDA: leading dimension on source proc
+*integer LDA: leading dimension on dest proc
+*integer number of source/dest pairs
+*array of integers RSRC: process row of message source
+*array of integers CSRC: process column of msg. src.
+*array of integers RDEST: process row of msg. dest.
+*array of integers CDEST: process column of msg. dest.
+*integer Number of grids
+*array of integers NPROW: number of rows in process grid
+*array of integers NPCOL: number of col's in proc. grid
+*------
+* note: UPLO stands for 'upper or lower trapezoidal or general
+* rectangular.'
+* note: the text descriptions as shown above are present in
+* the sample sdrv.dat included with this distribution,
+* but are not required.
+*
+* Read input file
+*
+ MEMUSED = 1
+ CMEMUSED = 1
+ OPEN(UNIT = SDIN, FILE = 'sdrv.dat', STATUS = 'OLD')
+*
+* Read in number of shapes, and values of UPLO and DIAG
+*
+ READ(SDIN, *) NSHAPE
+ UPLOPTR = CMEMUSED
+ DIAGPTR = UPLOPTR + NSHAPE
+ CMEMUSED = DIAGPTR + NSHAPE
+ IF ( CMEMUSED .GT. CMEMLEN ) THEN
+ WRITE(OUTNUM, 1000) CMEMLEN, NSHAPE, 'MATRIX SHAPES.'
+ IF( OUTNUM .NE. 6 .AND. OUTNUM .NE. 0 ) CLOSE(OUTNUM)
+ STOP
+ ELSE IF( NSHAPE .LT. 1 ) THEN
+ WRITE(OUTNUM, 2000) 'MATRIX SHAPE.'
+ IF( OUTNUM .NE. 6 .AND. OUTNUM .NE. 0 ) CLOSE(OUTNUM)
+ STOP
+ END IF
+*
+* Read in, upcase, and fatal error if UPLO/DIAG not recognized
+*
+ READ(SDIN, *) ( CMEM(UPLOPTR+I), I = 0, NSHAPE-1 )
+ DO 30 I = 0, NSHAPE-1
+ IF( LSAME(CMEM(UPLOPTR+I), 'G') ) THEN
+ CMEM(UPLOPTR+I) = 'G'
+ ELSE IF( LSAME(CMEM(UPLOPTR+I), 'U') ) THEN
+ CMEM(UPLOPTR+I) = 'U'
+ ELSE IF( LSAME(CMEM(UPLOPTR+I), 'L') ) THEN
+ CMEM(UPLOPTR+I) = 'L'
+ ELSE
+ WRITE(OUTNUM, 3000) 'UPLO ', CMEM(UPLOPTR+I)
+ IF( OUTNUM .NE. 6 .AND. OUTNUM .NE. 0 ) CLOSE(OUTNUM)
+ STOP
+ END IF
+ 30 CONTINUE
+*
+ READ(SDIN, *) ( CMEM(DIAGPTR+I), I = 0, NSHAPE-1 )
+ DO 40 I = 0, NSHAPE-1
+ IF( CMEM(UPLOPTR+I) .NE. 'G' ) THEN
+ IF( LSAME(CMEM(DIAGPTR+I), 'U') ) THEN
+ CMEM( DIAGPTR+I ) = 'U'
+ ELSE IF( LSAME(CMEM(DIAGPTR+I), 'N') ) THEN
+ CMEM(DIAGPTR+I) = 'N'
+ ELSE
+ WRITE(OUTNUM, 3000) 'DIAG ', CMEM(DIAGPTR+I)
+ IF( OUTNUM .NE. 6 .AND. OUTNUM .NE. 0 ) CLOSE(OUTNUM)
+ STOP
+ END IF
+ END IF
+ 40 CONTINUE
+*
+* Read in number of matrices, and values for M, N, LDASRC, and LDADEST
+*
+ READ(SDIN, *) NMAT
+ MPTR = MEMUSED
+ NPTR = MPTR + NMAT
+ LDSPTR = NPTR + NMAT
+ LDDPTR = LDSPTR + NMAT
+ MEMUSED = LDDPTR + NMAT
+ IF( MEMUSED .GT. MEMLEN ) THEN
+ WRITE(OUTNUM, 1000) MEMLEN, NMAT, 'MATRICES.'
+ IF( OUTNUM .NE. 6 .AND. OUTNUM .NE. 0 ) CLOSE(OUTNUM)
+ STOP
+ ELSE IF( NMAT .LT. 1 ) THEN
+ WRITE(OUTNUM, 2000) 'MATRIX.'
+ IF( OUTNUM .NE. 6 .AND. OUTNUM .NE. 0 ) CLOSE(OUTNUM)
+ STOP
+ END IF
+ READ(SDIN, *) ( MEM( MPTR+I ), I = 0, NMAT-1 )
+ READ(SDIN, *) ( MEM( NPTR+I ), I = 0, NMAT-1 )
+ READ(SDIN, *) ( MEM( LDSPTR+I ), I = 0, NMAT-1 )
+ READ(SDIN, *) ( MEM( LDDPTR+I ), I = 0, NMAT-1 )
+*
+* Make sure matrix values are legal
+*
+ CALL CHKMATDAT( OUTNUM, 'SDRV.dat', .FALSE., NMAT, MEM(MPTR),
+ $ MEM(NPTR), MEM(LDSPTR), MEM(LDDPTR), MEM(LDDPTR) )
+*
+* Read in number of src/dest pairs, and values of src/dest
+*
+ READ(SDIN, *) NSRC
+ RSRCPTR = MEMUSED
+ CSRCPTR = RSRCPTR + NSRC
+ RDESTPTR = CSRCPTR + NSRC
+ CDESTPTR = RDESTPTR + NSRC
+ MEMUSED = CDESTPTR + NSRC
+ IF( MEMUSED .GT. MEMLEN ) THEN
+ WRITE(OUTNUM, 1000) MEMLEN, NMAT, 'SRC/DEST.'
+ IF( OUTNUM .NE. 6 .AND. OUTNUM .NE. 0 ) CLOSE(OUTNUM)
+ STOP
+ ELSE IF( NSRC .LT. 1 ) THEN
+ WRITE(OUTNUM, 2000) 'SRC/DEST.'
+ IF( OUTNUM .NE. 6 .AND. OUTNUM .NE. 0 ) CLOSE(OUTNUM)
+ STOP
+ END IF
+ READ(SDIN, *) ( MEM(RSRCPTR+I), I = 0, NSRC-1 )
+ READ(SDIN, *) ( MEM(CSRCPTR+I), I = 0, NSRC-1 )
+ READ(SDIN, *) ( MEM(RDESTPTR+I), I = 0, NSRC-1 )
+ READ(SDIN, *) ( MEM(CDESTPTR+I), I = 0, NSRC-1 )
+*
+* Read in number of grids pairs, and values of P (process rows) and
+* Q (process columns)
+*
+ READ(SDIN, *) NGRID
+ PPTR = MEMUSED
+ QPTR = PPTR + NGRID
+ MEMUSED = QPTR + NGRID
+ IF( MEMUSED .GT. MEMLEN ) THEN
+ WRITE(OUTNUM, 1000) MEMLEN, NGRID, 'PROCESS GRIDS.'
+ IF( OUTNUM .NE. 6 .AND. OUTNUM .NE. 0 ) CLOSE(OUTNUM)
+ STOP
+ ELSE IF( NGRID .LT. 1 ) THEN
+ WRITE(OUTNUM, 2000) 'PROCESS GRID'
+ IF( OUTNUM .NE. 6 .AND. OUTNUM .NE. 0 ) CLOSE( OUTNUM )
+ STOP
+ END IF
+*
+ READ(SDIN, *) ( MEM(PPTR+I), I = 0, NGRID-1 )
+ READ(SDIN, *) ( MEM(QPTR+I), I = 0, NGRID-1 )
+ IF( SDIN .NE. 6 .AND. SDIN .NE. 0 ) CLOSE( SDIN )
+*
+* Fatal error if we've got an illegal grid
+*
+ DO 70 J = 0, NGRID-1
+ IF( MEM(PPTR+J).LT.1 .OR. MEM(QPTR+J).LT.1 ) THEN
+ WRITE(OUTNUM, 4000) MEM(PPTR+J), MEM(QPTR+J)
+ IF( OUTNUM .NE. 6 .AND. OUTNUM .NE. 0 ) CLOSE(OUTNUM)
+ STOP
+ END IF
+ 70 CONTINUE
+*
+* Prepare output variables
+*
+ MEM(MEMUSED) = NSHAPE
+ MEM(MEMUSED+1) = NMAT
+ MEM(MEMUSED+2) = NSRC
+ MEM(MEMUSED+3) = NGRID
+ MEMUSED = MEMUSED + 3
+ CMEMUSED = CMEMUSED - 1
+*
+ 1000 FORMAT('Mem too short (',I4,') to handle',I4,' ',A20)
+ 2000 FORMAT('Must have at least one ',A20)
+ 3000 FORMAT('UNRECOGNIZABLE ',A5,' ''', A1, '''.')
+ 4000 FORMAT('Illegal process grid: {',I3,',',I3,'}.')
+*
+ RETURN
+*
+* End of RDSDRV.
+*
+ END
+*
+ SUBROUTINE CHKMATDAT( NOUT, INFILE, TSTFLAG, NMAT, M0, N0,
+ $ LDAS0, LDAD0, LDI0 )
+*
+* -- BLACS tester (version 1.0) --
+* University of Tennessee
+* December 15, 1994
+*
+*
+* .. Scalar Arguments ..
+ LOGICAL TSTFLAG
+ INTEGER NOUT, NMAT
+* ..
+* .. Array Arguments ..
+ CHARACTER*8 INFILE
+ INTEGER M0(NMAT), N0(NMAT), LDAS0(NMAT), LDAD0(NMAT), LDI0(NMAT)
+* ..
+* Purpose
+* =======
+* CHKMATDAT: Checks that matrix data is correct.
+*
+* Arguments
+* =========
+* NOUT (input) INTEGER
+* The device number to write output to.
+*
+* INFILE (input) CHARACTER*8
+* The name of the input file where matrix values came from.
+*
+* TSTFLAG (input) LOGICAL
+* Whether to test RCFLAG (LDI) values or not.
+*
+* NMAT (input) INTEGER
+* The number of matrices to be tested.
+*
+* M0 (input) INTEGER array of dimension (NMAT)
+* Values of M to be tested.
+*
+* M0 (input) INTEGER array of dimension (NMAT)
+* Values of M to be tested.
+*
+* N0 (input) INTEGER array of dimension (NMAT)
+* Values of N to be tested.
+*
+* LDAS0 (input) INTEGER array of dimension (NMAT)
+* Values of LDAS (leading dimension of A on source process)
+* to be tested.
+*
+* LDAD0 (input) INTEGER array of dimension (NMAT)
+* Values of LDAD (leading dimension of A on destination
+* process) to be tested.
+*
+* ====================================================================
+*
+* .. Local Scalars ..
+ LOGICAL MATOK
+ INTEGER I
+* ..
+* .. Executable Statements ..
+ MATOK = .TRUE.
+ DO 10 I = 1, NMAT
+ IF( M0(I) .LT. 0 ) THEN
+ WRITE(NOUT,1000) INFILE, 'M', M0(I)
+ MATOK = .FALSE.
+ ELSE IF( N0(I) .LT. 0 ) THEN
+ WRITE(NOUT,1000) INFILE, 'N', N0(I)
+ MATOK = .FALSE.
+ ELSE IF( LDAS0(I) .LT. M0(I) ) THEN
+ WRITE(NOUT,2000) INFILE, 'LDASRC', LDAS0(I), M0(I)
+ MATOK = .FALSE.
+ ELSE IF( LDAD0(I) .LT. M0(I) ) THEN
+ WRITE(NOUT,2000) INFILE, 'LDADST', LDAD0(I), M0(I)
+ MATOK = .FALSE.
+ ELSE IF( TSTFLAG ) THEN
+ IF( (LDI0(I).LT.M0(I)) .AND. (LDI0(I).NE.-1) ) THEN
+ WRITE(NOUT,2000) INFILE, 'RCFLAG', LDI0(I), M0(I)
+ MATOK = .FALSE.
+ END IF
+ END IF
+ 10 CONTINUE
+*
+ IF( .NOT.MATOK ) THEN
+ IF( NOUT .NE. 6 .AND. NOUT .NE. 0 ) CLOSE(NOUT)
+ CALL BLACS_ABORT(-1, 1)
+ END IF
+*
+ 1000 FORMAT(A8,' INPUT ERROR: Illegal ',A1,'; value=',I6,'.')
+ 2000 FORMAT(A8,' INPUT ERROR: Illegal ',A6,'; value=',I6,', but M=',I6)
+*
+ RETURN
+ END
+*
+ LOGICAL FUNCTION ALLPASS( THISTEST )
+*
+* -- BLACS tester (version 1.0) --
+* University of Tennessee
+* December 15, 1994
+*
+*
+* .. Scalar Arguments ..
+ LOGICAL THISTEST
+* ..
+* Purpose
+* =======
+* ALLPASS: Returns whether all tests have passed so far.
+*
+* =====================================================================
+*
+* .. Local Scalars ..
+ LOGICAL PASSHIST
+* ..
+* .. Save Statement ..
+ SAVE PASSHIST
+* ..
+* .. Data Statements ..
+ DATA PASSHIST /.TRUE./
+* ..
+* .. Executable Statements ..
+ PASSHIST = (PASSHIST .AND. THISTEST)
+ ALLPASS = PASSHIST
+*
+ RETURN
+ END
+*
+ SUBROUTINE RDBSBR( MEMUSED, MEM, MEMLEN, CMEMUSED, CMEM, CMEMLEN,
+ $ OUTNUM )
+*
+* -- BLACS tester (version 1.0) --
+* University of Tennessee
+* December 15, 1994
+*
+*
+* .. Scalar Arguments ..
+ INTEGER MEMUSED, MEMLEN, CMEMUSED, CMEMLEN, OUTNUM
+* ..
+* .. Array Arguments ..
+ CHARACTER*1 CMEM(CMEMLEN)
+ INTEGER MEM(MEMLEN)
+* ..
+*
+* Purpose
+* =======
+* RDBSBR: Read and process the input file BSBR.dat.
+*
+* Arguments
+* =========
+* MEMUSED (output) INTEGER
+* Number of elements in MEM that this subroutine ends up using.
+*
+* MEM (output) INTEGER array of dimension memlen
+* On output, holds information read in from sdrv.dat.
+*
+* MEMLEN (input) INTEGER
+* Number of elements of MEM that this subroutine
+* may safely write into.
+*
+* CMEMUSED (output) INTEGER
+* Number of elements in CMEM that this subroutine ends up using.
+*
+* CMEM (output) CHARACTER*1 array of dimension cmemlen
+* On output, holds the values for UPLO and DIAG.
+*
+* CMEMLEN (input) INTEGER
+* Number of elements of CMEM that this subroutine
+* may safely write into.
+*
+* OUTNUM (input) INTEGER
+* Unit number of the output file.
+*
+* =================================================================
+*
+* .. Parameters ..
+ INTEGER SDIN
+ PARAMETER( SDIN = 12 )
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. Local Scalars ..
+ INTEGER NSCOPE, NTOP, NSHAPE, NMAT, NSRC, NGRID, I, J
+ INTEGER SCOPEPTR, TOPPTR, UPLOPTR, DIAGPTR, MPTR, NPTR
+ INTEGER LDSPTR, LDDPTR, RSRCPTR, CSRCPTR, PPTR, QPTR
+* ..
+* .. Executable Statements
+*
+* Open and read the file bsbr.dat. The expected format is
+* below.
+*
+*------
+*integer Number of scopes
+*array of CHAR*1's Values for Scopes
+*integer Number of topologies
+*array of CHAR*1's Values for TOP
+*integer number of shapes of the matrix
+*array of CHAR*1's UPLO
+*array of CHAR*1's DIAG: unit diagonal or not?
+*integer number of nmat
+*array of integers M: number of rows in matrix
+*array of integers N: number of columns in matrix
+*integer LDA: leading dimension on source proc
+*integer LDA: leading dimension on dest proc
+*integer number of source/dest pairs
+*array of integers RSRC: process row of message source
+*array of integers CSRC: process column of msg. src.
+*integer Number of grids
+*array of integers NPROW: number of rows in process grid
+*array of integers NPCOL: number of col's in proc. grid
+*------
+* note: UPLO stands for 'upper or lower trapezoidal or general
+* rectangular.'
+* note: the text descriptions as shown above are present in
+* the sample bsbr.dat included with this distribution,
+* but are not required.
+*
+* Read input file
+*
+ MEMUSED = 1
+ CMEMUSED = 1
+ OPEN(UNIT = SDIN, FILE = 'bsbr.dat', STATUS = 'OLD')
+*
+* Read in scopes and topologies
+*
+ READ(SDIN, *) NSCOPE
+ SCOPEPTR = CMEMUSED
+ CMEMUSED = SCOPEPTR + NSCOPE
+ IF ( CMEMUSED .GT. CMEMLEN ) THEN
+ WRITE(OUTNUM, 1000) CMEMLEN, NSCOPE, 'SCOPES.'
+ IF( OUTNUM .NE. 6 .AND. OUTNUM .NE. 0 ) CLOSE(OUTNUM)
+ STOP
+ ELSE IF( NSCOPE .LT. 1 ) THEN
+ WRITE(OUTNUM, 2000) 'SCOPE.'
+ IF( OUTNUM .NE. 6 .AND. OUTNUM .NE. 0 ) CLOSE(OUTNUM)
+ STOP
+ END IF
+*
+ READ(SDIN, *) ( CMEM(SCOPEPTR+I), I = 0, NSCOPE-1 )
+ DO 20 I = 0, NSCOPE-1
+ IF( LSAME(CMEM(SCOPEPTR+I), 'R') ) THEN
+ CMEM(SCOPEPTR+I) = 'R'
+ ELSE IF( LSAME(CMEM(SCOPEPTR+I), 'C') ) THEN
+ CMEM(SCOPEPTR+I) = 'C'
+ ELSE IF( LSAME(CMEM(SCOPEPTR+I), 'A') ) THEN
+ CMEM(SCOPEPTR+I) = 'A'
+ ELSE
+ WRITE(OUTNUM, 3000) 'SCOPE', CMEM(SCOPEPTR+I)
+ IF( OUTNUM .NE. 6 .AND. OUTNUM .NE. 0 ) CLOSE(OUTNUM)
+ STOP
+ END IF
+ 20 CONTINUE
+*
+ READ(SDIN, *) NTOP
+ TOPPTR = CMEMUSED
+ CMEMUSED = TOPPTR + NTOP
+ IF ( CMEMUSED .GT. CMEMLEN ) THEN
+ WRITE(OUTNUM, 1000) CMEMLEN, NTOP, 'TOPOLOGIES.'
+ IF( OUTNUM .NE. 6 .AND. OUTNUM .NE. 0 ) CLOSE(OUTNUM)
+ STOP
+ ELSE IF( NTOP .LT. 1 ) THEN
+ WRITE(OUTNUM, 2000) 'TOPOLOGY.'
+ IF( OUTNUM .NE. 6 .AND. OUTNUM .NE. 0 ) CLOSE(OUTNUM)
+ STOP
+ END IF
+ READ(SDIN, *) ( CMEM(TOPPTR+I), I = 0, NTOP-1 )
+*
+*
+* Read in number of shapes, and values of UPLO and DIAG
+*
+ READ(SDIN, *) NSHAPE
+ UPLOPTR = CMEMUSED
+ DIAGPTR = UPLOPTR + NSHAPE
+ CMEMUSED = DIAGPTR + NSHAPE
+ IF ( CMEMUSED .GT. CMEMLEN ) THEN
+ WRITE(OUTNUM, 1000) CMEMLEN, NSHAPE, 'MATRIX SHAPES.'
+ IF( OUTNUM .NE. 6 .AND. OUTNUM .NE. 0 ) CLOSE(OUTNUM)
+ STOP
+ ELSE IF( NSHAPE .LT. 1 ) THEN
+ WRITE(OUTNUM, 2000) 'MATRIX SHAPE.'
+ IF( OUTNUM .NE. 6 .AND. OUTNUM .NE. 0 ) CLOSE(OUTNUM)
+ STOP
+ END IF
+*
+* Read in, upcase, and fatal error if UPLO/DIAG not recognized
+*
+ READ(SDIN, *) ( CMEM(UPLOPTR+I), I = 0, NSHAPE-1 )
+ DO 30 I = 0, NSHAPE-1
+ IF( LSAME(CMEM(UPLOPTR+I), 'G') ) THEN
+ CMEM(UPLOPTR+I) = 'G'
+ ELSE IF( LSAME(CMEM(UPLOPTR+I), 'U') ) THEN
+ CMEM(UPLOPTR+I) = 'U'
+ ELSE IF( LSAME(CMEM(UPLOPTR+I), 'L') ) THEN
+ CMEM(UPLOPTR+I) = 'L'
+ ELSE
+ WRITE(OUTNUM, 3000) 'UPLO ', CMEM(UPLOPTR+I)
+ IF( OUTNUM .NE. 6 .AND. OUTNUM .NE. 0 ) CLOSE(OUTNUM)
+ STOP
+ END IF
+ 30 CONTINUE
+*
+ READ(SDIN, *) ( CMEM(DIAGPTR+I), I = 0, NSHAPE-1 )
+ DO 40 I = 0, NSHAPE-1
+ IF( CMEM(UPLOPTR+I) .NE. 'G' ) THEN
+ IF( LSAME(CMEM(DIAGPTR+I), 'U') ) THEN
+ CMEM( DIAGPTR+I ) = 'U'
+ ELSE IF( LSAME(CMEM(DIAGPTR+I), 'N') ) THEN
+ CMEM(DIAGPTR+I) = 'N'
+ ELSE
+ WRITE(OUTNUM, 3000) 'DIAG ', CMEM(DIAGPTR+I)
+ IF( OUTNUM .NE. 6 .AND. OUTNUM .NE. 0 ) CLOSE(OUTNUM)
+ STOP
+ END IF
+ END IF
+ 40 CONTINUE
+*
+* Read in number of matrices, and values for M, N, LDASRC, and LDADEST
+*
+ READ(SDIN, *) NMAT
+ MPTR = MEMUSED
+ NPTR = MPTR + NMAT
+ LDSPTR = NPTR + NMAT
+ LDDPTR = LDSPTR + NMAT
+ MEMUSED = LDDPTR + NMAT
+ IF( MEMUSED .GT. MEMLEN ) THEN
+ WRITE(OUTNUM, 1000) MEMLEN, NMAT, 'MATRICES.'
+ IF( OUTNUM .NE. 6 .AND. OUTNUM .NE. 0 ) CLOSE(OUTNUM)
+ STOP
+ ELSE IF( NMAT .LT. 1 ) THEN
+ WRITE(OUTNUM, 2000) 'MATRIX.'
+ IF( OUTNUM .NE. 6 .AND. OUTNUM .NE. 0 ) CLOSE(OUTNUM)
+ STOP
+ END IF
+ READ(SDIN, *) ( MEM( MPTR+I ), I = 0, NMAT-1 )
+ READ(SDIN, *) ( MEM( NPTR+I ), I = 0, NMAT-1 )
+ READ(SDIN, *) ( MEM( LDSPTR+I ), I = 0, NMAT-1 )
+ READ(SDIN, *) ( MEM( LDDPTR+I ), I = 0, NMAT-1 )
+*
+* Make sure matrix values are legal
+*
+ CALL CHKMATDAT( OUTNUM, 'BSBR.dat', .FALSE., NMAT, MEM(MPTR),
+ $ MEM(NPTR), MEM(LDSPTR), MEM(LDDPTR), MEM(LDDPTR) )
+*
+* Read in number of src pairs, and values of src
+*
+ READ(SDIN, *) NSRC
+ RSRCPTR = MEMUSED
+ CSRCPTR = RSRCPTR + NSRC
+ MEMUSED = CSRCPTR + NSRC
+ IF( MEMUSED .GT. MEMLEN ) THEN
+ WRITE(OUTNUM, 1000) MEMLEN, NMAT, 'SRC.'
+ IF( OUTNUM .NE. 6 .AND. OUTNUM .NE. 0 ) CLOSE(OUTNUM)
+ STOP
+ ELSE IF( NSRC .LT. 1 ) THEN
+ WRITE(OUTNUM, 2000) 'SRC.'
+ IF( OUTNUM .NE. 6 .AND. OUTNUM .NE. 0 ) CLOSE(OUTNUM)
+ STOP
+ END IF
+ READ(SDIN, *) ( MEM(RSRCPTR+I), I = 0, NSRC-1 )
+ READ(SDIN, *) ( MEM(CSRCPTR+I), I = 0, NSRC-1 )
+*
+* Read in number of grids pairs, and values of P (process rows) and
+* Q (process columns)
+*
+ READ(SDIN, *) NGRID
+ PPTR = MEMUSED
+ QPTR = PPTR + NGRID
+ MEMUSED = QPTR + NGRID
+ IF( MEMUSED .GT. MEMLEN ) THEN
+ WRITE(OUTNUM, 1000) MEMLEN, NGRID, 'PROCESS GRIDS.'
+ IF( OUTNUM .NE. 6 .AND. OUTNUM .NE. 0 ) CLOSE(OUTNUM)
+ STOP
+ ELSE IF( NGRID .LT. 1 ) THEN
+ WRITE(OUTNUM, 2000) 'PROCESS GRID'
+ IF( OUTNUM .NE. 6 .AND. OUTNUM .NE. 0 ) CLOSE( OUTNUM )
+ STOP
+ END IF
+*
+ READ(SDIN, *) ( MEM(PPTR+I), I = 0, NGRID-1 )
+ READ(SDIN, *) ( MEM(QPTR+I), I = 0, NGRID-1 )
+ IF( SDIN .NE. 6 .AND. SDIN .NE. 0 ) CLOSE( SDIN )
+*
+* Fatal error if we've got an illegal grid
+*
+ DO 70 J = 0, NGRID-1
+ IF( MEM(PPTR+J).LT.1 .OR. MEM(QPTR+J).LT.1 ) THEN
+ WRITE(OUTNUM, 4000) MEM(PPTR+J), MEM(QPTR+J)
+ IF( OUTNUM .NE. 6 .AND. OUTNUM .NE. 0 ) CLOSE(OUTNUM)
+ STOP
+ END IF
+ 70 CONTINUE
+*
+* Prepare output variables
+*
+ MEM(MEMUSED) = NSCOPE
+ MEM(MEMUSED+1) = NTOP
+ MEM(MEMUSED+2) = NSHAPE
+ MEM(MEMUSED+3) = NMAT
+ MEM(MEMUSED+4) = NSRC
+ MEM(MEMUSED+5) = NGRID
+ MEMUSED = MEMUSED + 5
+ CMEMUSED = CMEMUSED - 1
+*
+ 1000 FORMAT('Mem too short (',I4,') to handle',I4,' ',A20)
+ 2000 FORMAT('Must have at least one ',A20)
+ 3000 FORMAT('UNRECOGNIZABLE ',A5,' ''', A1, '''.')
+ 4000 FORMAT('Illegal process grid: {',I3,',',I3,'}.')
+*
+ RETURN
+*
+* End of RDBSBR.
+*
+ END
+*
+*
+ SUBROUTINE ISDRVTEST( OUTNUM, VERB, NSHAPE, UPLO0, DIAG0,
+ $ NMAT, M0, N0, LDAS0, LDAD0, NSRC, RSRC0,
+ $ CSRC0, RDEST0, CDEST0, NGRID, CONTEXT0,
+ $ P0, Q0, TFAIL, MEM, MEMLEN )
+*
+* -- BLACS tester (version 1.0) --
+* University of Tennessee
+* December 15, 1994
+*
+*
+* .. Scalar Arguments ..
+ INTEGER OUTNUM, VERB, NSHAPE, NMAT, NSRC, NGRID, MEMLEN
+* ..
+* .. Array Arguments ..
+ CHARACTER*1 UPLO0(NSHAPE), DIAG0(NSHAPE)
+ INTEGER M0(NMAT), N0(NMAT), LDAS0(NMAT), LDAD0(NMAT)
+ INTEGER RSRC0(NSRC), CSRC0(NSRC), RDEST0(NSRC), CDEST0(NSRC)
+ INTEGER CONTEXT0(NGRID), P0(NGRID), Q0(NGRID), TFAIL(*)
+ INTEGER MEM(MEMLEN)
+* ..
+*
+* Purpose
+* =======
+* ITESTSDRV: Test integer send/recv
+*
+* Arguments
+* =========
+* OUTNUM (input) INTEGER
+* The device number to write output to.
+*
+* VERB (input) INTEGER
+* The level of verbosity (how much printing to do).
+*
+* NSHAPE (input) INTEGER
+* The number of matrix shapes to be tested.
+*
+* UPLO0 (input) CHARACTER*1 array of dimension (NSHAPE)
+* Values of UPLO to be tested.
+*
+* DIAG0 (input) CHARACTER*1 array of dimension (NSHAPE)
+* Values of DIAG to be tested.
+*
+* NMAT (input) INTEGER
+* The number of matrices to be tested.
+*
+* M0 (input) INTEGER array of dimension (NMAT)
+* Values of M to be tested.
+*
+* M0 (input) INTEGER array of dimension (NMAT)
+* Values of M to be tested.
+*
+* N0 (input) INTEGER array of dimension (NMAT)
+* Values of N to be tested.
+*
+* LDAS0 (input) INTEGER array of dimension (NMAT)
+* Values of LDAS (leading dimension of A on source process)
+* to be tested.
+*
+* LDAD0 (input) INTEGER array of dimension (NMAT)
+* Values of LDAD (leading dimension of A on destination
+* process) to be tested.
+* NSRC (input) INTEGER
+* The number of sources to be tested.
+*
+* RSRC0 (input) INTEGER array of dimension (NDEST)
+* Values of RSRC (row coordinate of source) to be tested.
+*
+* CSRC0 (input) INTEGER array of dimension (NDEST)
+* Values of CSRC (column coordinate of source) to be tested.
+*
+* RDEST0 (input) INTEGER array of dimension (NNSRC)
+* Values of RDEST (row coordinate of destination) to be
+* tested.
+*
+* CDEST0 (input) INTEGER array of dimension (NNSRC)
+* Values of CDEST (column coordinate of destination) to be
+* tested.
+*
+* NGRID (input) INTEGER
+* The number of process grids to be tested.
+*
+* CONTEXT0 (input) INTEGER array of dimension (NGRID)
+* The BLACS context handles corresponding to the grids.
+*
+* P0 (input) INTEGER array of dimension (NGRID)
+* Values of P (number of process rows, NPROW).
+*
+* Q0 (input) INTEGER array of dimension (NGRID)
+* Values of Q (number of process columns, NPCOL).
+*
+* TFAIL (workspace) INTEGER array of dimension (NTESTS)
+* If VERB < 2, serves to indicate which tests fail. This
+* requires workspace of NTESTS (number of tests performed).
+*
+* MEM (workspace) INTEGER array of dimension (MEMLEN)
+* Used for all other workspaces, including the matrix A,
+* and its pre and post padding.
+*
+* MEMLEN (input) INTEGER
+* The length, in elements, of MEM.
+*
+* =====================================================================
+*
+* .. External Functions ..
+ LOGICAL ALLPASS
+ INTEGER IBTMYPROC, IBTSIZEOF
+ EXTERNAL ALLPASS, IBTMYPROC, IBTSIZEOF
+* ..
+* .. External Subroutines ..
+ EXTERNAL BLACS_GRIDINFO
+ EXTERNAL ITRSD2D, IGESD2D, ITRRV2D, IGERV2D
+ EXTERNAL IINITMAT, ICHKMAT, ICHKPAD, IBTCHECKIN
+* ..
+* .. Local Scalars ..
+ CHARACTER*1 UPLO, DIAG
+ LOGICAL TESTOK
+ INTEGER IAM, I, K, IGR, ISH, IMA, ISO, MYROW, MYCOL, IPRE, IPOST
+ INTEGER M, N, NPROW, NPCOL, RSRC, CSRC, RDEST, CDEST
+ INTEGER NERR, NSKIP, NFAIL, TESTNUM, CONTEXT, MAXERR, LDASRC
+ INTEGER LDADST, ERRDPTR, APTR, ERRIPTR, ISIZE
+ INTEGER SCHECKVAL, RCHECKVAL
+* ..
+* .. Executable Statements ..
+*
+ SCHECKVAL = -1
+ RCHECKVAL = -2
+*
+ IAM = IBTMYPROC()
+ ISIZE = IBTSIZEOF('I')
+ ISIZE = IBTSIZEOF('I')
+*
+* Verify file parameters
+*
+ IF( IAM .EQ. 0 ) THEN
+ WRITE(OUTNUM, *) ' '
+ WRITE(OUTNUM, *) ' '
+ WRITE(OUTNUM, 1000 )
+ IF( VERB .GT. 0 ) THEN
+ WRITE(OUTNUM,*) ' '
+ WRITE(OUTNUM, 2000) 'NSHAPE:', NSHAPE
+ WRITE(OUTNUM, 3000) ' UPLO :', ( UPLO0(I), I = 1, NSHAPE )
+ WRITE(OUTNUM, 3000) ' DIAG :', ( DIAG0(I), I = 1, NSHAPE )
+ WRITE(OUTNUM, 2000) 'NMAT :', NMAT
+ WRITE(OUTNUM, 2000) ' M :', ( M0(I), I = 1, NMAT )
+ WRITE(OUTNUM, 2000) ' N :', ( N0(I), I = 1, NMAT )
+ WRITE(OUTNUM, 2000) ' LDAS :', ( LDAS0(I), I = 1, NMAT )
+ WRITE(OUTNUM, 2000) ' LDAD :', ( LDAD0(I), I = 1, NMAT )
+ WRITE(OUTNUM, 2000) 'NSRC :', NSRC
+ WRITE(OUTNUM, 2000) ' RSRC :',( RSRC0(I), I = 1, NSRC )
+ WRITE(OUTNUM, 2000) ' CSRC :',( CSRC0(I), I = 1, NSRC )
+ WRITE(OUTNUM, 2000) ' RDEST:',( RDEST0(I), I = 1, NSRC )
+ WRITE(OUTNUM, 2000) ' CDEST:',( CDEST0(I), I = 1, NSRC )
+ WRITE(OUTNUM, 2000) 'NGRIDS:', NGRID
+ WRITE(OUTNUM, 2000) ' P :', ( P0(I), I = 1, NGRID )
+ WRITE(OUTNUM, 2000) ' Q :', ( Q0(I), I = 1, NGRID )
+ WRITE(OUTNUM, 2000) 'VERB :', VERB
+ WRITE(OUTNUM,*) ' '
+ END IF
+ IF( VERB .GT. 1 ) THEN
+ WRITE(OUTNUM,5000)
+ WRITE(OUTNUM,6000)
+ END IF
+ END IF
+*
+* Find biggest matrix, so we know where to stick error info
+*
+ I = 0
+ DO 10 IMA = 1, NMAT
+ K = N0(IMA) * MAX0( LDAS0(IMA), LDAD0(IMA) ) + 4 * M0(IMA)
+ IF( K .GT. I ) I = K
+ 10 CONTINUE
+ MAXERR = ( ISIZE * (MEMLEN-I) ) / ( ISIZE*2 + ISIZE*6 )
+ IF( MAXERR .LT. 1 ) THEN
+ WRITE(OUTNUM,*) 'ERROR: Not enough memory to run SDRV tests.'
+ CALL BLACS_ABORT(-1, 1)
+ END IF
+ ERRDPTR = I + 1
+ ERRIPTR = ERRDPTR + MAXERR
+ NERR = 0
+ TESTNUM = 0
+ NFAIL = 0
+ NSKIP = 0
+*
+* Loop over grids of matrix
+*
+ DO 110 IGR = 1, NGRID
+*
+ CONTEXT = CONTEXT0(IGR)
+ CALL BLACS_GRIDINFO( CONTEXT, NPROW, NPCOL, MYROW, MYCOL )
+*
+ DO 80 ISH = 1, NSHAPE
+ UPLO = UPLO0(ISH)
+ DIAG = DIAG0(ISH)
+*
+ DO 70 IMA = 1, NMAT
+ M = M0(IMA)
+ N = N0(IMA)
+ LDASRC = LDAS0(IMA)
+ LDADST = LDAD0(IMA)
+*
+ DO 60 ISO = 1, NSRC
+ TESTNUM = TESTNUM + 1
+ RSRC = RSRC0(ISO)
+ CSRC = CSRC0(ISO)
+ IF( RSRC.GE.P0(IGR) .OR. CSRC.GE.Q0(IGR) ) THEN
+ NSKIP = NSKIP + 1
+ GOTO 60
+ END IF
+ RDEST = RDEST0(ISO)
+ CDEST = CDEST0(ISO)
+ IF( RDEST.GE.P0(IGR) .OR. CDEST.GE.Q0(IGR) ) THEN
+ NSKIP = NSKIP + 1
+ GOTO 60
+ END IF
+*
+ IF( VERB .GT. 1 ) THEN
+ IF( IAM .EQ. 0 ) THEN
+ WRITE(OUTNUM, 7000) TESTNUM, 'RUNNING',
+ $ UPLO, DIAG, M, N,
+ $ LDASRC, LDADST, RSRC, CSRC,
+ $ RDEST, CDEST, NPROW, NPCOL
+ END IF
+ END IF
+*
+ TESTOK = .TRUE.
+ IPRE = 2 * M
+ IPOST = IPRE
+ APTR = IPRE + 1
+*
+* source process generates matrix and sends it
+*
+ IF( MYROW .EQ. RSRC .AND. MYCOL .EQ. CSRC ) THEN
+ CALL IINITMAT( UPLO, DIAG, M, N, MEM, LDASRC,
+ $ IPRE, IPOST, SCHECKVAL, TESTNUM,
+ $ MYROW, MYCOL )
+*
+ IF( UPLO .EQ. 'U' .OR. UPLO .EQ. 'L' ) THEN
+ CALL ITRSD2D( CONTEXT, UPLO, DIAG, M, N,
+ $ MEM(APTR), LDASRC, RDEST, CDEST )
+ ELSE
+ CALL IGESD2D( CONTEXT, M, N, MEM(APTR),
+ $ LDASRC, RDEST, CDEST )
+ END IF
+ END IF
+*
+ IF( MYROW .EQ. RDEST .AND. MYCOL .EQ. CDEST ) THEN
+*
+* Pad entire matrix area
+*
+ DO 50 K = 1, IPRE+IPOST+LDADST*N
+ MEM(K) = RCHECKVAL
+ 50 CONTINUE
+*
+* Receive matrix
+*
+ IF( UPLO .EQ. 'U' .OR. UPLO .EQ. 'L' ) THEN
+ CALL ITRRV2D( CONTEXT, UPLO, DIAG, M, N,
+ $ MEM(APTR), LDADST, RSRC, CSRC )
+ ELSE
+ CALL IGERV2D( CONTEXT, M, N, MEM(APTR),
+ $ LDADST, RSRC, CSRC )
+ END IF
+*
+* Check for errors in matrix or padding
+*
+ I = NERR
+ CALL ICHKMAT( UPLO, DIAG, M, N, MEM(APTR), LDADST,
+ $ RSRC, CSRC, MYROW, MYCOL, TESTNUM, MAXERR,
+ $ NERR, MEM(ERRIPTR), MEM(ERRDPTR) )
+*
+ CALL ICHKPAD( UPLO, DIAG, M, N, MEM, LDADST,
+ $ RSRC, CSRC, MYROW, MYCOL, IPRE, IPOST,
+ $ RCHECKVAL, TESTNUM, MAXERR, NERR,
+ $ MEM(ERRIPTR), MEM(ERRDPTR) )
+ TESTOK = I .EQ. NERR
+ END IF
+*
+ IF( VERB .GT. 1 ) THEN
+ I = NERR
+ CALL IBTCHECKIN( 0, OUTNUM, MAXERR, NERR,
+ $ MEM(ERRIPTR), MEM(ERRDPTR),
+ $ TFAIL )
+ IF( IAM .EQ. 0 ) THEN
+ IF( TESTOK .AND. I.EQ.NERR ) THEN
+ WRITE(OUTNUM, 7000) TESTNUM, 'PASSED ',
+ $ UPLO, DIAG, M, N, LDASRC, LDADST,
+ $ RSRC, CSRC, RDEST, CDEST, NPROW, NPCOL
+ ELSE
+ NFAIL = NFAIL + 1
+ WRITE(OUTNUM, 7000) TESTNUM, 'FAILED ',
+ $ UPLO, DIAG, M, N, LDASRC, LDADST,
+ $ RSRC, CSRC, RDEST, CDEST, NPROW, NPCOL
+ ENDIF
+ END IF
+*
+* Once we've printed out errors, can re-use buf space
+*
+ NERR = 0
+ END IF
+ 60 CONTINUE
+ 70 CONTINUE
+ 80 CONTINUE
+ 110 CONTINUE
+*
+ IF( VERB .LT. 2 ) THEN
+ NFAIL = TESTNUM
+ CALL IBTCHECKIN( NFAIL, OUTNUM, MAXERR, NERR, MEM(ERRIPTR),
+ $ MEM(ERRDPTR), TFAIL )
+ END IF
+ IF( IAM .EQ. 0 ) THEN
+ IF( VERB .GT. 1 ) WRITE(OUTNUM,*) ' '
+ IF( NFAIL+NSKIP .EQ. 0 ) THEN
+ WRITE(OUTNUM, 8000 ) TESTNUM
+ ELSE
+ WRITE(OUTNUM, 9000 ) TESTNUM, TESTNUM-NSKIP-NFAIL,
+ $ NSKIP, NFAIL
+ END IF
+ END IF
+*
+* Log whether their were any failures
+*
+ TESTOK = ALLPASS( (NFAIL.EQ.0) )
+*
+ 1000 FORMAT('INTEGER SDRV TESTS: BEGIN.' )
+ 2000 FORMAT(1X,A7,3X,10I6)
+ 3000 FORMAT(1X,A7,3X,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1,
+ $ 5X,A1,5X,A1)
+ 5000 FORMAT(' TEST# STATUS UPLO DIA M N LDAS LDAD RSRC ',
+ $ 'CSRC RDEST CDEST P Q')
+ 6000 FORMAT(' ----- ------- ---- --- ----- ----- ----- ----- ---- ',
+ $ '---- ----- ----- ---- ----')
+ 7000 FORMAT(I6,1X,A7,4X,A1,3X,A1,4I6,2I5,2I6,2I5)
+ 8000 FORMAT('INTEGER SDRV TESTS: PASSED ALL',
+ $ I5, ' TESTS.')
+ 9000 FORMAT('INTEGER SDRV TESTS:',I5,' TESTS;',I5,' PASSED,',
+ $ I5,' SKIPPED,',I5,' FAILED.')
+*
+ RETURN
+*
+* End of ISDRVTEST.
+*
+ END
+*
+*
+ SUBROUTINE SSDRVTEST( OUTNUM, VERB, NSHAPE, UPLO0, DIAG0,
+ $ NMAT, M0, N0, LDAS0, LDAD0, NSRC, RSRC0,
+ $ CSRC0, RDEST0, CDEST0, NGRID, CONTEXT0,
+ $ P0, Q0, TFAIL, MEM, MEMLEN )
+*
+* -- BLACS tester (version 1.0) --
+* University of Tennessee
+* December 15, 1994
+*
+*
+* .. Scalar Arguments ..
+ INTEGER OUTNUM, VERB, NSHAPE, NMAT, NSRC, NGRID, MEMLEN
+* ..
+* .. Array Arguments ..
+ CHARACTER*1 UPLO0(NSHAPE), DIAG0(NSHAPE)
+ INTEGER M0(NMAT), N0(NMAT), LDAS0(NMAT), LDAD0(NMAT)
+ INTEGER RSRC0(NSRC), CSRC0(NSRC), RDEST0(NSRC), CDEST0(NSRC)
+ INTEGER CONTEXT0(NGRID), P0(NGRID), Q0(NGRID), TFAIL(*)
+ REAL MEM(MEMLEN)
+* ..
+*
+* Purpose
+* =======
+* STESTSDRV: Test real send/recv
+*
+* Arguments
+* =========
+* OUTNUM (input) INTEGER
+* The device number to write output to.
+*
+* VERB (input) INTEGER
+* The level of verbosity (how much printing to do).
+*
+* NSHAPE (input) INTEGER
+* The number of matrix shapes to be tested.
+*
+* UPLO0 (input) CHARACTER*1 array of dimension (NSHAPE)
+* Values of UPLO to be tested.
+*
+* DIAG0 (input) CHARACTER*1 array of dimension (NSHAPE)
+* Values of DIAG to be tested.
+*
+* NMAT (input) INTEGER
+* The number of matrices to be tested.
+*
+* M0 (input) INTEGER array of dimension (NMAT)
+* Values of M to be tested.
+*
+* M0 (input) INTEGER array of dimension (NMAT)
+* Values of M to be tested.
+*
+* N0 (input) INTEGER array of dimension (NMAT)
+* Values of N to be tested.
+*
+* LDAS0 (input) INTEGER array of dimension (NMAT)
+* Values of LDAS (leading dimension of A on source process)
+* to be tested.
+*
+* LDAD0 (input) INTEGER array of dimension (NMAT)
+* Values of LDAD (leading dimension of A on destination
+* process) to be tested.
+* NSRC (input) INTEGER
+* The number of sources to be tested.
+*
+* RSRC0 (input) INTEGER array of dimension (NDEST)
+* Values of RSRC (row coordinate of source) to be tested.
+*
+* CSRC0 (input) INTEGER array of dimension (NDEST)
+* Values of CSRC (column coordinate of source) to be tested.
+*
+* RDEST0 (input) INTEGER array of dimension (NNSRC)
+* Values of RDEST (row coordinate of destination) to be
+* tested.
+*
+* CDEST0 (input) INTEGER array of dimension (NNSRC)
+* Values of CDEST (column coordinate of destination) to be
+* tested.
+*
+* NGRID (input) INTEGER
+* The number of process grids to be tested.
+*
+* CONTEXT0 (input) INTEGER array of dimension (NGRID)
+* The BLACS context handles corresponding to the grids.
+*
+* P0 (input) INTEGER array of dimension (NGRID)
+* Values of P (number of process rows, NPROW).
+*
+* Q0 (input) INTEGER array of dimension (NGRID)
+* Values of Q (number of process columns, NPCOL).
+*
+* TFAIL (workspace) INTEGER array of dimension (NTESTS)
+* If VERB < 2, serves to indicate which tests fail. This
+* requires workspace of NTESTS (number of tests performed).
+*
+* MEM (workspace) REAL array of dimension (MEMLEN)
+* Used for all other workspaces, including the matrix A,
+* and its pre and post padding.
+*
+* MEMLEN (input) INTEGER
+* The length, in elements, of MEM.
+*
+* =====================================================================
+*
+* .. External Functions ..
+ LOGICAL ALLPASS
+ INTEGER IBTMYPROC, IBTSIZEOF
+ EXTERNAL ALLPASS, IBTMYPROC, IBTSIZEOF
+* ..
+* .. External Subroutines ..
+ EXTERNAL BLACS_GRIDINFO
+ EXTERNAL STRSD2D, SGESD2D, STRRV2D, SGERV2D
+ EXTERNAL SINITMAT, SCHKMAT, SCHKPAD, SBTCHECKIN
+* ..
+* .. Local Scalars ..
+ CHARACTER*1 UPLO, DIAG
+ LOGICAL TESTOK
+ INTEGER IAM, I, K, IGR, ISH, IMA, ISO, MYROW, MYCOL, IPRE, IPOST
+ INTEGER M, N, NPROW, NPCOL, RSRC, CSRC, RDEST, CDEST
+ INTEGER NERR, NSKIP, NFAIL, TESTNUM, CONTEXT, MAXERR, LDASRC
+ INTEGER LDADST, ERRDPTR, APTR, ERRIPTR, ISIZE, SSIZE
+ REAL SCHECKVAL, RCHECKVAL
+* ..
+* .. Executable Statements ..
+*
+ SCHECKVAL = -0.01E0
+ RCHECKVAL = -0.02E0
+*
+ IAM = IBTMYPROC()
+ ISIZE = IBTSIZEOF('I')
+ SSIZE = IBTSIZEOF('S')
+*
+* Verify file parameters
+*
+ IF( IAM .EQ. 0 ) THEN
+ WRITE(OUTNUM, *) ' '
+ WRITE(OUTNUM, *) ' '
+ WRITE(OUTNUM, 1000 )
+ IF( VERB .GT. 0 ) THEN
+ WRITE(OUTNUM,*) ' '
+ WRITE(OUTNUM, 2000) 'NSHAPE:', NSHAPE
+ WRITE(OUTNUM, 3000) ' UPLO :', ( UPLO0(I), I = 1, NSHAPE )
+ WRITE(OUTNUM, 3000) ' DIAG :', ( DIAG0(I), I = 1, NSHAPE )
+ WRITE(OUTNUM, 2000) 'NMAT :', NMAT
+ WRITE(OUTNUM, 2000) ' M :', ( M0(I), I = 1, NMAT )
+ WRITE(OUTNUM, 2000) ' N :', ( N0(I), I = 1, NMAT )
+ WRITE(OUTNUM, 2000) ' LDAS :', ( LDAS0(I), I = 1, NMAT )
+ WRITE(OUTNUM, 2000) ' LDAD :', ( LDAD0(I), I = 1, NMAT )
+ WRITE(OUTNUM, 2000) 'NSRC :', NSRC
+ WRITE(OUTNUM, 2000) ' RSRC :',( RSRC0(I), I = 1, NSRC )
+ WRITE(OUTNUM, 2000) ' CSRC :',( CSRC0(I), I = 1, NSRC )
+ WRITE(OUTNUM, 2000) ' RDEST:',( RDEST0(I), I = 1, NSRC )
+ WRITE(OUTNUM, 2000) ' CDEST:',( CDEST0(I), I = 1, NSRC )
+ WRITE(OUTNUM, 2000) 'NGRIDS:', NGRID
+ WRITE(OUTNUM, 2000) ' P :', ( P0(I), I = 1, NGRID )
+ WRITE(OUTNUM, 2000) ' Q :', ( Q0(I), I = 1, NGRID )
+ WRITE(OUTNUM, 2000) 'VERB :', VERB
+ WRITE(OUTNUM,*) ' '
+ END IF
+ IF( VERB .GT. 1 ) THEN
+ WRITE(OUTNUM,5000)
+ WRITE(OUTNUM,6000)
+ END IF
+ END IF
+*
+* Find biggest matrix, so we know where to stick error info
+*
+ I = 0
+ DO 10 IMA = 1, NMAT
+ K = N0(IMA) * MAX0( LDAS0(IMA), LDAD0(IMA) ) + 4 * M0(IMA)
+ IF( K .GT. I ) I = K
+ 10 CONTINUE
+ MAXERR = ( SSIZE * (MEMLEN-I) ) / ( SSIZE*2 + ISIZE*6 )
+ IF( MAXERR .LT. 1 ) THEN
+ WRITE(OUTNUM,*) 'ERROR: Not enough memory to run SDRV tests.'
+ CALL BLACS_ABORT(-1, 1)
+ END IF
+ ERRDPTR = I + 1
+ ERRIPTR = ERRDPTR + MAXERR
+ NERR = 0
+ TESTNUM = 0
+ NFAIL = 0
+ NSKIP = 0
+*
+* Loop over grids of matrix
+*
+ DO 110 IGR = 1, NGRID
+*
+ CONTEXT = CONTEXT0(IGR)
+ CALL BLACS_GRIDINFO( CONTEXT, NPROW, NPCOL, MYROW, MYCOL )
+*
+ DO 80 ISH = 1, NSHAPE
+ UPLO = UPLO0(ISH)
+ DIAG = DIAG0(ISH)
+*
+ DO 70 IMA = 1, NMAT
+ M = M0(IMA)
+ N = N0(IMA)
+ LDASRC = LDAS0(IMA)
+ LDADST = LDAD0(IMA)
+*
+ DO 60 ISO = 1, NSRC
+ TESTNUM = TESTNUM + 1
+ RSRC = RSRC0(ISO)
+ CSRC = CSRC0(ISO)
+ IF( RSRC.GE.P0(IGR) .OR. CSRC.GE.Q0(IGR) ) THEN
+ NSKIP = NSKIP + 1
+ GOTO 60
+ END IF
+ RDEST = RDEST0(ISO)
+ CDEST = CDEST0(ISO)
+ IF( RDEST.GE.P0(IGR) .OR. CDEST.GE.Q0(IGR) ) THEN
+ NSKIP = NSKIP + 1
+ GOTO 60
+ END IF
+*
+ IF( VERB .GT. 1 ) THEN
+ IF( IAM .EQ. 0 ) THEN
+ WRITE(OUTNUM, 7000) TESTNUM, 'RUNNING',
+ $ UPLO, DIAG, M, N,
+ $ LDASRC, LDADST, RSRC, CSRC,
+ $ RDEST, CDEST, NPROW, NPCOL
+ END IF
+ END IF
+*
+ TESTOK = .TRUE.
+ IPRE = 2 * M
+ IPOST = IPRE
+ APTR = IPRE + 1
+*
+* source process generates matrix and sends it
+*
+ IF( MYROW .EQ. RSRC .AND. MYCOL .EQ. CSRC ) THEN
+ CALL SINITMAT( UPLO, DIAG, M, N, MEM, LDASRC,
+ $ IPRE, IPOST, SCHECKVAL, TESTNUM,
+ $ MYROW, MYCOL )
+*
+ IF( UPLO .EQ. 'U' .OR. UPLO .EQ. 'L' ) THEN
+ CALL STRSD2D( CONTEXT, UPLO, DIAG, M, N,
+ $ MEM(APTR), LDASRC, RDEST, CDEST )
+ ELSE
+ CALL SGESD2D( CONTEXT, M, N, MEM(APTR),
+ $ LDASRC, RDEST, CDEST )
+ END IF
+ END IF
+*
+ IF( MYROW .EQ. RDEST .AND. MYCOL .EQ. CDEST ) THEN
+*
+* Pad entire matrix area
+*
+ DO 50 K = 1, IPRE+IPOST+LDADST*N
+ MEM(K) = RCHECKVAL
+ 50 CONTINUE
+*
+* Receive matrix
+*
+ IF( UPLO .EQ. 'U' .OR. UPLO .EQ. 'L' ) THEN
+ CALL STRRV2D( CONTEXT, UPLO, DIAG, M, N,
+ $ MEM(APTR), LDADST, RSRC, CSRC )
+ ELSE
+ CALL SGERV2D( CONTEXT, M, N, MEM(APTR),
+ $ LDADST, RSRC, CSRC )
+ END IF
+*
+* Check for errors in matrix or padding
+*
+ I = NERR
+ CALL SCHKMAT( UPLO, DIAG, M, N, MEM(APTR), LDADST,
+ $ RSRC, CSRC, MYROW, MYCOL, TESTNUM, MAXERR,
+ $ NERR, MEM(ERRIPTR), MEM(ERRDPTR) )
+*
+ CALL SCHKPAD( UPLO, DIAG, M, N, MEM, LDADST,
+ $ RSRC, CSRC, MYROW, MYCOL, IPRE, IPOST,
+ $ RCHECKVAL, TESTNUM, MAXERR, NERR,
+ $ MEM(ERRIPTR), MEM(ERRDPTR) )
+ TESTOK = I .EQ. NERR
+ END IF
+*
+ IF( VERB .GT. 1 ) THEN
+ I = NERR
+ CALL SBTCHECKIN( 0, OUTNUM, MAXERR, NERR,
+ $ MEM(ERRIPTR), MEM(ERRDPTR),
+ $ TFAIL )
+ IF( IAM .EQ. 0 ) THEN
+ IF( TESTOK .AND. I.EQ.NERR ) THEN
+ WRITE(OUTNUM, 7000) TESTNUM, 'PASSED ',
+ $ UPLO, DIAG, M, N, LDASRC, LDADST,
+ $ RSRC, CSRC, RDEST, CDEST, NPROW, NPCOL
+ ELSE
+ NFAIL = NFAIL + 1
+ WRITE(OUTNUM, 7000) TESTNUM, 'FAILED ',
+ $ UPLO, DIAG, M, N, LDASRC, LDADST,
+ $ RSRC, CSRC, RDEST, CDEST, NPROW, NPCOL
+ ENDIF
+ END IF
+*
+* Once we've printed out errors, can re-use buf space
+*
+ NERR = 0
+ END IF
+ 60 CONTINUE
+ 70 CONTINUE
+ 80 CONTINUE
+ 110 CONTINUE
+*
+ IF( VERB .LT. 2 ) THEN
+ NFAIL = TESTNUM
+ CALL SBTCHECKIN( NFAIL, OUTNUM, MAXERR, NERR, MEM(ERRIPTR),
+ $ MEM(ERRDPTR), TFAIL )
+ END IF
+ IF( IAM .EQ. 0 ) THEN
+ IF( VERB .GT. 1 ) WRITE(OUTNUM,*) ' '
+ IF( NFAIL+NSKIP .EQ. 0 ) THEN
+ WRITE(OUTNUM, 8000 ) TESTNUM
+ ELSE
+ WRITE(OUTNUM, 9000 ) TESTNUM, TESTNUM-NSKIP-NFAIL,
+ $ NSKIP, NFAIL
+ END IF
+ END IF
+*
+* Log whether their were any failures
+*
+ TESTOK = ALLPASS( (NFAIL.EQ.0) )
+*
+ 1000 FORMAT('REAL SDRV TESTS: BEGIN.' )
+ 2000 FORMAT(1X,A7,3X,10I6)
+ 3000 FORMAT(1X,A7,3X,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1,
+ $ 5X,A1,5X,A1)
+ 5000 FORMAT(' TEST# STATUS UPLO DIA M N LDAS LDAD RSRC ',
+ $ 'CSRC RDEST CDEST P Q')
+ 6000 FORMAT(' ----- ------- ---- --- ----- ----- ----- ----- ---- ',
+ $ '---- ----- ----- ---- ----')
+ 7000 FORMAT(I6,1X,A7,4X,A1,3X,A1,4I6,2I5,2I6,2I5)
+ 8000 FORMAT('REAL SDRV TESTS: PASSED ALL',
+ $ I5, ' TESTS.')
+ 9000 FORMAT('REAL SDRV TESTS:',I5,' TESTS;',I5,' PASSED,',
+ $ I5,' SKIPPED,',I5,' FAILED.')
+*
+ RETURN
+*
+* End of SSDRVTEST.
+*
+ END
+*
+*
+ SUBROUTINE DSDRVTEST( OUTNUM, VERB, NSHAPE, UPLO0, DIAG0,
+ $ NMAT, M0, N0, LDAS0, LDAD0, NSRC, RSRC0,
+ $ CSRC0, RDEST0, CDEST0, NGRID, CONTEXT0,
+ $ P0, Q0, TFAIL, MEM, MEMLEN )
+*
+* -- BLACS tester (version 1.0) --
+* University of Tennessee
+* December 15, 1994
+*
+*
+* .. Scalar Arguments ..
+ INTEGER OUTNUM, VERB, NSHAPE, NMAT, NSRC, NGRID, MEMLEN
+* ..
+* .. Array Arguments ..
+ CHARACTER*1 UPLO0(NSHAPE), DIAG0(NSHAPE)
+ INTEGER M0(NMAT), N0(NMAT), LDAS0(NMAT), LDAD0(NMAT)
+ INTEGER RSRC0(NSRC), CSRC0(NSRC), RDEST0(NSRC), CDEST0(NSRC)
+ INTEGER CONTEXT0(NGRID), P0(NGRID), Q0(NGRID), TFAIL(*)
+ DOUBLE PRECISION MEM(MEMLEN)
+* ..
+*
+* Purpose
+* =======
+* DTESTSDRV: Test double precision send/recv
+*
+* Arguments
+* =========
+* OUTNUM (input) INTEGER
+* The device number to write output to.
+*
+* VERB (input) INTEGER
+* The level of verbosity (how much printing to do).
+*
+* NSHAPE (input) INTEGER
+* The number of matrix shapes to be tested.
+*
+* UPLO0 (input) CHARACTER*1 array of dimension (NSHAPE)
+* Values of UPLO to be tested.
+*
+* DIAG0 (input) CHARACTER*1 array of dimension (NSHAPE)
+* Values of DIAG to be tested.
+*
+* NMAT (input) INTEGER
+* The number of matrices to be tested.
+*
+* M0 (input) INTEGER array of dimension (NMAT)
+* Values of M to be tested.
+*
+* M0 (input) INTEGER array of dimension (NMAT)
+* Values of M to be tested.
+*
+* N0 (input) INTEGER array of dimension (NMAT)
+* Values of N to be tested.
+*
+* LDAS0 (input) INTEGER array of dimension (NMAT)
+* Values of LDAS (leading dimension of A on source process)
+* to be tested.
+*
+* LDAD0 (input) INTEGER array of dimension (NMAT)
+* Values of LDAD (leading dimension of A on destination
+* process) to be tested.
+* NSRC (input) INTEGER
+* The number of sources to be tested.
+*
+* RSRC0 (input) INTEGER array of dimension (NDEST)
+* Values of RSRC (row coordinate of source) to be tested.
+*
+* CSRC0 (input) INTEGER array of dimension (NDEST)
+* Values of CSRC (column coordinate of source) to be tested.
+*
+* RDEST0 (input) INTEGER array of dimension (NNSRC)
+* Values of RDEST (row coordinate of destination) to be
+* tested.
+*
+* CDEST0 (input) INTEGER array of dimension (NNSRC)
+* Values of CDEST (column coordinate of destination) to be
+* tested.
+*
+* NGRID (input) INTEGER
+* The number of process grids to be tested.
+*
+* CONTEXT0 (input) INTEGER array of dimension (NGRID)
+* The BLACS context handles corresponding to the grids.
+*
+* P0 (input) INTEGER array of dimension (NGRID)
+* Values of P (number of process rows, NPROW).
+*
+* Q0 (input) INTEGER array of dimension (NGRID)
+* Values of Q (number of process columns, NPCOL).
+*
+* TFAIL (workspace) INTEGER array of dimension (NTESTS)
+* If VERB < 2, serves to indicate which tests fail. This
+* requires workspace of NTESTS (number of tests performed).
+*
+* MEM (workspace) DOUBLE PRECISION array of dimension (MEMLEN)
+* Used for all other workspaces, including the matrix A,
+* and its pre and post padding.
+*
+* MEMLEN (input) INTEGER
+* The length, in elements, of MEM.
+*
+* =====================================================================
+*
+* .. External Functions ..
+ LOGICAL ALLPASS
+ INTEGER IBTMYPROC, IBTSIZEOF
+ EXTERNAL ALLPASS, IBTMYPROC, IBTSIZEOF
+* ..
+* .. External Subroutines ..
+ EXTERNAL BLACS_GRIDINFO
+ EXTERNAL DTRSD2D, DGESD2D, DTRRV2D, DGERV2D
+ EXTERNAL DINITMAT, DCHKMAT, DCHKPAD, DBTCHECKIN
+* ..
+* .. Local Scalars ..
+ CHARACTER*1 UPLO, DIAG
+ LOGICAL TESTOK
+ INTEGER IAM, I, K, IGR, ISH, IMA, ISO, MYROW, MYCOL, IPRE, IPOST
+ INTEGER M, N, NPROW, NPCOL, RSRC, CSRC, RDEST, CDEST
+ INTEGER NERR, NSKIP, NFAIL, TESTNUM, CONTEXT, MAXERR, LDASRC
+ INTEGER LDADST, ERRDPTR, APTR, ERRIPTR, ISIZE, DSIZE
+ DOUBLE PRECISION SCHECKVAL, RCHECKVAL
+* ..
+* .. Executable Statements ..
+*
+ SCHECKVAL = -0.01D0
+ RCHECKVAL = -0.02D0
+*
+ IAM = IBTMYPROC()
+ ISIZE = IBTSIZEOF('I')
+ DSIZE = IBTSIZEOF('D')
+*
+* Verify file parameters
+*
+ IF( IAM .EQ. 0 ) THEN
+ WRITE(OUTNUM, *) ' '
+ WRITE(OUTNUM, *) ' '
+ WRITE(OUTNUM, 1000 )
+ IF( VERB .GT. 0 ) THEN
+ WRITE(OUTNUM,*) ' '
+ WRITE(OUTNUM, 2000) 'NSHAPE:', NSHAPE
+ WRITE(OUTNUM, 3000) ' UPLO :', ( UPLO0(I), I = 1, NSHAPE )
+ WRITE(OUTNUM, 3000) ' DIAG :', ( DIAG0(I), I = 1, NSHAPE )
+ WRITE(OUTNUM, 2000) 'NMAT :', NMAT
+ WRITE(OUTNUM, 2000) ' M :', ( M0(I), I = 1, NMAT )
+ WRITE(OUTNUM, 2000) ' N :', ( N0(I), I = 1, NMAT )
+ WRITE(OUTNUM, 2000) ' LDAS :', ( LDAS0(I), I = 1, NMAT )
+ WRITE(OUTNUM, 2000) ' LDAD :', ( LDAD0(I), I = 1, NMAT )
+ WRITE(OUTNUM, 2000) 'NSRC :', NSRC
+ WRITE(OUTNUM, 2000) ' RSRC :',( RSRC0(I), I = 1, NSRC )
+ WRITE(OUTNUM, 2000) ' CSRC :',( CSRC0(I), I = 1, NSRC )
+ WRITE(OUTNUM, 2000) ' RDEST:',( RDEST0(I), I = 1, NSRC )
+ WRITE(OUTNUM, 2000) ' CDEST:',( CDEST0(I), I = 1, NSRC )
+ WRITE(OUTNUM, 2000) 'NGRIDS:', NGRID
+ WRITE(OUTNUM, 2000) ' P :', ( P0(I), I = 1, NGRID )
+ WRITE(OUTNUM, 2000) ' Q :', ( Q0(I), I = 1, NGRID )
+ WRITE(OUTNUM, 2000) 'VERB :', VERB
+ WRITE(OUTNUM,*) ' '
+ END IF
+ IF( VERB .GT. 1 ) THEN
+ WRITE(OUTNUM,5000)
+ WRITE(OUTNUM,6000)
+ END IF
+ END IF
+*
+* Find biggest matrix, so we know where to stick error info
+*
+ I = 0
+ DO 10 IMA = 1, NMAT
+ K = N0(IMA) * MAX0( LDAS0(IMA), LDAD0(IMA) ) + 4 * M0(IMA)
+ IF( K .GT. I ) I = K
+ 10 CONTINUE
+ MAXERR = ( DSIZE * (MEMLEN-I) ) / ( DSIZE*2 + ISIZE*6 )
+ IF( MAXERR .LT. 1 ) THEN
+ WRITE(OUTNUM,*) 'ERROR: Not enough memory to run SDRV tests.'
+ CALL BLACS_ABORT(-1, 1)
+ END IF
+ ERRDPTR = I + 1
+ ERRIPTR = ERRDPTR + MAXERR
+ NERR = 0
+ TESTNUM = 0
+ NFAIL = 0
+ NSKIP = 0
+*
+* Loop over grids of matrix
+*
+ DO 110 IGR = 1, NGRID
+*
+ CONTEXT = CONTEXT0(IGR)
+ CALL BLACS_GRIDINFO( CONTEXT, NPROW, NPCOL, MYROW, MYCOL )
+*
+ DO 80 ISH = 1, NSHAPE
+ UPLO = UPLO0(ISH)
+ DIAG = DIAG0(ISH)
+*
+ DO 70 IMA = 1, NMAT
+ M = M0(IMA)
+ N = N0(IMA)
+ LDASRC = LDAS0(IMA)
+ LDADST = LDAD0(IMA)
+*
+ DO 60 ISO = 1, NSRC
+ TESTNUM = TESTNUM + 1
+ RSRC = RSRC0(ISO)
+ CSRC = CSRC0(ISO)
+ IF( RSRC.GE.P0(IGR) .OR. CSRC.GE.Q0(IGR) ) THEN
+ NSKIP = NSKIP + 1
+ GOTO 60
+ END IF
+ RDEST = RDEST0(ISO)
+ CDEST = CDEST0(ISO)
+ IF( RDEST.GE.P0(IGR) .OR. CDEST.GE.Q0(IGR) ) THEN
+ NSKIP = NSKIP + 1
+ GOTO 60
+ END IF
+*
+ IF( VERB .GT. 1 ) THEN
+ IF( IAM .EQ. 0 ) THEN
+ WRITE(OUTNUM, 7000) TESTNUM, 'RUNNING',
+ $ UPLO, DIAG, M, N,
+ $ LDASRC, LDADST, RSRC, CSRC,
+ $ RDEST, CDEST, NPROW, NPCOL
+ END IF
+ END IF
+*
+ TESTOK = .TRUE.
+ IPRE = 2 * M
+ IPOST = IPRE
+ APTR = IPRE + 1
+*
+* source process generates matrix and sends it
+*
+ IF( MYROW .EQ. RSRC .AND. MYCOL .EQ. CSRC ) THEN
+ CALL DINITMAT( UPLO, DIAG, M, N, MEM, LDASRC,
+ $ IPRE, IPOST, SCHECKVAL, TESTNUM,
+ $ MYROW, MYCOL )
+*
+ IF( UPLO .EQ. 'U' .OR. UPLO .EQ. 'L' ) THEN
+ CALL DTRSD2D( CONTEXT, UPLO, DIAG, M, N,
+ $ MEM(APTR), LDASRC, RDEST, CDEST )
+ ELSE
+ CALL DGESD2D( CONTEXT, M, N, MEM(APTR),
+ $ LDASRC, RDEST, CDEST )
+ END IF
+ END IF
+*
+ IF( MYROW .EQ. RDEST .AND. MYCOL .EQ. CDEST ) THEN
+*
+* Pad entire matrix area
+*
+ DO 50 K = 1, IPRE+IPOST+LDADST*N
+ MEM(K) = RCHECKVAL
+ 50 CONTINUE
+*
+* Receive matrix
+*
+ IF( UPLO .EQ. 'U' .OR. UPLO .EQ. 'L' ) THEN
+ CALL DTRRV2D( CONTEXT, UPLO, DIAG, M, N,
+ $ MEM(APTR), LDADST, RSRC, CSRC )
+ ELSE
+ CALL DGERV2D( CONTEXT, M, N, MEM(APTR),
+ $ LDADST, RSRC, CSRC )
+ END IF
+*
+* Check for errors in matrix or padding
+*
+ I = NERR
+ CALL DCHKMAT( UPLO, DIAG, M, N, MEM(APTR), LDADST,
+ $ RSRC, CSRC, MYROW, MYCOL, TESTNUM, MAXERR,
+ $ NERR, MEM(ERRIPTR), MEM(ERRDPTR) )
+*
+ CALL DCHKPAD( UPLO, DIAG, M, N, MEM, LDADST,
+ $ RSRC, CSRC, MYROW, MYCOL, IPRE, IPOST,
+ $ RCHECKVAL, TESTNUM, MAXERR, NERR,
+ $ MEM(ERRIPTR), MEM(ERRDPTR) )
+ TESTOK = I .EQ. NERR
+ END IF
+*
+ IF( VERB .GT. 1 ) THEN
+ I = NERR
+ CALL DBTCHECKIN( 0, OUTNUM, MAXERR, NERR,
+ $ MEM(ERRIPTR), MEM(ERRDPTR),
+ $ TFAIL )
+ IF( IAM .EQ. 0 ) THEN
+ IF( TESTOK .AND. I.EQ.NERR ) THEN
+ WRITE(OUTNUM, 7000) TESTNUM, 'PASSED ',
+ $ UPLO, DIAG, M, N, LDASRC, LDADST,
+ $ RSRC, CSRC, RDEST, CDEST, NPROW, NPCOL
+ ELSE
+ NFAIL = NFAIL + 1
+ WRITE(OUTNUM, 7000) TESTNUM, 'FAILED ',
+ $ UPLO, DIAG, M, N, LDASRC, LDADST,
+ $ RSRC, CSRC, RDEST, CDEST, NPROW, NPCOL
+ ENDIF
+ END IF
+*
+* Once we've printed out errors, can re-use buf space
+*
+ NERR = 0
+ END IF
+ 60 CONTINUE
+ 70 CONTINUE
+ 80 CONTINUE
+ 110 CONTINUE
+*
+ IF( VERB .LT. 2 ) THEN
+ NFAIL = TESTNUM
+ CALL DBTCHECKIN( NFAIL, OUTNUM, MAXERR, NERR, MEM(ERRIPTR),
+ $ MEM(ERRDPTR), TFAIL )
+ END IF
+ IF( IAM .EQ. 0 ) THEN
+ IF( VERB .GT. 1 ) WRITE(OUTNUM,*) ' '
+ IF( NFAIL+NSKIP .EQ. 0 ) THEN
+ WRITE(OUTNUM, 8000 ) TESTNUM
+ ELSE
+ WRITE(OUTNUM, 9000 ) TESTNUM, TESTNUM-NSKIP-NFAIL,
+ $ NSKIP, NFAIL
+ END IF
+ END IF
+*
+* Log whether their were any failures
+*
+ TESTOK = ALLPASS( (NFAIL.EQ.0) )
+*
+ 1000 FORMAT('DOUBLE PRECISION SDRV TESTS: BEGIN.' )
+ 2000 FORMAT(1X,A7,3X,10I6)
+ 3000 FORMAT(1X,A7,3X,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1,
+ $ 5X,A1,5X,A1)
+ 5000 FORMAT(' TEST# STATUS UPLO DIA M N LDAS LDAD RSRC ',
+ $ 'CSRC RDEST CDEST P Q')
+ 6000 FORMAT(' ----- ------- ---- --- ----- ----- ----- ----- ---- ',
+ $ '---- ----- ----- ---- ----')
+ 7000 FORMAT(I6,1X,A7,4X,A1,3X,A1,4I6,2I5,2I6,2I5)
+ 8000 FORMAT('DOUBLE PRECISION SDRV TESTS: PASSED ALL',
+ $ I5, ' TESTS.')
+ 9000 FORMAT('DOUBLE PRECISION SDRV TESTS:',I5,' TESTS;',I5,' PASSED,',
+ $ I5,' SKIPPED,',I5,' FAILED.')
+*
+ RETURN
+*
+* End of DSDRVTEST.
+*
+ END
+*
+*
+ SUBROUTINE CSDRVTEST( OUTNUM, VERB, NSHAPE, UPLO0, DIAG0,
+ $ NMAT, M0, N0, LDAS0, LDAD0, NSRC, RSRC0,
+ $ CSRC0, RDEST0, CDEST0, NGRID, CONTEXT0,
+ $ P0, Q0, TFAIL, MEM, MEMLEN )
+*
+* -- BLACS tester (version 1.0) --
+* University of Tennessee
+* December 15, 1994
+*
+*
+* .. Scalar Arguments ..
+ INTEGER OUTNUM, VERB, NSHAPE, NMAT, NSRC, NGRID, MEMLEN
+* ..
+* .. Array Arguments ..
+ CHARACTER*1 UPLO0(NSHAPE), DIAG0(NSHAPE)
+ INTEGER M0(NMAT), N0(NMAT), LDAS0(NMAT), LDAD0(NMAT)
+ INTEGER RSRC0(NSRC), CSRC0(NSRC), RDEST0(NSRC), CDEST0(NSRC)
+ INTEGER CONTEXT0(NGRID), P0(NGRID), Q0(NGRID), TFAIL(*)
+ COMPLEX MEM(MEMLEN)
+* ..
+*
+* Purpose
+* =======
+* CTESTSDRV: Test complex send/recv
+*
+* Arguments
+* =========
+* OUTNUM (input) INTEGER
+* The device number to write output to.
+*
+* VERB (input) INTEGER
+* The level of verbosity (how much printing to do).
+*
+* NSHAPE (input) INTEGER
+* The number of matrix shapes to be tested.
+*
+* UPLO0 (input) CHARACTER*1 array of dimension (NSHAPE)
+* Values of UPLO to be tested.
+*
+* DIAG0 (input) CHARACTER*1 array of dimension (NSHAPE)
+* Values of DIAG to be tested.
+*
+* NMAT (input) INTEGER
+* The number of matrices to be tested.
+*
+* M0 (input) INTEGER array of dimension (NMAT)
+* Values of M to be tested.
+*
+* M0 (input) INTEGER array of dimension (NMAT)
+* Values of M to be tested.
+*
+* N0 (input) INTEGER array of dimension (NMAT)
+* Values of N to be tested.
+*
+* LDAS0 (input) INTEGER array of dimension (NMAT)
+* Values of LDAS (leading dimension of A on source process)
+* to be tested.
+*
+* LDAD0 (input) INTEGER array of dimension (NMAT)
+* Values of LDAD (leading dimension of A on destination
+* process) to be tested.
+* NSRC (input) INTEGER
+* The number of sources to be tested.
+*
+* RSRC0 (input) INTEGER array of dimension (NDEST)
+* Values of RSRC (row coordinate of source) to be tested.
+*
+* CSRC0 (input) INTEGER array of dimension (NDEST)
+* Values of CSRC (column coordinate of source) to be tested.
+*
+* RDEST0 (input) INTEGER array of dimension (NNSRC)
+* Values of RDEST (row coordinate of destination) to be
+* tested.
+*
+* CDEST0 (input) INTEGER array of dimension (NNSRC)
+* Values of CDEST (column coordinate of destination) to be
+* tested.
+*
+* NGRID (input) INTEGER
+* The number of process grids to be tested.
+*
+* CONTEXT0 (input) INTEGER array of dimension (NGRID)
+* The BLACS context handles corresponding to the grids.
+*
+* P0 (input) INTEGER array of dimension (NGRID)
+* Values of P (number of process rows, NPROW).
+*
+* Q0 (input) INTEGER array of dimension (NGRID)
+* Values of Q (number of process columns, NPCOL).
+*
+* TFAIL (workspace) INTEGER array of dimension (NTESTS)
+* If VERB < 2, serves to indicate which tests fail. This
+* requires workspace of NTESTS (number of tests performed).
+*
+* MEM (workspace) COMPLEX array of dimension (MEMLEN)
+* Used for all other workspaces, including the matrix A,
+* and its pre and post padding.
+*
+* MEMLEN (input) INTEGER
+* The length, in elements, of MEM.
+*
+* =====================================================================
+*
+* .. External Functions ..
+ LOGICAL ALLPASS
+ INTEGER IBTMYPROC, IBTSIZEOF
+ EXTERNAL ALLPASS, IBTMYPROC, IBTSIZEOF
+* ..
+* .. External Subroutines ..
+ EXTERNAL BLACS_GRIDINFO
+ EXTERNAL CTRSD2D, CGESD2D, CTRRV2D, CGERV2D
+ EXTERNAL CINITMAT, CCHKMAT, CCHKPAD, CBTCHECKIN
+* ..
+* .. Local Scalars ..
+ CHARACTER*1 UPLO, DIAG
+ LOGICAL TESTOK
+ INTEGER IAM, I, K, IGR, ISH, IMA, ISO, MYROW, MYCOL, IPRE, IPOST
+ INTEGER M, N, NPROW, NPCOL, RSRC, CSRC, RDEST, CDEST
+ INTEGER NERR, NSKIP, NFAIL, TESTNUM, CONTEXT, MAXERR, LDASRC
+ INTEGER LDADST, ERRDPTR, APTR, ERRIPTR, ISIZE, CSIZE
+ COMPLEX SCHECKVAL, RCHECKVAL
+* ..
+* .. Executable Statements ..
+*
+ SCHECKVAL = CMPLX( -0.01, -0.01 )
+ RCHECKVAL = CMPLX( -0.02, -0.02 )
+*
+ IAM = IBTMYPROC()
+ ISIZE = IBTSIZEOF('I')
+ CSIZE = IBTSIZEOF('C')
+*
+* Verify file parameters
+*
+ IF( IAM .EQ. 0 ) THEN
+ WRITE(OUTNUM, *) ' '
+ WRITE(OUTNUM, *) ' '
+ WRITE(OUTNUM, 1000 )
+ IF( VERB .GT. 0 ) THEN
+ WRITE(OUTNUM,*) ' '
+ WRITE(OUTNUM, 2000) 'NSHAPE:', NSHAPE
+ WRITE(OUTNUM, 3000) ' UPLO :', ( UPLO0(I), I = 1, NSHAPE )
+ WRITE(OUTNUM, 3000) ' DIAG :', ( DIAG0(I), I = 1, NSHAPE )
+ WRITE(OUTNUM, 2000) 'NMAT :', NMAT
+ WRITE(OUTNUM, 2000) ' M :', ( M0(I), I = 1, NMAT )
+ WRITE(OUTNUM, 2000) ' N :', ( N0(I), I = 1, NMAT )
+ WRITE(OUTNUM, 2000) ' LDAS :', ( LDAS0(I), I = 1, NMAT )
+ WRITE(OUTNUM, 2000) ' LDAD :', ( LDAD0(I), I = 1, NMAT )
+ WRITE(OUTNUM, 2000) 'NSRC :', NSRC
+ WRITE(OUTNUM, 2000) ' RSRC :',( RSRC0(I), I = 1, NSRC )
+ WRITE(OUTNUM, 2000) ' CSRC :',( CSRC0(I), I = 1, NSRC )
+ WRITE(OUTNUM, 2000) ' RDEST:',( RDEST0(I), I = 1, NSRC )
+ WRITE(OUTNUM, 2000) ' CDEST:',( CDEST0(I), I = 1, NSRC )
+ WRITE(OUTNUM, 2000) 'NGRIDS:', NGRID
+ WRITE(OUTNUM, 2000) ' P :', ( P0(I), I = 1, NGRID )
+ WRITE(OUTNUM, 2000) ' Q :', ( Q0(I), I = 1, NGRID )
+ WRITE(OUTNUM, 2000) 'VERB :', VERB
+ WRITE(OUTNUM,*) ' '
+ END IF
+ IF( VERB .GT. 1 ) THEN
+ WRITE(OUTNUM,5000)
+ WRITE(OUTNUM,6000)
+ END IF
+ END IF
+*
+* Find biggest matrix, so we know where to stick error info
+*
+ I = 0
+ DO 10 IMA = 1, NMAT
+ K = N0(IMA) * MAX0( LDAS0(IMA), LDAD0(IMA) ) + 4 * M0(IMA)
+ IF( K .GT. I ) I = K
+ 10 CONTINUE
+ MAXERR = ( CSIZE * (MEMLEN-I) ) / ( CSIZE*2 + ISIZE*6 )
+ IF( MAXERR .LT. 1 ) THEN
+ WRITE(OUTNUM,*) 'ERROR: Not enough memory to run SDRV tests.'
+ CALL BLACS_ABORT(-1, 1)
+ END IF
+ ERRDPTR = I + 1
+ ERRIPTR = ERRDPTR + MAXERR
+ NERR = 0
+ TESTNUM = 0
+ NFAIL = 0
+ NSKIP = 0
+*
+* Loop over grids of matrix
+*
+ DO 110 IGR = 1, NGRID
+*
+ CONTEXT = CONTEXT0(IGR)
+ CALL BLACS_GRIDINFO( CONTEXT, NPROW, NPCOL, MYROW, MYCOL )
+*
+ DO 80 ISH = 1, NSHAPE
+ UPLO = UPLO0(ISH)
+ DIAG = DIAG0(ISH)
+*
+ DO 70 IMA = 1, NMAT
+ M = M0(IMA)
+ N = N0(IMA)
+ LDASRC = LDAS0(IMA)
+ LDADST = LDAD0(IMA)
+*
+ DO 60 ISO = 1, NSRC
+ TESTNUM = TESTNUM + 1
+ RSRC = RSRC0(ISO)
+ CSRC = CSRC0(ISO)
+ IF( RSRC.GE.P0(IGR) .OR. CSRC.GE.Q0(IGR) ) THEN
+ NSKIP = NSKIP + 1
+ GOTO 60
+ END IF
+ RDEST = RDEST0(ISO)
+ CDEST = CDEST0(ISO)
+ IF( RDEST.GE.P0(IGR) .OR. CDEST.GE.Q0(IGR) ) THEN
+ NSKIP = NSKIP + 1
+ GOTO 60
+ END IF
+*
+ IF( VERB .GT. 1 ) THEN
+ IF( IAM .EQ. 0 ) THEN
+ WRITE(OUTNUM, 7000) TESTNUM, 'RUNNING',
+ $ UPLO, DIAG, M, N,
+ $ LDASRC, LDADST, RSRC, CSRC,
+ $ RDEST, CDEST, NPROW, NPCOL
+ END IF
+ END IF
+*
+ TESTOK = .TRUE.
+ IPRE = 2 * M
+ IPOST = IPRE
+ APTR = IPRE + 1
+*
+* source process generates matrix and sends it
+*
+ IF( MYROW .EQ. RSRC .AND. MYCOL .EQ. CSRC ) THEN
+ CALL CINITMAT( UPLO, DIAG, M, N, MEM, LDASRC,
+ $ IPRE, IPOST, SCHECKVAL, TESTNUM,
+ $ MYROW, MYCOL )
+*
+ IF( UPLO .EQ. 'U' .OR. UPLO .EQ. 'L' ) THEN
+ CALL CTRSD2D( CONTEXT, UPLO, DIAG, M, N,
+ $ MEM(APTR), LDASRC, RDEST, CDEST )
+ ELSE
+ CALL CGESD2D( CONTEXT, M, N, MEM(APTR),
+ $ LDASRC, RDEST, CDEST )
+ END IF
+ END IF
+*
+ IF( MYROW .EQ. RDEST .AND. MYCOL .EQ. CDEST ) THEN
+*
+* Pad entire matrix area
+*
+ DO 50 K = 1, IPRE+IPOST+LDADST*N
+ MEM(K) = RCHECKVAL
+ 50 CONTINUE
+*
+* Receive matrix
+*
+ IF( UPLO .EQ. 'U' .OR. UPLO .EQ. 'L' ) THEN
+ CALL CTRRV2D( CONTEXT, UPLO, DIAG, M, N,
+ $ MEM(APTR), LDADST, RSRC, CSRC )
+ ELSE
+ CALL CGERV2D( CONTEXT, M, N, MEM(APTR),
+ $ LDADST, RSRC, CSRC )
+ END IF
+*
+* Check for errors in matrix or padding
+*
+ I = NERR
+ CALL CCHKMAT( UPLO, DIAG, M, N, MEM(APTR), LDADST,
+ $ RSRC, CSRC, MYROW, MYCOL, TESTNUM, MAXERR,
+ $ NERR, MEM(ERRIPTR), MEM(ERRDPTR) )
+*
+ CALL CCHKPAD( UPLO, DIAG, M, N, MEM, LDADST,
+ $ RSRC, CSRC, MYROW, MYCOL, IPRE, IPOST,
+ $ RCHECKVAL, TESTNUM, MAXERR, NERR,
+ $ MEM(ERRIPTR), MEM(ERRDPTR) )
+ TESTOK = I .EQ. NERR
+ END IF
+*
+ IF( VERB .GT. 1 ) THEN
+ I = NERR
+ CALL CBTCHECKIN( 0, OUTNUM, MAXERR, NERR,
+ $ MEM(ERRIPTR), MEM(ERRDPTR),
+ $ TFAIL )
+ IF( IAM .EQ. 0 ) THEN
+ IF( TESTOK .AND. I.EQ.NERR ) THEN
+ WRITE(OUTNUM, 7000) TESTNUM, 'PASSED ',
+ $ UPLO, DIAG, M, N, LDASRC, LDADST,
+ $ RSRC, CSRC, RDEST, CDEST, NPROW, NPCOL
+ ELSE
+ NFAIL = NFAIL + 1
+ WRITE(OUTNUM, 7000) TESTNUM, 'FAILED ',
+ $ UPLO, DIAG, M, N, LDASRC, LDADST,
+ $ RSRC, CSRC, RDEST, CDEST, NPROW, NPCOL
+ ENDIF
+ END IF
+*
+* Once we've printed out errors, can re-use buf space
+*
+ NERR = 0
+ END IF
+ 60 CONTINUE
+ 70 CONTINUE
+ 80 CONTINUE
+ 110 CONTINUE
+*
+ IF( VERB .LT. 2 ) THEN
+ NFAIL = TESTNUM
+ CALL CBTCHECKIN( NFAIL, OUTNUM, MAXERR, NERR, MEM(ERRIPTR),
+ $ MEM(ERRDPTR), TFAIL )
+ END IF
+ IF( IAM .EQ. 0 ) THEN
+ IF( VERB .GT. 1 ) WRITE(OUTNUM,*) ' '
+ IF( NFAIL+NSKIP .EQ. 0 ) THEN
+ WRITE(OUTNUM, 8000 ) TESTNUM
+ ELSE
+ WRITE(OUTNUM, 9000 ) TESTNUM, TESTNUM-NSKIP-NFAIL,
+ $ NSKIP, NFAIL
+ END IF
+ END IF
+*
+* Log whether their were any failures
+*
+ TESTOK = ALLPASS( (NFAIL.EQ.0) )
+*
+ 1000 FORMAT('COMPLEX SDRV TESTS: BEGIN.' )
+ 2000 FORMAT(1X,A7,3X,10I6)
+ 3000 FORMAT(1X,A7,3X,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1,
+ $ 5X,A1,5X,A1)
+ 5000 FORMAT(' TEST# STATUS UPLO DIA M N LDAS LDAD RSRC ',
+ $ 'CSRC RDEST CDEST P Q')
+ 6000 FORMAT(' ----- ------- ---- --- ----- ----- ----- ----- ---- ',
+ $ '---- ----- ----- ---- ----')
+ 7000 FORMAT(I6,1X,A7,4X,A1,3X,A1,4I6,2I5,2I6,2I5)
+ 8000 FORMAT('COMPLEX SDRV TESTS: PASSED ALL',
+ $ I5, ' TESTS.')
+ 9000 FORMAT('COMPLEX SDRV TESTS:',I5,' TESTS;',I5,' PASSED,',
+ $ I5,' SKIPPED,',I5,' FAILED.')
+*
+ RETURN
+*
+* End of CSDRVTEST.
+*
+ END
+*
+*
+ SUBROUTINE ZSDRVTEST( OUTNUM, VERB, NSHAPE, UPLO0, DIAG0,
+ $ NMAT, M0, N0, LDAS0, LDAD0, NSRC, RSRC0,
+ $ CSRC0, RDEST0, CDEST0, NGRID, CONTEXT0,
+ $ P0, Q0, TFAIL, MEM, MEMLEN )
+*
+* -- BLACS tester (version 1.0) --
+* University of Tennessee
+* December 15, 1994
+*
+*
+* .. Scalar Arguments ..
+ INTEGER OUTNUM, VERB, NSHAPE, NMAT, NSRC, NGRID, MEMLEN
+* ..
+* .. Array Arguments ..
+ CHARACTER*1 UPLO0(NSHAPE), DIAG0(NSHAPE)
+ INTEGER M0(NMAT), N0(NMAT), LDAS0(NMAT), LDAD0(NMAT)
+ INTEGER RSRC0(NSRC), CSRC0(NSRC), RDEST0(NSRC), CDEST0(NSRC)
+ INTEGER CONTEXT0(NGRID), P0(NGRID), Q0(NGRID), TFAIL(*)
+ DOUBLE COMPLEX MEM(MEMLEN)
+* ..
+*
+* Purpose
+* =======
+* ZTESTSDRV: Test double complex send/recv
+*
+* Arguments
+* =========
+* OUTNUM (input) INTEGER
+* The device number to write output to.
+*
+* VERB (input) INTEGER
+* The level of verbosity (how much printing to do).
+*
+* NSHAPE (input) INTEGER
+* The number of matrix shapes to be tested.
+*
+* UPLO0 (input) CHARACTER*1 array of dimension (NSHAPE)
+* Values of UPLO to be tested.
+*
+* DIAG0 (input) CHARACTER*1 array of dimension (NSHAPE)
+* Values of DIAG to be tested.
+*
+* NMAT (input) INTEGER
+* The number of matrices to be tested.
+*
+* M0 (input) INTEGER array of dimension (NMAT)
+* Values of M to be tested.
+*
+* M0 (input) INTEGER array of dimension (NMAT)
+* Values of M to be tested.
+*
+* N0 (input) INTEGER array of dimension (NMAT)
+* Values of N to be tested.
+*
+* LDAS0 (input) INTEGER array of dimension (NMAT)
+* Values of LDAS (leading dimension of A on source process)
+* to be tested.
+*
+* LDAD0 (input) INTEGER array of dimension (NMAT)
+* Values of LDAD (leading dimension of A on destination
+* process) to be tested.
+* NSRC (input) INTEGER
+* The number of sources to be tested.
+*
+* RSRC0 (input) INTEGER array of dimension (NDEST)
+* Values of RSRC (row coordinate of source) to be tested.
+*
+* CSRC0 (input) INTEGER array of dimension (NDEST)
+* Values of CSRC (column coordinate of source) to be tested.
+*
+* RDEST0 (input) INTEGER array of dimension (NNSRC)
+* Values of RDEST (row coordinate of destination) to be
+* tested.
+*
+* CDEST0 (input) INTEGER array of dimension (NNSRC)
+* Values of CDEST (column coordinate of destination) to be
+* tested.
+*
+* NGRID (input) INTEGER
+* The number of process grids to be tested.
+*
+* CONTEXT0 (input) INTEGER array of dimension (NGRID)
+* The BLACS context handles corresponding to the grids.
+*
+* P0 (input) INTEGER array of dimension (NGRID)
+* Values of P (number of process rows, NPROW).
+*
+* Q0 (input) INTEGER array of dimension (NGRID)
+* Values of Q (number of process columns, NPCOL).
+*
+* TFAIL (workspace) INTEGER array of dimension (NTESTS)
+* If VERB < 2, serves to indicate which tests fail. This
+* requires workspace of NTESTS (number of tests performed).
+*
+* MEM (workspace) DOUBLE COMPLEX array of dimension (MEMLEN)
+* Used for all other workspaces, including the matrix A,
+* and its pre and post padding.
+*
+* MEMLEN (input) INTEGER
+* The length, in elements, of MEM.
+*
+* =====================================================================
+*
+* .. External Functions ..
+ LOGICAL ALLPASS
+ INTEGER IBTMYPROC, IBTSIZEOF
+ EXTERNAL ALLPASS, IBTMYPROC, IBTSIZEOF
+* ..
+* .. External Subroutines ..
+ EXTERNAL BLACS_GRIDINFO
+ EXTERNAL ZTRSD2D, ZGESD2D, ZTRRV2D, ZGERV2D
+ EXTERNAL ZINITMAT, ZCHKMAT, ZCHKPAD, ZBTCHECKIN
+* ..
+* .. Local Scalars ..
+ CHARACTER*1 UPLO, DIAG
+ LOGICAL TESTOK
+ INTEGER IAM, I, K, IGR, ISH, IMA, ISO, MYROW, MYCOL, IPRE, IPOST
+ INTEGER M, N, NPROW, NPCOL, RSRC, CSRC, RDEST, CDEST
+ INTEGER NERR, NSKIP, NFAIL, TESTNUM, CONTEXT, MAXERR, LDASRC
+ INTEGER LDADST, ERRDPTR, APTR, ERRIPTR, ISIZE, ZSIZE
+ DOUBLE COMPLEX SCHECKVAL, RCHECKVAL
+* ..
+* .. Executable Statements ..
+*
+ SCHECKVAL = DCMPLX( -0.01D0, -0.01D0 )
+ RCHECKVAL = DCMPLX( -0.02D0, -0.02D0 )
+*
+ IAM = IBTMYPROC()
+ ISIZE = IBTSIZEOF('I')
+ ZSIZE = IBTSIZEOF('Z')
+*
+* Verify file parameters
+*
+ IF( IAM .EQ. 0 ) THEN
+ WRITE(OUTNUM, *) ' '
+ WRITE(OUTNUM, *) ' '
+ WRITE(OUTNUM, 1000 )
+ IF( VERB .GT. 0 ) THEN
+ WRITE(OUTNUM,*) ' '
+ WRITE(OUTNUM, 2000) 'NSHAPE:', NSHAPE
+ WRITE(OUTNUM, 3000) ' UPLO :', ( UPLO0(I), I = 1, NSHAPE )
+ WRITE(OUTNUM, 3000) ' DIAG :', ( DIAG0(I), I = 1, NSHAPE )
+ WRITE(OUTNUM, 2000) 'NMAT :', NMAT
+ WRITE(OUTNUM, 2000) ' M :', ( M0(I), I = 1, NMAT )
+ WRITE(OUTNUM, 2000) ' N :', ( N0(I), I = 1, NMAT )
+ WRITE(OUTNUM, 2000) ' LDAS :', ( LDAS0(I), I = 1, NMAT )
+ WRITE(OUTNUM, 2000) ' LDAD :', ( LDAD0(I), I = 1, NMAT )
+ WRITE(OUTNUM, 2000) 'NSRC :', NSRC
+ WRITE(OUTNUM, 2000) ' RSRC :',( RSRC0(I), I = 1, NSRC )
+ WRITE(OUTNUM, 2000) ' CSRC :',( CSRC0(I), I = 1, NSRC )
+ WRITE(OUTNUM, 2000) ' RDEST:',( RDEST0(I), I = 1, NSRC )
+ WRITE(OUTNUM, 2000) ' CDEST:',( CDEST0(I), I = 1, NSRC )
+ WRITE(OUTNUM, 2000) 'NGRIDS:', NGRID
+ WRITE(OUTNUM, 2000) ' P :', ( P0(I), I = 1, NGRID )
+ WRITE(OUTNUM, 2000) ' Q :', ( Q0(I), I = 1, NGRID )
+ WRITE(OUTNUM, 2000) 'VERB :', VERB
+ WRITE(OUTNUM,*) ' '
+ END IF
+ IF( VERB .GT. 1 ) THEN
+ WRITE(OUTNUM,5000)
+ WRITE(OUTNUM,6000)
+ END IF
+ END IF
+*
+* Find biggest matrix, so we know where to stick error info
+*
+ I = 0
+ DO 10 IMA = 1, NMAT
+ K = N0(IMA) * MAX0( LDAS0(IMA), LDAD0(IMA) ) + 4 * M0(IMA)
+ IF( K .GT. I ) I = K
+ 10 CONTINUE
+ MAXERR = ( ZSIZE * (MEMLEN-I) ) / ( ZSIZE*2 + ISIZE*6 )
+ IF( MAXERR .LT. 1 ) THEN
+ WRITE(OUTNUM,*) 'ERROR: Not enough memory to run SDRV tests.'
+ CALL BLACS_ABORT(-1, 1)
+ END IF
+ ERRDPTR = I + 1
+ ERRIPTR = ERRDPTR + MAXERR
+ NERR = 0
+ TESTNUM = 0
+ NFAIL = 0
+ NSKIP = 0
+*
+* Loop over grids of matrix
+*
+ DO 110 IGR = 1, NGRID
+*
+ CONTEXT = CONTEXT0(IGR)
+ CALL BLACS_GRIDINFO( CONTEXT, NPROW, NPCOL, MYROW, MYCOL )
+*
+ DO 80 ISH = 1, NSHAPE
+ UPLO = UPLO0(ISH)
+ DIAG = DIAG0(ISH)
+*
+ DO 70 IMA = 1, NMAT
+ M = M0(IMA)
+ N = N0(IMA)
+ LDASRC = LDAS0(IMA)
+ LDADST = LDAD0(IMA)
+*
+ DO 60 ISO = 1, NSRC
+ TESTNUM = TESTNUM + 1
+ RSRC = RSRC0(ISO)
+ CSRC = CSRC0(ISO)
+ IF( RSRC.GE.P0(IGR) .OR. CSRC.GE.Q0(IGR) ) THEN
+ NSKIP = NSKIP + 1
+ GOTO 60
+ END IF
+ RDEST = RDEST0(ISO)
+ CDEST = CDEST0(ISO)
+ IF( RDEST.GE.P0(IGR) .OR. CDEST.GE.Q0(IGR) ) THEN
+ NSKIP = NSKIP + 1
+ GOTO 60
+ END IF
+*
+ IF( VERB .GT. 1 ) THEN
+ IF( IAM .EQ. 0 ) THEN
+ WRITE(OUTNUM, 7000) TESTNUM, 'RUNNING',
+ $ UPLO, DIAG, M, N,
+ $ LDASRC, LDADST, RSRC, CSRC,
+ $ RDEST, CDEST, NPROW, NPCOL
+ END IF
+ END IF
+*
+ TESTOK = .TRUE.
+ IPRE = 2 * M
+ IPOST = IPRE
+ APTR = IPRE + 1
+*
+* source process generates matrix and sends it
+*
+ IF( MYROW .EQ. RSRC .AND. MYCOL .EQ. CSRC ) THEN
+ CALL ZINITMAT( UPLO, DIAG, M, N, MEM, LDASRC,
+ $ IPRE, IPOST, SCHECKVAL, TESTNUM,
+ $ MYROW, MYCOL )
+*
+ IF( UPLO .EQ. 'U' .OR. UPLO .EQ. 'L' ) THEN
+ CALL ZTRSD2D( CONTEXT, UPLO, DIAG, M, N,
+ $ MEM(APTR), LDASRC, RDEST, CDEST )
+ ELSE
+ CALL ZGESD2D( CONTEXT, M, N, MEM(APTR),
+ $ LDASRC, RDEST, CDEST )
+ END IF
+ END IF
+*
+ IF( MYROW .EQ. RDEST .AND. MYCOL .EQ. CDEST ) THEN
+*
+* Pad entire matrix area
+*
+ DO 50 K = 1, IPRE+IPOST+LDADST*N
+ MEM(K) = RCHECKVAL
+ 50 CONTINUE
+*
+* Receive matrix
+*
+ IF( UPLO .EQ. 'U' .OR. UPLO .EQ. 'L' ) THEN
+ CALL ZTRRV2D( CONTEXT, UPLO, DIAG, M, N,
+ $ MEM(APTR), LDADST, RSRC, CSRC )
+ ELSE
+ CALL ZGERV2D( CONTEXT, M, N, MEM(APTR),
+ $ LDADST, RSRC, CSRC )
+ END IF
+*
+* Check for errors in matrix or padding
+*
+ I = NERR
+ CALL ZCHKMAT( UPLO, DIAG, M, N, MEM(APTR), LDADST,
+ $ RSRC, CSRC, MYROW, MYCOL, TESTNUM, MAXERR,
+ $ NERR, MEM(ERRIPTR), MEM(ERRDPTR) )
+*
+ CALL ZCHKPAD( UPLO, DIAG, M, N, MEM, LDADST,
+ $ RSRC, CSRC, MYROW, MYCOL, IPRE, IPOST,
+ $ RCHECKVAL, TESTNUM, MAXERR, NERR,
+ $ MEM(ERRIPTR), MEM(ERRDPTR) )
+ TESTOK = I .EQ. NERR
+ END IF
+*
+ IF( VERB .GT. 1 ) THEN
+ I = NERR
+ CALL ZBTCHECKIN( 0, OUTNUM, MAXERR, NERR,
+ $ MEM(ERRIPTR), MEM(ERRDPTR),
+ $ TFAIL )
+ IF( IAM .EQ. 0 ) THEN
+ IF( TESTOK .AND. I.EQ.NERR ) THEN
+ WRITE(OUTNUM, 7000) TESTNUM, 'PASSED ',
+ $ UPLO, DIAG, M, N, LDASRC, LDADST,
+ $ RSRC, CSRC, RDEST, CDEST, NPROW, NPCOL
+ ELSE
+ NFAIL = NFAIL + 1
+ WRITE(OUTNUM, 7000) TESTNUM, 'FAILED ',
+ $ UPLO, DIAG, M, N, LDASRC, LDADST,
+ $ RSRC, CSRC, RDEST, CDEST, NPROW, NPCOL
+ ENDIF
+ END IF
+*
+* Once we've printed out errors, can re-use buf space
+*
+ NERR = 0
+ END IF
+ 60 CONTINUE
+ 70 CONTINUE
+ 80 CONTINUE
+ 110 CONTINUE
+*
+ IF( VERB .LT. 2 ) THEN
+ NFAIL = TESTNUM
+ CALL ZBTCHECKIN( NFAIL, OUTNUM, MAXERR, NERR, MEM(ERRIPTR),
+ $ MEM(ERRDPTR), TFAIL )
+ END IF
+ IF( IAM .EQ. 0 ) THEN
+ IF( VERB .GT. 1 ) WRITE(OUTNUM,*) ' '
+ IF( NFAIL+NSKIP .EQ. 0 ) THEN
+ WRITE(OUTNUM, 8000 ) TESTNUM
+ ELSE
+ WRITE(OUTNUM, 9000 ) TESTNUM, TESTNUM-NSKIP-NFAIL,
+ $ NSKIP, NFAIL
+ END IF
+ END IF
+*
+* Log whether their were any failures
+*
+ TESTOK = ALLPASS( (NFAIL.EQ.0) )
+*
+ 1000 FORMAT('DOUBLE COMPLEX SDRV TESTS: BEGIN.' )
+ 2000 FORMAT(1X,A7,3X,10I6)
+ 3000 FORMAT(1X,A7,3X,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1,
+ $ 5X,A1,5X,A1)
+ 5000 FORMAT(' TEST# STATUS UPLO DIA M N LDAS LDAD RSRC ',
+ $ 'CSRC RDEST CDEST P Q')
+ 6000 FORMAT(' ----- ------- ---- --- ----- ----- ----- ----- ---- ',
+ $ '---- ----- ----- ---- ----')
+ 7000 FORMAT(I6,1X,A7,4X,A1,3X,A1,4I6,2I5,2I6,2I5)
+ 8000 FORMAT('DOUBLE COMPLEX SDRV TESTS: PASSED ALL',
+ $ I5, ' TESTS.')
+ 9000 FORMAT('DOUBLE COMPLEX SDRV TESTS:',I5,' TESTS;',I5,' PASSED,',
+ $ I5,' SKIPPED,',I5,' FAILED.')
+*
+ RETURN
+*
+* End of ZSDRVTEST.
+*
+ END
+*
+*
+ SUBROUTINE IBSBRTEST( OUTNUM, VERB, NSCOPE, SCOPE0, NTOP, TOP0,
+ $ NSHAPE, UPLO0, DIAG0, NMAT, M0, N0, LDAS0,
+ $ LDAD0, NSRC, RSRC0, CSRC0, NGRID, CONTEXT0,
+ $ P0, Q0, TFAIL, MEM, MEMLEN )
+*
+* -- BLACS tester (version 1.0) --
+* University of Tennessee
+* December 15, 1994
+*
+*
+* .. Scalar Arguments ..
+ INTEGER OUTNUM, VERB, NSCOPE, NTOP, NSHAPE, NMAT, NSRC, NGRID
+ INTEGER MEMLEN
+* ..
+* .. Array Arguments ..
+ CHARACTER*1 SCOPE0(NSCOPE), TOP0(NTOP)
+ CHARACTER*1 UPLO0(NSHAPE), DIAG0(NSHAPE)
+ INTEGER M0(NMAT), N0(NMAT), LDAS0(NMAT), LDAD0(NMAT)
+ INTEGER RSRC0(NSRC), CSRC0(NSRC), CONTEXT0(NGRID)
+ INTEGER P0(NGRID), Q0(NGRID), TFAIL(*)
+ INTEGER MEM(MEMLEN)
+* ..
+*
+* Purpose
+* =======
+* ITESTBSBR: Test integer broadcast
+*
+* Arguments
+* =========
+* OUTNUM (input) INTEGER
+* The device number to write output to.
+*
+* VERB (input) INTEGER
+* The level of verbosity (how much printing to do).
+*
+* NSCOPE (input) INTEGER
+* The number of scopes to be tested.
+*
+* SCOPE0 (input) CHARACTER*1 array of dimension (NSCOPE)
+* Values of the scopes to be tested.
+*
+* NTOP (input) INTEGER
+* The number of topologies to be tested.
+*
+* TOP0 (input) CHARACTER*1 array of dimension (NTOP)
+* Values of the topologies to be tested.
+*
+* NSHAPE (input) INTEGER
+* The number of matrix shapes to be tested.
+*
+* UPLO0 (input) CHARACTER*1 array of dimension (NSHAPE)
+* Values of UPLO to be tested.
+*
+* DIAG0 (input) CHARACTER*1 array of dimension (NSHAPE)
+* Values of DIAG to be tested.
+*
+* NMAT (input) INTEGER
+* The number of matrices to be tested.
+*
+* M0 (input) INTEGER array of dimension (NMAT)
+* Values of M to be tested.
+*
+* M0 (input) INTEGER array of dimension (NMAT)
+* Values of M to be tested.
+*
+* N0 (input) INTEGER array of dimension (NMAT)
+* Values of N to be tested.
+*
+* LDAS0 (input) INTEGER array of dimension (NMAT)
+* Values of LDAS (leading dimension of A on source process)
+* to be tested.
+*
+* LDAD0 (input) INTEGER array of dimension (NMAT)
+* Values of LDAD (leading dimension of A on destination
+* process) to be tested.
+* NSRC (input) INTEGER
+* The number of sources to be tested.
+*
+* RSRC0 (input) INTEGER array of dimension (NDEST)
+* Values of RSRC (row coordinate of source) to be tested.
+*
+* CSRC0 (input) INTEGER array of dimension (NDEST)
+* Values of CSRC (column coordinate of source) to be tested.
+*
+* NGRID (input) INTEGER
+* The number of process grids to be tested.
+*
+* CONTEXT0 (input) INTEGER array of dimension (NGRID)
+* The BLACS context handles corresponding to the grids.
+*
+* P0 (input) INTEGER array of dimension (NGRID)
+* Values of P (number of process rows, NPROW).
+*
+* Q0 (input) INTEGER array of dimension (NGRID)
+* Values of Q (number of process columns, NPCOL).
+*
+* TFAIL (workspace) INTEGER array of dimension (NTESTS)
+* If VERB < 2, serves to indicate which tests fail. This
+* requires workspace of NTESTS (number of tests performed).
+*
+* MEM (workspace) INTEGER array of dimension (MEMLEN)
+* Used for all other workspaces, including the matrix A,
+* and its pre and post padding.
+*
+* MEMLEN (input) INTEGER
+* The length, in elements, of MEM.
+*
+* =====================================================================
+*
+* .. External Functions ..
+ LOGICAL ALLPASS, LSAME
+ INTEGER IBTMYPROC, IBTSIZEOF
+ EXTERNAL ALLPASS, LSAME, IBTMYPROC, IBTSIZEOF
+* ..
+* .. External Subroutines ..
+ EXTERNAL BLACS_GRIDINFO
+ EXTERNAL ITRBS2D, IGEBS2D, ITRBR2D, IGEBR2D
+ EXTERNAL IINITMAT, ICHKMAT, ICHKPAD, IBTCHECKIN
+* ..
+* .. Local Scalars ..
+ CHARACTER*1 SCOPE, TOP, UPLO, DIAG
+ LOGICAL TESTOK, INGRID
+ INTEGER IAM, I, K, J, IGR, ISH, IMA, ISO, ISC, ITO
+ INTEGER M, N, NPROW, NPCOL, MYROW, MYCOL, RSRC, CSRC
+ INTEGER ISTART, ISTOP, IPRE, IPOST, SETWHAT
+ INTEGER NERR, NSKIP, NFAIL, TESTNUM, CONTEXT, MAXERR, LDASRC
+ INTEGER LDADST, ERRDPTR, APTR, ERRIPTR, ISIZE
+ INTEGER SCHECKVAL, RCHECKVAL
+* ..
+* .. Executable Statements ..
+*
+ SCHECKVAL = -1
+ RCHECKVAL = -2
+*
+ IAM = IBTMYPROC()
+ ISIZE = IBTSIZEOF('I')
+ ISIZE = IBTSIZEOF('I')
+*
+* Verify file parameters
+*
+ IF( IAM .EQ. 0 ) THEN
+ WRITE(OUTNUM, *) ' '
+ WRITE(OUTNUM, *) ' '
+ WRITE(OUTNUM, 1000 )
+ IF( VERB .GT. 0 ) THEN
+ WRITE(OUTNUM,*) ' '
+ WRITE(OUTNUM, 2000) 'NSCOPE:', NSCOPE
+ WRITE(OUTNUM, 3000) ' SCOPE:', ( SCOPE0(I), I = 1, NSCOPE )
+ WRITE(OUTNUM, 2000) 'NTOP :', NTOP
+ WRITE(OUTNUM, 3000) ' TOP :', ( TOP0(I), I = 1, NTOP )
+ WRITE(OUTNUM, 2000) 'NSHAPE:', NSHAPE
+ WRITE(OUTNUM, 3000) ' UPLO :', ( UPLO0(I), I = 1, NSHAPE )
+ WRITE(OUTNUM, 3000) ' DIAG :', ( DIAG0(I), I = 1, NSHAPE )
+ WRITE(OUTNUM, 2000) 'NMAT :', NMAT
+ WRITE(OUTNUM, 2000) ' M :', ( M0(I), I = 1, NMAT )
+ WRITE(OUTNUM, 2000) ' N :', ( N0(I), I = 1, NMAT )
+ WRITE(OUTNUM, 2000) ' LDAS :', ( LDAS0(I), I = 1, NMAT )
+ WRITE(OUTNUM, 2000) ' LDAD :', ( LDAD0(I), I = 1, NMAT )
+ WRITE(OUTNUM, 2000) 'NSRC :', NSRC
+ WRITE(OUTNUM, 2000) ' RSRC :',( RSRC0(I), I = 1, NSRC )
+ WRITE(OUTNUM, 2000) ' CSRC :',( CSRC0(I), I = 1, NSRC )
+ WRITE(OUTNUM, 2000) 'NGRIDS:', NGRID
+ WRITE(OUTNUM, 2000) ' P :', ( P0(I), I = 1, NGRID )
+ WRITE(OUTNUM, 2000) ' Q :', ( Q0(I), I = 1, NGRID )
+ WRITE(OUTNUM, 2000) 'VERB :', VERB
+ WRITE(OUTNUM,*) ' '
+ END IF
+ IF( VERB .GT. 1 ) THEN
+ WRITE(OUTNUM,5000)
+ WRITE(OUTNUM,6000)
+ END IF
+ END IF
+*
+* Find biggest matrix, so we know where to stick error info
+*
+ I = 0
+ DO 10 IMA = 1, NMAT
+ K = N0(IMA) * MAX0( LDAS0(IMA), LDAD0(IMA) ) + 4 * M0(IMA)
+ IF( K .GT. I ) I = K
+ 10 CONTINUE
+ MAXERR = ( ISIZE * (MEMLEN-I) ) / ( ISIZE*2 + ISIZE*6 )
+ IF( MAXERR .LT. 1 ) THEN
+ WRITE(OUTNUM,*) 'ERROR: Not enough memory to run BSBR tests.'
+ CALL BLACS_ABORT(-1, 1)
+ END IF
+ ERRDPTR = I + 1
+ ERRIPTR = ERRDPTR + MAXERR
+ NERR = 0
+ TESTNUM = 0
+ NFAIL = 0
+ NSKIP = 0
+*
+* Loop over grids of matrix
+*
+ DO 110 IGR = 1, NGRID
+*
+ CONTEXT = CONTEXT0(IGR)
+ CALL BLACS_GRIDINFO( CONTEXT, NPROW, NPCOL, MYROW, MYCOL )
+*
+ INGRID = ( NPROW .GT. 0 )
+*
+ DO 100 ISC = 1, NSCOPE
+ SCOPE = SCOPE0(ISC)
+ DO 90 ITO = 1, NTOP
+ TOP = TOP0(ITO)
+*
+* If testing multipath ('M') or general tree ('T'),
+* need to loop over calls to BLACS_SET
+*
+ IF( LSAME(TOP, 'M') ) THEN
+ SETWHAT = 11
+ IF( SCOPE .EQ. 'R' ) THEN
+ ISTART = -(NPCOL - 1)
+ ISTOP = -ISTART
+ ELSE IF (SCOPE .EQ. 'C') THEN
+ ISTART = -(NPROW - 1)
+ ISTOP = -ISTART
+ ELSE
+ ISTART = -(NPROW*NPCOL - 1)
+ ISTOP = -ISTART
+ ENDIF
+ ELSE IF( LSAME(TOP, 'T') ) THEN
+ SETWHAT = 12
+ ISTART = 1
+ IF( SCOPE .EQ. 'R' ) THEN
+ ISTOP = NPCOL - 1
+ ELSE IF (SCOPE .EQ. 'C') THEN
+ ISTOP = NPROW - 1
+ ELSE
+ ISTOP = NPROW*NPCOL - 1
+ ENDIF
+ ELSE
+ SETWHAT = 0
+ ISTART = 1
+ ISTOP = 1
+ ENDIF
+ DO 80 ISH = 1, NSHAPE
+ UPLO = UPLO0(ISH)
+ DIAG = DIAG0(ISH)
+*
+ DO 70 IMA = 1, NMAT
+ M = M0(IMA)
+ N = N0(IMA)
+ LDASRC = LDAS0(IMA)
+ LDADST = LDAD0(IMA)
+*
+ DO 60 ISO = 1, NSRC
+ TESTNUM = TESTNUM + 1
+ RSRC = RSRC0(ISO)
+ CSRC = CSRC0(ISO)
+ IF( RSRC.GE.P0(IGR) .OR. CSRC.GE.Q0(IGR) ) THEN
+ NSKIP = NSKIP + 1
+ GOTO 60
+ END IF
+ IF( VERB .GT. 1 ) THEN
+ IF( IAM .EQ. 0 ) THEN
+ WRITE(OUTNUM, 7000)
+ $ TESTNUM, 'RUNNING',SCOPE, TOP, UPLO, DIAG,
+ $ M, N, LDASRC, LDADST, RSRC, CSRC,
+ $ NPROW, NPCOL
+ END IF
+ END IF
+*
+ TESTOK = .TRUE.
+ IPRE = 2 * M
+ IPOST = IPRE
+ APTR = IPRE + 1
+*
+* If I am in scope
+*
+ IF( (MYROW.EQ.RSRC .AND. SCOPE.EQ.'R') .OR.
+ $ (MYCOL.EQ.CSRC .AND. SCOPE.EQ.'C') .OR.
+ $ (SCOPE .EQ. 'A') ) THEN
+*
+* source process generates matrix and sends it
+*
+ IF( MYROW.EQ.RSRC .AND. MYCOL.EQ.CSRC ) THEN
+ CALL IINITMAT(UPLO, DIAG, M, N, MEM,
+ $ LDASRC, IPRE, IPOST,
+ $ SCHECKVAL, TESTNUM,
+ $ MYROW, MYCOL )
+*
+ DO 20 J = ISTART, ISTOP
+ IF( J.EQ.0 ) GOTO 20
+ IF( SETWHAT.NE.0 )
+ $ CALL BLACS_SET(CONTEXT, SETWHAT, J)
+ IF( UPLO.EQ.'U' .OR. UPLO.EQ.'L' ) THEN
+ CALL ITRBS2D(CONTEXT, SCOPE, TOP,
+ $ UPLO, DIAG, M, N,
+ $ MEM(APTR), LDASRC )
+ ELSE
+ CALL IGEBS2D(CONTEXT, SCOPE, TOP,
+ $ M, N, MEM(APTR),
+ $ LDASRC )
+ END IF
+ 20 CONTINUE
+*
+* Destination processes
+*
+ ELSE IF( INGRID ) THEN
+ DO 40 J = ISTART, ISTOP
+ IF( J.EQ.0 ) GOTO 40
+ IF( SETWHAT.NE.0 )
+ $ CALL BLACS_SET(CONTEXT, SETWHAT, J)
+*
+* Pad entire matrix area
+*
+ DO 30 K = 1, IPRE+IPOST+LDADST*N
+ MEM(K) = RCHECKVAL
+ 30 CONTINUE
+*
+* Receive matrix
+*
+ IF( UPLO.EQ.'U' .OR. UPLO.EQ.'L' ) THEN
+ CALL ITRBR2D(CONTEXT, SCOPE, TOP,
+ $ UPLO, DIAG, M, N,
+ $ MEM(APTR), LDADST,
+ $ RSRC, CSRC)
+ ELSE
+ CALL IGEBR2D(CONTEXT, SCOPE, TOP,
+ $ M, N, MEM(APTR),
+ $ LDADST, RSRC, CSRC)
+ END IF
+*
+* Check for errors in matrix or padding
+*
+ I = NERR
+ CALL ICHKMAT(UPLO, DIAG, M, N,
+ $ MEM(APTR), LDADST, RSRC, CSRC,
+ $ MYROW, MYCOL, TESTNUM, MAXERR,
+ $ NERR, MEM(ERRIPTR),
+ $ MEM(ERRDPTR))
+*
+ CALL ICHKPAD(UPLO, DIAG, M, N, MEM,
+ $ LDADST, RSRC, CSRC, MYROW,
+ $ MYCOL, IPRE, IPOST, RCHECKVAL,
+ $ TESTNUM, MAXERR, NERR,
+ $ MEM(ERRIPTR), MEM(ERRDPTR))
+ 40 CONTINUE
+ TESTOK = ( I .EQ. NERR )
+ END IF
+ END IF
+*
+ IF( VERB .GT. 1 ) THEN
+ I = NERR
+ CALL IBTCHECKIN(0, OUTNUM, MAXERR, NERR,
+ $ MEM(ERRIPTR), MEM(ERRDPTR),
+ $ TFAIL)
+ IF( IAM .EQ. 0 ) THEN
+ TESTOK = ( TESTOK .AND. (I.EQ.NERR) )
+ IF( TESTOK ) THEN
+ WRITE(OUTNUM,7000)TESTNUM,'PASSED ',
+ $ SCOPE, TOP, UPLO, DIAG, M, N,
+ $ LDASRC, LDADST, RSRC, CSRC,
+ $ NPROW, NPCOL
+ ELSE
+ NFAIL = NFAIL + 1
+ WRITE(OUTNUM,7000)TESTNUM,'FAILED ',
+ $ SCOPE, TOP, UPLO, DIAG, M, N,
+ $ LDASRC, LDADST, RSRC, CSRC,
+ $ NPROW, NPCOL
+ END IF
+ END IF
+*
+* Once we've printed out errors, can re-use buf space
+*
+ NERR = 0
+ END IF
+ 60 CONTINUE
+ 70 CONTINUE
+ 80 CONTINUE
+ 90 CONTINUE
+ 100 CONTINUE
+ 110 CONTINUE
+*
+ IF( VERB .LT. 2 ) THEN
+ NFAIL = TESTNUM
+ CALL IBTCHECKIN( NFAIL, OUTNUM, MAXERR, NERR, MEM(ERRIPTR),
+ $ MEM(ERRDPTR), TFAIL )
+ END IF
+ IF( IAM .EQ. 0 ) THEN
+ IF( VERB .GT. 1 ) WRITE(OUTNUM,*) ' '
+ IF( NFAIL+NSKIP .EQ. 0 ) THEN
+ WRITE(OUTNUM, 8000 ) TESTNUM
+ ELSE
+ WRITE(OUTNUM, 9000 ) TESTNUM, TESTNUM-NSKIP-NFAIL,
+ $ NSKIP, NFAIL
+ END IF
+ END IF
+*
+* Log whether their were any failures
+*
+ TESTOK = ALLPASS( (NFAIL.EQ.0) )
+*
+ 1000 FORMAT('INTEGER BSBR TESTS: BEGIN.' )
+ 2000 FORMAT(1X,A7,3X,10I6)
+ 3000 FORMAT(1X,A7,3X,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1,
+ $ 5X,A1,5X,A1)
+ 5000 FORMAT(' TEST# STATUS SCOPE TOP UPLO DIAG M N LDAS ',
+ $ ' LDAD RSRC CSRC P Q')
+ 6000 FORMAT(' ----- ------- ----- --- ---- ---- ----- ----- ----- ',
+ $ '----- ---- ---- ---- ----')
+ 7000 FORMAT(I6,1X,A7,5X,A1,3X,A1,2(4X,A1), 4I6, 4I5)
+ 8000 FORMAT('INTEGER BSBR TESTS: PASSED ALL',
+ $ I5, ' TESTS.')
+ 9000 FORMAT('INTEGER BSBR TESTS:',I5,' TESTS;',I5,' PASSED,',
+ $ I5,' SKIPPED,',I5,' FAILED.')
+*
+ RETURN
+*
+* End of IBSBRTEST.
+*
+ END
+*
+*
+ SUBROUTINE SBSBRTEST( OUTNUM, VERB, NSCOPE, SCOPE0, NTOP, TOP0,
+ $ NSHAPE, UPLO0, DIAG0, NMAT, M0, N0, LDAS0,
+ $ LDAD0, NSRC, RSRC0, CSRC0, NGRID, CONTEXT0,
+ $ P0, Q0, TFAIL, MEM, MEMLEN )
+*
+* -- BLACS tester (version 1.0) --
+* University of Tennessee
+* December 15, 1994
+*
+*
+* .. Scalar Arguments ..
+ INTEGER OUTNUM, VERB, NSCOPE, NTOP, NSHAPE, NMAT, NSRC, NGRID
+ INTEGER MEMLEN
+* ..
+* .. Array Arguments ..
+ CHARACTER*1 SCOPE0(NSCOPE), TOP0(NTOP)
+ CHARACTER*1 UPLO0(NSHAPE), DIAG0(NSHAPE)
+ INTEGER M0(NMAT), N0(NMAT), LDAS0(NMAT), LDAD0(NMAT)
+ INTEGER RSRC0(NSRC), CSRC0(NSRC), CONTEXT0(NGRID)
+ INTEGER P0(NGRID), Q0(NGRID), TFAIL(*)
+ REAL MEM(MEMLEN)
+* ..
+*
+* Purpose
+* =======
+* STESTBSBR: Test real broadcast
+*
+* Arguments
+* =========
+* OUTNUM (input) INTEGER
+* The device number to write output to.
+*
+* VERB (input) INTEGER
+* The level of verbosity (how much printing to do).
+*
+* NSCOPE (input) INTEGER
+* The number of scopes to be tested.
+*
+* SCOPE0 (input) CHARACTER*1 array of dimension (NSCOPE)
+* Values of the scopes to be tested.
+*
+* NTOP (input) INTEGER
+* The number of topologies to be tested.
+*
+* TOP0 (input) CHARACTER*1 array of dimension (NTOP)
+* Values of the topologies to be tested.
+*
+* NSHAPE (input) INTEGER
+* The number of matrix shapes to be tested.
+*
+* UPLO0 (input) CHARACTER*1 array of dimension (NSHAPE)
+* Values of UPLO to be tested.
+*
+* DIAG0 (input) CHARACTER*1 array of dimension (NSHAPE)
+* Values of DIAG to be tested.
+*
+* NMAT (input) INTEGER
+* The number of matrices to be tested.
+*
+* M0 (input) INTEGER array of dimension (NMAT)
+* Values of M to be tested.
+*
+* M0 (input) INTEGER array of dimension (NMAT)
+* Values of M to be tested.
+*
+* N0 (input) INTEGER array of dimension (NMAT)
+* Values of N to be tested.
+*
+* LDAS0 (input) INTEGER array of dimension (NMAT)
+* Values of LDAS (leading dimension of A on source process)
+* to be tested.
+*
+* LDAD0 (input) INTEGER array of dimension (NMAT)
+* Values of LDAD (leading dimension of A on destination
+* process) to be tested.
+* NSRC (input) INTEGER
+* The number of sources to be tested.
+*
+* RSRC0 (input) INTEGER array of dimension (NDEST)
+* Values of RSRC (row coordinate of source) to be tested.
+*
+* CSRC0 (input) INTEGER array of dimension (NDEST)
+* Values of CSRC (column coordinate of source) to be tested.
+*
+* NGRID (input) INTEGER
+* The number of process grids to be tested.
+*
+* CONTEXT0 (input) INTEGER array of dimension (NGRID)
+* The BLACS context handles corresponding to the grids.
+*
+* P0 (input) INTEGER array of dimension (NGRID)
+* Values of P (number of process rows, NPROW).
+*
+* Q0 (input) INTEGER array of dimension (NGRID)
+* Values of Q (number of process columns, NPCOL).
+*
+* TFAIL (workspace) INTEGER array of dimension (NTESTS)
+* If VERB < 2, serves to indicate which tests fail. This
+* requires workspace of NTESTS (number of tests performed).
+*
+* MEM (workspace) REAL array of dimension (MEMLEN)
+* Used for all other workspaces, including the matrix A,
+* and its pre and post padding.
+*
+* MEMLEN (input) INTEGER
+* The length, in elements, of MEM.
+*
+* =====================================================================
+*
+* .. External Functions ..
+ LOGICAL ALLPASS, LSAME
+ INTEGER IBTMYPROC, IBTSIZEOF
+ EXTERNAL ALLPASS, LSAME, IBTMYPROC, IBTSIZEOF
+* ..
+* .. External Subroutines ..
+ EXTERNAL BLACS_GRIDINFO
+ EXTERNAL STRBS2D, SGEBS2D, STRBR2D, SGEBR2D
+ EXTERNAL SINITMAT, SCHKMAT, SCHKPAD, SBTCHECKIN
+* ..
+* .. Local Scalars ..
+ CHARACTER*1 SCOPE, TOP, UPLO, DIAG
+ LOGICAL TESTOK, INGRID
+ INTEGER IAM, I, K, J, IGR, ISH, IMA, ISO, ISC, ITO
+ INTEGER M, N, NPROW, NPCOL, MYROW, MYCOL, RSRC, CSRC
+ INTEGER ISTART, ISTOP, IPRE, IPOST, SETWHAT
+ INTEGER NERR, NSKIP, NFAIL, TESTNUM, CONTEXT, MAXERR, LDASRC
+ INTEGER LDADST, ERRDPTR, APTR, ERRIPTR, ISIZE, SSIZE
+ REAL SCHECKVAL, RCHECKVAL
+* ..
+* .. Executable Statements ..
+*
+ SCHECKVAL = -0.01E0
+ RCHECKVAL = -0.02E0
+*
+ IAM = IBTMYPROC()
+ ISIZE = IBTSIZEOF('I')
+ SSIZE = IBTSIZEOF('S')
+*
+* Verify file parameters
+*
+ IF( IAM .EQ. 0 ) THEN
+ WRITE(OUTNUM, *) ' '
+ WRITE(OUTNUM, *) ' '
+ WRITE(OUTNUM, 1000 )
+ IF( VERB .GT. 0 ) THEN
+ WRITE(OUTNUM,*) ' '
+ WRITE(OUTNUM, 2000) 'NSCOPE:', NSCOPE
+ WRITE(OUTNUM, 3000) ' SCOPE:', ( SCOPE0(I), I = 1, NSCOPE )
+ WRITE(OUTNUM, 2000) 'NTOP :', NTOP
+ WRITE(OUTNUM, 3000) ' TOP :', ( TOP0(I), I = 1, NTOP )
+ WRITE(OUTNUM, 2000) 'NSHAPE:', NSHAPE
+ WRITE(OUTNUM, 3000) ' UPLO :', ( UPLO0(I), I = 1, NSHAPE )
+ WRITE(OUTNUM, 3000) ' DIAG :', ( DIAG0(I), I = 1, NSHAPE )
+ WRITE(OUTNUM, 2000) 'NMAT :', NMAT
+ WRITE(OUTNUM, 2000) ' M :', ( M0(I), I = 1, NMAT )
+ WRITE(OUTNUM, 2000) ' N :', ( N0(I), I = 1, NMAT )
+ WRITE(OUTNUM, 2000) ' LDAS :', ( LDAS0(I), I = 1, NMAT )
+ WRITE(OUTNUM, 2000) ' LDAD :', ( LDAD0(I), I = 1, NMAT )
+ WRITE(OUTNUM, 2000) 'NSRC :', NSRC
+ WRITE(OUTNUM, 2000) ' RSRC :',( RSRC0(I), I = 1, NSRC )
+ WRITE(OUTNUM, 2000) ' CSRC :',( CSRC0(I), I = 1, NSRC )
+ WRITE(OUTNUM, 2000) 'NGRIDS:', NGRID
+ WRITE(OUTNUM, 2000) ' P :', ( P0(I), I = 1, NGRID )
+ WRITE(OUTNUM, 2000) ' Q :', ( Q0(I), I = 1, NGRID )
+ WRITE(OUTNUM, 2000) 'VERB :', VERB
+ WRITE(OUTNUM,*) ' '
+ END IF
+ IF( VERB .GT. 1 ) THEN
+ WRITE(OUTNUM,5000)
+ WRITE(OUTNUM,6000)
+ END IF
+ END IF
+*
+* Find biggest matrix, so we know where to stick error info
+*
+ I = 0
+ DO 10 IMA = 1, NMAT
+ K = N0(IMA) * MAX0( LDAS0(IMA), LDAD0(IMA) ) + 4 * M0(IMA)
+ IF( K .GT. I ) I = K
+ 10 CONTINUE
+ MAXERR = ( SSIZE * (MEMLEN-I) ) / ( SSIZE*2 + ISIZE*6 )
+ IF( MAXERR .LT. 1 ) THEN
+ WRITE(OUTNUM,*) 'ERROR: Not enough memory to run BSBR tests.'
+ CALL BLACS_ABORT(-1, 1)
+ END IF
+ ERRDPTR = I + 1
+ ERRIPTR = ERRDPTR + MAXERR
+ NERR = 0
+ TESTNUM = 0
+ NFAIL = 0
+ NSKIP = 0
+*
+* Loop over grids of matrix
+*
+ DO 110 IGR = 1, NGRID
+*
+ CONTEXT = CONTEXT0(IGR)
+ CALL BLACS_GRIDINFO( CONTEXT, NPROW, NPCOL, MYROW, MYCOL )
+*
+ INGRID = ( NPROW .GT. 0 )
+*
+ DO 100 ISC = 1, NSCOPE
+ SCOPE = SCOPE0(ISC)
+ DO 90 ITO = 1, NTOP
+ TOP = TOP0(ITO)
+*
+* If testing multipath ('M') or general tree ('T'),
+* need to loop over calls to BLACS_SET
+*
+ IF( LSAME(TOP, 'M') ) THEN
+ SETWHAT = 11
+ IF( SCOPE .EQ. 'R' ) THEN
+ ISTART = -(NPCOL - 1)
+ ISTOP = -ISTART
+ ELSE IF (SCOPE .EQ. 'C') THEN
+ ISTART = -(NPROW - 1)
+ ISTOP = -ISTART
+ ELSE
+ ISTART = -(NPROW*NPCOL - 1)
+ ISTOP = -ISTART
+ ENDIF
+ ELSE IF( LSAME(TOP, 'T') ) THEN
+ SETWHAT = 12
+ ISTART = 1
+ IF( SCOPE .EQ. 'R' ) THEN
+ ISTOP = NPCOL - 1
+ ELSE IF (SCOPE .EQ. 'C') THEN
+ ISTOP = NPROW - 1
+ ELSE
+ ISTOP = NPROW*NPCOL - 1
+ ENDIF
+ ELSE
+ SETWHAT = 0
+ ISTART = 1
+ ISTOP = 1
+ ENDIF
+ DO 80 ISH = 1, NSHAPE
+ UPLO = UPLO0(ISH)
+ DIAG = DIAG0(ISH)
+*
+ DO 70 IMA = 1, NMAT
+ M = M0(IMA)
+ N = N0(IMA)
+ LDASRC = LDAS0(IMA)
+ LDADST = LDAD0(IMA)
+*
+ DO 60 ISO = 1, NSRC
+ TESTNUM = TESTNUM + 1
+ RSRC = RSRC0(ISO)
+ CSRC = CSRC0(ISO)
+ IF( RSRC.GE.P0(IGR) .OR. CSRC.GE.Q0(IGR) ) THEN
+ NSKIP = NSKIP + 1
+ GOTO 60
+ END IF
+ IF( VERB .GT. 1 ) THEN
+ IF( IAM .EQ. 0 ) THEN
+ WRITE(OUTNUM, 7000)
+ $ TESTNUM, 'RUNNING',SCOPE, TOP, UPLO, DIAG,
+ $ M, N, LDASRC, LDADST, RSRC, CSRC,
+ $ NPROW, NPCOL
+ END IF
+ END IF
+*
+ TESTOK = .TRUE.
+ IPRE = 2 * M
+ IPOST = IPRE
+ APTR = IPRE + 1
+*
+* If I am in scope
+*
+ IF( (MYROW.EQ.RSRC .AND. SCOPE.EQ.'R') .OR.
+ $ (MYCOL.EQ.CSRC .AND. SCOPE.EQ.'C') .OR.
+ $ (SCOPE .EQ. 'A') ) THEN
+*
+* source process generates matrix and sends it
+*
+ IF( MYROW.EQ.RSRC .AND. MYCOL.EQ.CSRC ) THEN
+ CALL SINITMAT(UPLO, DIAG, M, N, MEM,
+ $ LDASRC, IPRE, IPOST,
+ $ SCHECKVAL, TESTNUM,
+ $ MYROW, MYCOL )
+*
+ DO 20 J = ISTART, ISTOP
+ IF( J.EQ.0 ) GOTO 20
+ IF( SETWHAT.NE.0 )
+ $ CALL BLACS_SET(CONTEXT, SETWHAT, J)
+ IF( UPLO.EQ.'U' .OR. UPLO.EQ.'L' ) THEN
+ CALL STRBS2D(CONTEXT, SCOPE, TOP,
+ $ UPLO, DIAG, M, N,
+ $ MEM(APTR), LDASRC )
+ ELSE
+ CALL SGEBS2D(CONTEXT, SCOPE, TOP,
+ $ M, N, MEM(APTR),
+ $ LDASRC )
+ END IF
+ 20 CONTINUE
+*
+* Destination processes
+*
+ ELSE IF( INGRID ) THEN
+ DO 40 J = ISTART, ISTOP
+ IF( J.EQ.0 ) GOTO 40
+ IF( SETWHAT.NE.0 )
+ $ CALL BLACS_SET(CONTEXT, SETWHAT, J)
+*
+* Pad entire matrix area
+*
+ DO 30 K = 1, IPRE+IPOST+LDADST*N
+ MEM(K) = RCHECKVAL
+ 30 CONTINUE
+*
+* Receive matrix
+*
+ IF( UPLO.EQ.'U' .OR. UPLO.EQ.'L' ) THEN
+ CALL STRBR2D(CONTEXT, SCOPE, TOP,
+ $ UPLO, DIAG, M, N,
+ $ MEM(APTR), LDADST,
+ $ RSRC, CSRC)
+ ELSE
+ CALL SGEBR2D(CONTEXT, SCOPE, TOP,
+ $ M, N, MEM(APTR),
+ $ LDADST, RSRC, CSRC)
+ END IF
+*
+* Check for errors in matrix or padding
+*
+ I = NERR
+ CALL SCHKMAT(UPLO, DIAG, M, N,
+ $ MEM(APTR), LDADST, RSRC, CSRC,
+ $ MYROW, MYCOL, TESTNUM, MAXERR,
+ $ NERR, MEM(ERRIPTR),
+ $ MEM(ERRDPTR))
+*
+ CALL SCHKPAD(UPLO, DIAG, M, N, MEM,
+ $ LDADST, RSRC, CSRC, MYROW,
+ $ MYCOL, IPRE, IPOST, RCHECKVAL,
+ $ TESTNUM, MAXERR, NERR,
+ $ MEM(ERRIPTR), MEM(ERRDPTR))
+ 40 CONTINUE
+ TESTOK = ( I .EQ. NERR )
+ END IF
+ END IF
+*
+ IF( VERB .GT. 1 ) THEN
+ I = NERR
+ CALL SBTCHECKIN(0, OUTNUM, MAXERR, NERR,
+ $ MEM(ERRIPTR), MEM(ERRDPTR),
+ $ TFAIL)
+ IF( IAM .EQ. 0 ) THEN
+ TESTOK = ( TESTOK .AND. (I.EQ.NERR) )
+ IF( TESTOK ) THEN
+ WRITE(OUTNUM,7000)TESTNUM,'PASSED ',
+ $ SCOPE, TOP, UPLO, DIAG, M, N,
+ $ LDASRC, LDADST, RSRC, CSRC,
+ $ NPROW, NPCOL
+ ELSE
+ NFAIL = NFAIL + 1
+ WRITE(OUTNUM,7000)TESTNUM,'FAILED ',
+ $ SCOPE, TOP, UPLO, DIAG, M, N,
+ $ LDASRC, LDADST, RSRC, CSRC,
+ $ NPROW, NPCOL
+ END IF
+ END IF
+*
+* Once we've printed out errors, can re-use buf space
+*
+ NERR = 0
+ END IF
+ 60 CONTINUE
+ 70 CONTINUE
+ 80 CONTINUE
+ 90 CONTINUE
+ 100 CONTINUE
+ 110 CONTINUE
+*
+ IF( VERB .LT. 2 ) THEN
+ NFAIL = TESTNUM
+ CALL SBTCHECKIN( NFAIL, OUTNUM, MAXERR, NERR, MEM(ERRIPTR),
+ $ MEM(ERRDPTR), TFAIL )
+ END IF
+ IF( IAM .EQ. 0 ) THEN
+ IF( VERB .GT. 1 ) WRITE(OUTNUM,*) ' '
+ IF( NFAIL+NSKIP .EQ. 0 ) THEN
+ WRITE(OUTNUM, 8000 ) TESTNUM
+ ELSE
+ WRITE(OUTNUM, 9000 ) TESTNUM, TESTNUM-NSKIP-NFAIL,
+ $ NSKIP, NFAIL
+ END IF
+ END IF
+*
+* Log whether their were any failures
+*
+ TESTOK = ALLPASS( (NFAIL.EQ.0) )
+*
+ 1000 FORMAT('REAL BSBR TESTS: BEGIN.' )
+ 2000 FORMAT(1X,A7,3X,10I6)
+ 3000 FORMAT(1X,A7,3X,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1,
+ $ 5X,A1,5X,A1)
+ 5000 FORMAT(' TEST# STATUS SCOPE TOP UPLO DIAG M N LDAS ',
+ $ ' LDAD RSRC CSRC P Q')
+ 6000 FORMAT(' ----- ------- ----- --- ---- ---- ----- ----- ----- ',
+ $ '----- ---- ---- ---- ----')
+ 7000 FORMAT(I6,1X,A7,5X,A1,3X,A1,2(4X,A1), 4I6, 4I5)
+ 8000 FORMAT('REAL BSBR TESTS: PASSED ALL',
+ $ I5, ' TESTS.')
+ 9000 FORMAT('REAL BSBR TESTS:',I5,' TESTS;',I5,' PASSED,',
+ $ I5,' SKIPPED,',I5,' FAILED.')
+*
+ RETURN
+*
+* End of SBSBRTEST.
+*
+ END
+*
+*
+ SUBROUTINE DBSBRTEST( OUTNUM, VERB, NSCOPE, SCOPE0, NTOP, TOP0,
+ $ NSHAPE, UPLO0, DIAG0, NMAT, M0, N0, LDAS0,
+ $ LDAD0, NSRC, RSRC0, CSRC0, NGRID, CONTEXT0,
+ $ P0, Q0, TFAIL, MEM, MEMLEN )
+*
+* -- BLACS tester (version 1.0) --
+* University of Tennessee
+* December 15, 1994
+*
+*
+* .. Scalar Arguments ..
+ INTEGER OUTNUM, VERB, NSCOPE, NTOP, NSHAPE, NMAT, NSRC, NGRID
+ INTEGER MEMLEN
+* ..
+* .. Array Arguments ..
+ CHARACTER*1 SCOPE0(NSCOPE), TOP0(NTOP)
+ CHARACTER*1 UPLO0(NSHAPE), DIAG0(NSHAPE)
+ INTEGER M0(NMAT), N0(NMAT), LDAS0(NMAT), LDAD0(NMAT)
+ INTEGER RSRC0(NSRC), CSRC0(NSRC), CONTEXT0(NGRID)
+ INTEGER P0(NGRID), Q0(NGRID), TFAIL(*)
+ DOUBLE PRECISION MEM(MEMLEN)
+* ..
+*
+* Purpose
+* =======
+* DTESTBSBR: Test double precision broadcast
+*
+* Arguments
+* =========
+* OUTNUM (input) INTEGER
+* The device number to write output to.
+*
+* VERB (input) INTEGER
+* The level of verbosity (how much printing to do).
+*
+* NSCOPE (input) INTEGER
+* The number of scopes to be tested.
+*
+* SCOPE0 (input) CHARACTER*1 array of dimension (NSCOPE)
+* Values of the scopes to be tested.
+*
+* NTOP (input) INTEGER
+* The number of topologies to be tested.
+*
+* TOP0 (input) CHARACTER*1 array of dimension (NTOP)
+* Values of the topologies to be tested.
+*
+* NSHAPE (input) INTEGER
+* The number of matrix shapes to be tested.
+*
+* UPLO0 (input) CHARACTER*1 array of dimension (NSHAPE)
+* Values of UPLO to be tested.
+*
+* DIAG0 (input) CHARACTER*1 array of dimension (NSHAPE)
+* Values of DIAG to be tested.
+*
+* NMAT (input) INTEGER
+* The number of matrices to be tested.
+*
+* M0 (input) INTEGER array of dimension (NMAT)
+* Values of M to be tested.
+*
+* M0 (input) INTEGER array of dimension (NMAT)
+* Values of M to be tested.
+*
+* N0 (input) INTEGER array of dimension (NMAT)
+* Values of N to be tested.
+*
+* LDAS0 (input) INTEGER array of dimension (NMAT)
+* Values of LDAS (leading dimension of A on source process)
+* to be tested.
+*
+* LDAD0 (input) INTEGER array of dimension (NMAT)
+* Values of LDAD (leading dimension of A on destination
+* process) to be tested.
+* NSRC (input) INTEGER
+* The number of sources to be tested.
+*
+* RSRC0 (input) INTEGER array of dimension (NDEST)
+* Values of RSRC (row coordinate of source) to be tested.
+*
+* CSRC0 (input) INTEGER array of dimension (NDEST)
+* Values of CSRC (column coordinate of source) to be tested.
+*
+* NGRID (input) INTEGER
+* The number of process grids to be tested.
+*
+* CONTEXT0 (input) INTEGER array of dimension (NGRID)
+* The BLACS context handles corresponding to the grids.
+*
+* P0 (input) INTEGER array of dimension (NGRID)
+* Values of P (number of process rows, NPROW).
+*
+* Q0 (input) INTEGER array of dimension (NGRID)
+* Values of Q (number of process columns, NPCOL).
+*
+* TFAIL (workspace) INTEGER array of dimension (NTESTS)
+* If VERB < 2, serves to indicate which tests fail. This
+* requires workspace of NTESTS (number of tests performed).
+*
+* MEM (workspace) DOUBLE PRECISION array of dimension (MEMLEN)
+* Used for all other workspaces, including the matrix A,
+* and its pre and post padding.
+*
+* MEMLEN (input) INTEGER
+* The length, in elements, of MEM.
+*
+* =====================================================================
+*
+* .. External Functions ..
+ LOGICAL ALLPASS, LSAME
+ INTEGER IBTMYPROC, IBTSIZEOF
+ EXTERNAL ALLPASS, LSAME, IBTMYPROC, IBTSIZEOF
+* ..
+* .. External Subroutines ..
+ EXTERNAL BLACS_GRIDINFO
+ EXTERNAL DTRBS2D, DGEBS2D, DTRBR2D, DGEBR2D
+ EXTERNAL DINITMAT, DCHKMAT, DCHKPAD, DBTCHECKIN
+* ..
+* .. Local Scalars ..
+ CHARACTER*1 SCOPE, TOP, UPLO, DIAG
+ LOGICAL TESTOK, INGRID
+ INTEGER IAM, I, K, J, IGR, ISH, IMA, ISO, ISC, ITO
+ INTEGER M, N, NPROW, NPCOL, MYROW, MYCOL, RSRC, CSRC
+ INTEGER ISTART, ISTOP, IPRE, IPOST, SETWHAT
+ INTEGER NERR, NSKIP, NFAIL, TESTNUM, CONTEXT, MAXERR, LDASRC
+ INTEGER LDADST, ERRDPTR, APTR, ERRIPTR, ISIZE, DSIZE
+ DOUBLE PRECISION SCHECKVAL, RCHECKVAL
+* ..
+* .. Executable Statements ..
+*
+ SCHECKVAL = -0.01D0
+ RCHECKVAL = -0.02D0
+*
+ IAM = IBTMYPROC()
+ ISIZE = IBTSIZEOF('I')
+ DSIZE = IBTSIZEOF('D')
+*
+* Verify file parameters
+*
+ IF( IAM .EQ. 0 ) THEN
+ WRITE(OUTNUM, *) ' '
+ WRITE(OUTNUM, *) ' '
+ WRITE(OUTNUM, 1000 )
+ IF( VERB .GT. 0 ) THEN
+ WRITE(OUTNUM,*) ' '
+ WRITE(OUTNUM, 2000) 'NSCOPE:', NSCOPE
+ WRITE(OUTNUM, 3000) ' SCOPE:', ( SCOPE0(I), I = 1, NSCOPE )
+ WRITE(OUTNUM, 2000) 'NTOP :', NTOP
+ WRITE(OUTNUM, 3000) ' TOP :', ( TOP0(I), I = 1, NTOP )
+ WRITE(OUTNUM, 2000) 'NSHAPE:', NSHAPE
+ WRITE(OUTNUM, 3000) ' UPLO :', ( UPLO0(I), I = 1, NSHAPE )
+ WRITE(OUTNUM, 3000) ' DIAG :', ( DIAG0(I), I = 1, NSHAPE )
+ WRITE(OUTNUM, 2000) 'NMAT :', NMAT
+ WRITE(OUTNUM, 2000) ' M :', ( M0(I), I = 1, NMAT )
+ WRITE(OUTNUM, 2000) ' N :', ( N0(I), I = 1, NMAT )
+ WRITE(OUTNUM, 2000) ' LDAS :', ( LDAS0(I), I = 1, NMAT )
+ WRITE(OUTNUM, 2000) ' LDAD :', ( LDAD0(I), I = 1, NMAT )
+ WRITE(OUTNUM, 2000) 'NSRC :', NSRC
+ WRITE(OUTNUM, 2000) ' RSRC :',( RSRC0(I), I = 1, NSRC )
+ WRITE(OUTNUM, 2000) ' CSRC :',( CSRC0(I), I = 1, NSRC )
+ WRITE(OUTNUM, 2000) 'NGRIDS:', NGRID
+ WRITE(OUTNUM, 2000) ' P :', ( P0(I), I = 1, NGRID )
+ WRITE(OUTNUM, 2000) ' Q :', ( Q0(I), I = 1, NGRID )
+ WRITE(OUTNUM, 2000) 'VERB :', VERB
+ WRITE(OUTNUM,*) ' '
+ END IF
+ IF( VERB .GT. 1 ) THEN
+ WRITE(OUTNUM,5000)
+ WRITE(OUTNUM,6000)
+ END IF
+ END IF
+*
+* Find biggest matrix, so we know where to stick error info
+*
+ I = 0
+ DO 10 IMA = 1, NMAT
+ K = N0(IMA) * MAX0( LDAS0(IMA), LDAD0(IMA) ) + 4 * M0(IMA)
+ IF( K .GT. I ) I = K
+ 10 CONTINUE
+ MAXERR = ( DSIZE * (MEMLEN-I) ) / ( DSIZE*2 + ISIZE*6 )
+ IF( MAXERR .LT. 1 ) THEN
+ WRITE(OUTNUM,*) 'ERROR: Not enough memory to run BSBR tests.'
+ CALL BLACS_ABORT(-1, 1)
+ END IF
+ ERRDPTR = I + 1
+ ERRIPTR = ERRDPTR + MAXERR
+ NERR = 0
+ TESTNUM = 0
+ NFAIL = 0
+ NSKIP = 0
+*
+* Loop over grids of matrix
+*
+ DO 110 IGR = 1, NGRID
+*
+ CONTEXT = CONTEXT0(IGR)
+ CALL BLACS_GRIDINFO( CONTEXT, NPROW, NPCOL, MYROW, MYCOL )
+*
+ INGRID = ( NPROW .GT. 0 )
+*
+ DO 100 ISC = 1, NSCOPE
+ SCOPE = SCOPE0(ISC)
+ DO 90 ITO = 1, NTOP
+ TOP = TOP0(ITO)
+*
+* If testing multipath ('M') or general tree ('T'),
+* need to loop over calls to BLACS_SET
+*
+ IF( LSAME(TOP, 'M') ) THEN
+ SETWHAT = 11
+ IF( SCOPE .EQ. 'R' ) THEN
+ ISTART = -(NPCOL - 1)
+ ISTOP = -ISTART
+ ELSE IF (SCOPE .EQ. 'C') THEN
+ ISTART = -(NPROW - 1)
+ ISTOP = -ISTART
+ ELSE
+ ISTART = -(NPROW*NPCOL - 1)
+ ISTOP = -ISTART
+ ENDIF
+ ELSE IF( LSAME(TOP, 'T') ) THEN
+ SETWHAT = 12
+ ISTART = 1
+ IF( SCOPE .EQ. 'R' ) THEN
+ ISTOP = NPCOL - 1
+ ELSE IF (SCOPE .EQ. 'C') THEN
+ ISTOP = NPROW - 1
+ ELSE
+ ISTOP = NPROW*NPCOL - 1
+ ENDIF
+ ELSE
+ SETWHAT = 0
+ ISTART = 1
+ ISTOP = 1
+ ENDIF
+ DO 80 ISH = 1, NSHAPE
+ UPLO = UPLO0(ISH)
+ DIAG = DIAG0(ISH)
+*
+ DO 70 IMA = 1, NMAT
+ M = M0(IMA)
+ N = N0(IMA)
+ LDASRC = LDAS0(IMA)
+ LDADST = LDAD0(IMA)
+*
+ DO 60 ISO = 1, NSRC
+ TESTNUM = TESTNUM + 1
+ RSRC = RSRC0(ISO)
+ CSRC = CSRC0(ISO)
+ IF( RSRC.GE.P0(IGR) .OR. CSRC.GE.Q0(IGR) ) THEN
+ NSKIP = NSKIP + 1
+ GOTO 60
+ END IF
+ IF( VERB .GT. 1 ) THEN
+ IF( IAM .EQ. 0 ) THEN
+ WRITE(OUTNUM, 7000)
+ $ TESTNUM, 'RUNNING',SCOPE, TOP, UPLO, DIAG,
+ $ M, N, LDASRC, LDADST, RSRC, CSRC,
+ $ NPROW, NPCOL
+ END IF
+ END IF
+*
+ TESTOK = .TRUE.
+ IPRE = 2 * M
+ IPOST = IPRE
+ APTR = IPRE + 1
+*
+* If I am in scope
+*
+ IF( (MYROW.EQ.RSRC .AND. SCOPE.EQ.'R') .OR.
+ $ (MYCOL.EQ.CSRC .AND. SCOPE.EQ.'C') .OR.
+ $ (SCOPE .EQ. 'A') ) THEN
+*
+* source process generates matrix and sends it
+*
+ IF( MYROW.EQ.RSRC .AND. MYCOL.EQ.CSRC ) THEN
+ CALL DINITMAT(UPLO, DIAG, M, N, MEM,
+ $ LDASRC, IPRE, IPOST,
+ $ SCHECKVAL, TESTNUM,
+ $ MYROW, MYCOL )
+*
+ DO 20 J = ISTART, ISTOP
+ IF( J.EQ.0 ) GOTO 20
+ IF( SETWHAT.NE.0 )
+ $ CALL BLACS_SET(CONTEXT, SETWHAT, J)
+ IF( UPLO.EQ.'U' .OR. UPLO.EQ.'L' ) THEN
+ CALL DTRBS2D(CONTEXT, SCOPE, TOP,
+ $ UPLO, DIAG, M, N,
+ $ MEM(APTR), LDASRC )
+ ELSE
+ CALL DGEBS2D(CONTEXT, SCOPE, TOP,
+ $ M, N, MEM(APTR),
+ $ LDASRC )
+ END IF
+ 20 CONTINUE
+*
+* Destination processes
+*
+ ELSE IF( INGRID ) THEN
+ DO 40 J = ISTART, ISTOP
+ IF( J.EQ.0 ) GOTO 40
+ IF( SETWHAT.NE.0 )
+ $ CALL BLACS_SET(CONTEXT, SETWHAT, J)
+*
+* Pad entire matrix area
+*
+ DO 30 K = 1, IPRE+IPOST+LDADST*N
+ MEM(K) = RCHECKVAL
+ 30 CONTINUE
+*
+* Receive matrix
+*
+ IF( UPLO.EQ.'U' .OR. UPLO.EQ.'L' ) THEN
+ CALL DTRBR2D(CONTEXT, SCOPE, TOP,
+ $ UPLO, DIAG, M, N,
+ $ MEM(APTR), LDADST,
+ $ RSRC, CSRC)
+ ELSE
+ CALL DGEBR2D(CONTEXT, SCOPE, TOP,
+ $ M, N, MEM(APTR),
+ $ LDADST, RSRC, CSRC)
+ END IF
+*
+* Check for errors in matrix or padding
+*
+ I = NERR
+ CALL DCHKMAT(UPLO, DIAG, M, N,
+ $ MEM(APTR), LDADST, RSRC, CSRC,
+ $ MYROW, MYCOL, TESTNUM, MAXERR,
+ $ NERR, MEM(ERRIPTR),
+ $ MEM(ERRDPTR))
+*
+ CALL DCHKPAD(UPLO, DIAG, M, N, MEM,
+ $ LDADST, RSRC, CSRC, MYROW,
+ $ MYCOL, IPRE, IPOST, RCHECKVAL,
+ $ TESTNUM, MAXERR, NERR,
+ $ MEM(ERRIPTR), MEM(ERRDPTR))
+ 40 CONTINUE
+ TESTOK = ( I .EQ. NERR )
+ END IF
+ END IF
+*
+ IF( VERB .GT. 1 ) THEN
+ I = NERR
+ CALL DBTCHECKIN(0, OUTNUM, MAXERR, NERR,
+ $ MEM(ERRIPTR), MEM(ERRDPTR),
+ $ TFAIL)
+ IF( IAM .EQ. 0 ) THEN
+ TESTOK = ( TESTOK .AND. (I.EQ.NERR) )
+ IF( TESTOK ) THEN
+ WRITE(OUTNUM,7000)TESTNUM,'PASSED ',
+ $ SCOPE, TOP, UPLO, DIAG, M, N,
+ $ LDASRC, LDADST, RSRC, CSRC,
+ $ NPROW, NPCOL
+ ELSE
+ NFAIL = NFAIL + 1
+ WRITE(OUTNUM,7000)TESTNUM,'FAILED ',
+ $ SCOPE, TOP, UPLO, DIAG, M, N,
+ $ LDASRC, LDADST, RSRC, CSRC,
+ $ NPROW, NPCOL
+ END IF
+ END IF
+*
+* Once we've printed out errors, can re-use buf space
+*
+ NERR = 0
+ END IF
+ 60 CONTINUE
+ 70 CONTINUE
+ 80 CONTINUE
+ 90 CONTINUE
+ 100 CONTINUE
+ 110 CONTINUE
+*
+ IF( VERB .LT. 2 ) THEN
+ NFAIL = TESTNUM
+ CALL DBTCHECKIN( NFAIL, OUTNUM, MAXERR, NERR, MEM(ERRIPTR),
+ $ MEM(ERRDPTR), TFAIL )
+ END IF
+ IF( IAM .EQ. 0 ) THEN
+ IF( VERB .GT. 1 ) WRITE(OUTNUM,*) ' '
+ IF( NFAIL+NSKIP .EQ. 0 ) THEN
+ WRITE(OUTNUM, 8000 ) TESTNUM
+ ELSE
+ WRITE(OUTNUM, 9000 ) TESTNUM, TESTNUM-NSKIP-NFAIL,
+ $ NSKIP, NFAIL
+ END IF
+ END IF
+*
+* Log whether their were any failures
+*
+ TESTOK = ALLPASS( (NFAIL.EQ.0) )
+*
+ 1000 FORMAT('DOUBLE PRECISION BSBR TESTS: BEGIN.' )
+ 2000 FORMAT(1X,A7,3X,10I6)
+ 3000 FORMAT(1X,A7,3X,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1,
+ $ 5X,A1,5X,A1)
+ 5000 FORMAT(' TEST# STATUS SCOPE TOP UPLO DIAG M N LDAS ',
+ $ ' LDAD RSRC CSRC P Q')
+ 6000 FORMAT(' ----- ------- ----- --- ---- ---- ----- ----- ----- ',
+ $ '----- ---- ---- ---- ----')
+ 7000 FORMAT(I6,1X,A7,5X,A1,3X,A1,2(4X,A1), 4I6, 4I5)
+ 8000 FORMAT('DOUBLE PRECISION BSBR TESTS: PASSED ALL',
+ $ I5, ' TESTS.')
+ 9000 FORMAT('DOUBLE PRECISION BSBR TESTS:',I5,' TESTS;',I5,' PASSED,',
+ $ I5,' SKIPPED,',I5,' FAILED.')
+*
+ RETURN
+*
+* End of DBSBRTEST.
+*
+ END
+*
+*
+ SUBROUTINE CBSBRTEST( OUTNUM, VERB, NSCOPE, SCOPE0, NTOP, TOP0,
+ $ NSHAPE, UPLO0, DIAG0, NMAT, M0, N0, LDAS0,
+ $ LDAD0, NSRC, RSRC0, CSRC0, NGRID, CONTEXT0,
+ $ P0, Q0, TFAIL, MEM, MEMLEN )
+*
+* -- BLACS tester (version 1.0) --
+* University of Tennessee
+* December 15, 1994
+*
+*
+* .. Scalar Arguments ..
+ INTEGER OUTNUM, VERB, NSCOPE, NTOP, NSHAPE, NMAT, NSRC, NGRID
+ INTEGER MEMLEN
+* ..
+* .. Array Arguments ..
+ CHARACTER*1 SCOPE0(NSCOPE), TOP0(NTOP)
+ CHARACTER*1 UPLO0(NSHAPE), DIAG0(NSHAPE)
+ INTEGER M0(NMAT), N0(NMAT), LDAS0(NMAT), LDAD0(NMAT)
+ INTEGER RSRC0(NSRC), CSRC0(NSRC), CONTEXT0(NGRID)
+ INTEGER P0(NGRID), Q0(NGRID), TFAIL(*)
+ COMPLEX MEM(MEMLEN)
+* ..
+*
+* Purpose
+* =======
+* CTESTBSBR: Test complex broadcast
+*
+* Arguments
+* =========
+* OUTNUM (input) INTEGER
+* The device number to write output to.
+*
+* VERB (input) INTEGER
+* The level of verbosity (how much printing to do).
+*
+* NSCOPE (input) INTEGER
+* The number of scopes to be tested.
+*
+* SCOPE0 (input) CHARACTER*1 array of dimension (NSCOPE)
+* Values of the scopes to be tested.
+*
+* NTOP (input) INTEGER
+* The number of topologies to be tested.
+*
+* TOP0 (input) CHARACTER*1 array of dimension (NTOP)
+* Values of the topologies to be tested.
+*
+* NSHAPE (input) INTEGER
+* The number of matrix shapes to be tested.
+*
+* UPLO0 (input) CHARACTER*1 array of dimension (NSHAPE)
+* Values of UPLO to be tested.
+*
+* DIAG0 (input) CHARACTER*1 array of dimension (NSHAPE)
+* Values of DIAG to be tested.
+*
+* NMAT (input) INTEGER
+* The number of matrices to be tested.
+*
+* M0 (input) INTEGER array of dimension (NMAT)
+* Values of M to be tested.
+*
+* M0 (input) INTEGER array of dimension (NMAT)
+* Values of M to be tested.
+*
+* N0 (input) INTEGER array of dimension (NMAT)
+* Values of N to be tested.
+*
+* LDAS0 (input) INTEGER array of dimension (NMAT)
+* Values of LDAS (leading dimension of A on source process)
+* to be tested.
+*
+* LDAD0 (input) INTEGER array of dimension (NMAT)
+* Values of LDAD (leading dimension of A on destination
+* process) to be tested.
+* NSRC (input) INTEGER
+* The number of sources to be tested.
+*
+* RSRC0 (input) INTEGER array of dimension (NDEST)
+* Values of RSRC (row coordinate of source) to be tested.
+*
+* CSRC0 (input) INTEGER array of dimension (NDEST)
+* Values of CSRC (column coordinate of source) to be tested.
+*
+* NGRID (input) INTEGER
+* The number of process grids to be tested.
+*
+* CONTEXT0 (input) INTEGER array of dimension (NGRID)
+* The BLACS context handles corresponding to the grids.
+*
+* P0 (input) INTEGER array of dimension (NGRID)
+* Values of P (number of process rows, NPROW).
+*
+* Q0 (input) INTEGER array of dimension (NGRID)
+* Values of Q (number of process columns, NPCOL).
+*
+* TFAIL (workspace) INTEGER array of dimension (NTESTS)
+* If VERB < 2, serves to indicate which tests fail. This
+* requires workspace of NTESTS (number of tests performed).
+*
+* MEM (workspace) COMPLEX array of dimension (MEMLEN)
+* Used for all other workspaces, including the matrix A,
+* and its pre and post padding.
+*
+* MEMLEN (input) INTEGER
+* The length, in elements, of MEM.
+*
+* =====================================================================
+*
+* .. External Functions ..
+ LOGICAL ALLPASS, LSAME
+ INTEGER IBTMYPROC, IBTSIZEOF
+ EXTERNAL ALLPASS, LSAME, IBTMYPROC, IBTSIZEOF
+* ..
+* .. External Subroutines ..
+ EXTERNAL BLACS_GRIDINFO
+ EXTERNAL CTRBS2D, CGEBS2D, CTRBR2D, CGEBR2D
+ EXTERNAL CINITMAT, CCHKMAT, CCHKPAD, CBTCHECKIN
+* ..
+* .. Local Scalars ..
+ CHARACTER*1 SCOPE, TOP, UPLO, DIAG
+ LOGICAL TESTOK, INGRID
+ INTEGER IAM, I, K, J, IGR, ISH, IMA, ISO, ISC, ITO
+ INTEGER M, N, NPROW, NPCOL, MYROW, MYCOL, RSRC, CSRC
+ INTEGER ISTART, ISTOP, IPRE, IPOST, SETWHAT
+ INTEGER NERR, NSKIP, NFAIL, TESTNUM, CONTEXT, MAXERR, LDASRC
+ INTEGER LDADST, ERRDPTR, APTR, ERRIPTR, ISIZE, CSIZE
+ COMPLEX SCHECKVAL, RCHECKVAL
+* ..
+* .. Executable Statements ..
+*
+ SCHECKVAL = CMPLX( -0.01, -0.01 )
+ RCHECKVAL = CMPLX( -0.02, -0.02 )
+*
+ IAM = IBTMYPROC()
+ ISIZE = IBTSIZEOF('I')
+ CSIZE = IBTSIZEOF('C')
+*
+* Verify file parameters
+*
+ IF( IAM .EQ. 0 ) THEN
+ WRITE(OUTNUM, *) ' '
+ WRITE(OUTNUM, *) ' '
+ WRITE(OUTNUM, 1000 )
+ IF( VERB .GT. 0 ) THEN
+ WRITE(OUTNUM,*) ' '
+ WRITE(OUTNUM, 2000) 'NSCOPE:', NSCOPE
+ WRITE(OUTNUM, 3000) ' SCOPE:', ( SCOPE0(I), I = 1, NSCOPE )
+ WRITE(OUTNUM, 2000) 'NTOP :', NTOP
+ WRITE(OUTNUM, 3000) ' TOP :', ( TOP0(I), I = 1, NTOP )
+ WRITE(OUTNUM, 2000) 'NSHAPE:', NSHAPE
+ WRITE(OUTNUM, 3000) ' UPLO :', ( UPLO0(I), I = 1, NSHAPE )
+ WRITE(OUTNUM, 3000) ' DIAG :', ( DIAG0(I), I = 1, NSHAPE )
+ WRITE(OUTNUM, 2000) 'NMAT :', NMAT
+ WRITE(OUTNUM, 2000) ' M :', ( M0(I), I = 1, NMAT )
+ WRITE(OUTNUM, 2000) ' N :', ( N0(I), I = 1, NMAT )
+ WRITE(OUTNUM, 2000) ' LDAS :', ( LDAS0(I), I = 1, NMAT )
+ WRITE(OUTNUM, 2000) ' LDAD :', ( LDAD0(I), I = 1, NMAT )
+ WRITE(OUTNUM, 2000) 'NSRC :', NSRC
+ WRITE(OUTNUM, 2000) ' RSRC :',( RSRC0(I), I = 1, NSRC )
+ WRITE(OUTNUM, 2000) ' CSRC :',( CSRC0(I), I = 1, NSRC )
+ WRITE(OUTNUM, 2000) 'NGRIDS:', NGRID
+ WRITE(OUTNUM, 2000) ' P :', ( P0(I), I = 1, NGRID )
+ WRITE(OUTNUM, 2000) ' Q :', ( Q0(I), I = 1, NGRID )
+ WRITE(OUTNUM, 2000) 'VERB :', VERB
+ WRITE(OUTNUM,*) ' '
+ END IF
+ IF( VERB .GT. 1 ) THEN
+ WRITE(OUTNUM,5000)
+ WRITE(OUTNUM,6000)
+ END IF
+ END IF
+*
+* Find biggest matrix, so we know where to stick error info
+*
+ I = 0
+ DO 10 IMA = 1, NMAT
+ K = N0(IMA) * MAX0( LDAS0(IMA), LDAD0(IMA) ) + 4 * M0(IMA)
+ IF( K .GT. I ) I = K
+ 10 CONTINUE
+ MAXERR = ( CSIZE * (MEMLEN-I) ) / ( CSIZE*2 + ISIZE*6 )
+ IF( MAXERR .LT. 1 ) THEN
+ WRITE(OUTNUM,*) 'ERROR: Not enough memory to run BSBR tests.'
+ CALL BLACS_ABORT(-1, 1)
+ END IF
+ ERRDPTR = I + 1
+ ERRIPTR = ERRDPTR + MAXERR
+ NERR = 0
+ TESTNUM = 0
+ NFAIL = 0
+ NSKIP = 0
+*
+* Loop over grids of matrix
+*
+ DO 110 IGR = 1, NGRID
+*
+ CONTEXT = CONTEXT0(IGR)
+ CALL BLACS_GRIDINFO( CONTEXT, NPROW, NPCOL, MYROW, MYCOL )
+*
+ INGRID = ( NPROW .GT. 0 )
+*
+ DO 100 ISC = 1, NSCOPE
+ SCOPE = SCOPE0(ISC)
+ DO 90 ITO = 1, NTOP
+ TOP = TOP0(ITO)
+*
+* If testing multipath ('M') or general tree ('T'),
+* need to loop over calls to BLACS_SET
+*
+ IF( LSAME(TOP, 'M') ) THEN
+ SETWHAT = 11
+ IF( SCOPE .EQ. 'R' ) THEN
+ ISTART = -(NPCOL - 1)
+ ISTOP = -ISTART
+ ELSE IF (SCOPE .EQ. 'C') THEN
+ ISTART = -(NPROW - 1)
+ ISTOP = -ISTART
+ ELSE
+ ISTART = -(NPROW*NPCOL - 1)
+ ISTOP = -ISTART
+ ENDIF
+ ELSE IF( LSAME(TOP, 'T') ) THEN
+ SETWHAT = 12
+ ISTART = 1
+ IF( SCOPE .EQ. 'R' ) THEN
+ ISTOP = NPCOL - 1
+ ELSE IF (SCOPE .EQ. 'C') THEN
+ ISTOP = NPROW - 1
+ ELSE
+ ISTOP = NPROW*NPCOL - 1
+ ENDIF
+ ELSE
+ SETWHAT = 0
+ ISTART = 1
+ ISTOP = 1
+ ENDIF
+ DO 80 ISH = 1, NSHAPE
+ UPLO = UPLO0(ISH)
+ DIAG = DIAG0(ISH)
+*
+ DO 70 IMA = 1, NMAT
+ M = M0(IMA)
+ N = N0(IMA)
+ LDASRC = LDAS0(IMA)
+ LDADST = LDAD0(IMA)
+*
+ DO 60 ISO = 1, NSRC
+ TESTNUM = TESTNUM + 1
+ RSRC = RSRC0(ISO)
+ CSRC = CSRC0(ISO)
+ IF( RSRC.GE.P0(IGR) .OR. CSRC.GE.Q0(IGR) ) THEN
+ NSKIP = NSKIP + 1
+ GOTO 60
+ END IF
+ IF( VERB .GT. 1 ) THEN
+ IF( IAM .EQ. 0 ) THEN
+ WRITE(OUTNUM, 7000)
+ $ TESTNUM, 'RUNNING',SCOPE, TOP, UPLO, DIAG,
+ $ M, N, LDASRC, LDADST, RSRC, CSRC,
+ $ NPROW, NPCOL
+ END IF
+ END IF
+*
+ TESTOK = .TRUE.
+ IPRE = 2 * M
+ IPOST = IPRE
+ APTR = IPRE + 1
+*
+* If I am in scope
+*
+ IF( (MYROW.EQ.RSRC .AND. SCOPE.EQ.'R') .OR.
+ $ (MYCOL.EQ.CSRC .AND. SCOPE.EQ.'C') .OR.
+ $ (SCOPE .EQ. 'A') ) THEN
+*
+* source process generates matrix and sends it
+*
+ IF( MYROW.EQ.RSRC .AND. MYCOL.EQ.CSRC ) THEN
+ CALL CINITMAT(UPLO, DIAG, M, N, MEM,
+ $ LDASRC, IPRE, IPOST,
+ $ SCHECKVAL, TESTNUM,
+ $ MYROW, MYCOL )
+*
+ DO 20 J = ISTART, ISTOP
+ IF( J.EQ.0 ) GOTO 20
+ IF( SETWHAT.NE.0 )
+ $ CALL BLACS_SET(CONTEXT, SETWHAT, J)
+ IF( UPLO.EQ.'U' .OR. UPLO.EQ.'L' ) THEN
+ CALL CTRBS2D(CONTEXT, SCOPE, TOP,
+ $ UPLO, DIAG, M, N,
+ $ MEM(APTR), LDASRC )
+ ELSE
+ CALL CGEBS2D(CONTEXT, SCOPE, TOP,
+ $ M, N, MEM(APTR),
+ $ LDASRC )
+ END IF
+ 20 CONTINUE
+*
+* Destination processes
+*
+ ELSE IF( INGRID ) THEN
+ DO 40 J = ISTART, ISTOP
+ IF( J.EQ.0 ) GOTO 40
+ IF( SETWHAT.NE.0 )
+ $ CALL BLACS_SET(CONTEXT, SETWHAT, J)
+*
+* Pad entire matrix area
+*
+ DO 30 K = 1, IPRE+IPOST+LDADST*N
+ MEM(K) = RCHECKVAL
+ 30 CONTINUE
+*
+* Receive matrix
+*
+ IF( UPLO.EQ.'U' .OR. UPLO.EQ.'L' ) THEN
+ CALL CTRBR2D(CONTEXT, SCOPE, TOP,
+ $ UPLO, DIAG, M, N,
+ $ MEM(APTR), LDADST,
+ $ RSRC, CSRC)
+ ELSE
+ CALL CGEBR2D(CONTEXT, SCOPE, TOP,
+ $ M, N, MEM(APTR),
+ $ LDADST, RSRC, CSRC)
+ END IF
+*
+* Check for errors in matrix or padding
+*
+ I = NERR
+ CALL CCHKMAT(UPLO, DIAG, M, N,
+ $ MEM(APTR), LDADST, RSRC, CSRC,
+ $ MYROW, MYCOL, TESTNUM, MAXERR,
+ $ NERR, MEM(ERRIPTR),
+ $ MEM(ERRDPTR))
+*
+ CALL CCHKPAD(UPLO, DIAG, M, N, MEM,
+ $ LDADST, RSRC, CSRC, MYROW,
+ $ MYCOL, IPRE, IPOST, RCHECKVAL,
+ $ TESTNUM, MAXERR, NERR,
+ $ MEM(ERRIPTR), MEM(ERRDPTR))
+ 40 CONTINUE
+ TESTOK = ( I .EQ. NERR )
+ END IF
+ END IF
+*
+ IF( VERB .GT. 1 ) THEN
+ I = NERR
+ CALL CBTCHECKIN(0, OUTNUM, MAXERR, NERR,
+ $ MEM(ERRIPTR), MEM(ERRDPTR),
+ $ TFAIL)
+ IF( IAM .EQ. 0 ) THEN
+ TESTOK = ( TESTOK .AND. (I.EQ.NERR) )
+ IF( TESTOK ) THEN
+ WRITE(OUTNUM,7000)TESTNUM,'PASSED ',
+ $ SCOPE, TOP, UPLO, DIAG, M, N,
+ $ LDASRC, LDADST, RSRC, CSRC,
+ $ NPROW, NPCOL
+ ELSE
+ NFAIL = NFAIL + 1
+ WRITE(OUTNUM,7000)TESTNUM,'FAILED ',
+ $ SCOPE, TOP, UPLO, DIAG, M, N,
+ $ LDASRC, LDADST, RSRC, CSRC,
+ $ NPROW, NPCOL
+ END IF
+ END IF
+*
+* Once we've printed out errors, can re-use buf space
+*
+ NERR = 0
+ END IF
+ 60 CONTINUE
+ 70 CONTINUE
+ 80 CONTINUE
+ 90 CONTINUE
+ 100 CONTINUE
+ 110 CONTINUE
+*
+ IF( VERB .LT. 2 ) THEN
+ NFAIL = TESTNUM
+ CALL CBTCHECKIN( NFAIL, OUTNUM, MAXERR, NERR, MEM(ERRIPTR),
+ $ MEM(ERRDPTR), TFAIL )
+ END IF
+ IF( IAM .EQ. 0 ) THEN
+ IF( VERB .GT. 1 ) WRITE(OUTNUM,*) ' '
+ IF( NFAIL+NSKIP .EQ. 0 ) THEN
+ WRITE(OUTNUM, 8000 ) TESTNUM
+ ELSE
+ WRITE(OUTNUM, 9000 ) TESTNUM, TESTNUM-NSKIP-NFAIL,
+ $ NSKIP, NFAIL
+ END IF
+ END IF
+*
+* Log whether their were any failures
+*
+ TESTOK = ALLPASS( (NFAIL.EQ.0) )
+*
+ 1000 FORMAT('COMPLEX BSBR TESTS: BEGIN.' )
+ 2000 FORMAT(1X,A7,3X,10I6)
+ 3000 FORMAT(1X,A7,3X,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1,
+ $ 5X,A1,5X,A1)
+ 5000 FORMAT(' TEST# STATUS SCOPE TOP UPLO DIAG M N LDAS ',
+ $ ' LDAD RSRC CSRC P Q')
+ 6000 FORMAT(' ----- ------- ----- --- ---- ---- ----- ----- ----- ',
+ $ '----- ---- ---- ---- ----')
+ 7000 FORMAT(I6,1X,A7,5X,A1,3X,A1,2(4X,A1), 4I6, 4I5)
+ 8000 FORMAT('COMPLEX BSBR TESTS: PASSED ALL',
+ $ I5, ' TESTS.')
+ 9000 FORMAT('COMPLEX BSBR TESTS:',I5,' TESTS;',I5,' PASSED,',
+ $ I5,' SKIPPED,',I5,' FAILED.')
+*
+ RETURN
+*
+* End of CBSBRTEST.
+*
+ END
+*
+*
+ SUBROUTINE ZBSBRTEST( OUTNUM, VERB, NSCOPE, SCOPE0, NTOP, TOP0,
+ $ NSHAPE, UPLO0, DIAG0, NMAT, M0, N0, LDAS0,
+ $ LDAD0, NSRC, RSRC0, CSRC0, NGRID, CONTEXT0,
+ $ P0, Q0, TFAIL, MEM, MEMLEN )
+*
+* -- BLACS tester (version 1.0) --
+* University of Tennessee
+* December 15, 1994
+*
+*
+* .. Scalar Arguments ..
+ INTEGER OUTNUM, VERB, NSCOPE, NTOP, NSHAPE, NMAT, NSRC, NGRID
+ INTEGER MEMLEN
+* ..
+* .. Array Arguments ..
+ CHARACTER*1 SCOPE0(NSCOPE), TOP0(NTOP)
+ CHARACTER*1 UPLO0(NSHAPE), DIAG0(NSHAPE)
+ INTEGER M0(NMAT), N0(NMAT), LDAS0(NMAT), LDAD0(NMAT)
+ INTEGER RSRC0(NSRC), CSRC0(NSRC), CONTEXT0(NGRID)
+ INTEGER P0(NGRID), Q0(NGRID), TFAIL(*)
+ DOUBLE COMPLEX MEM(MEMLEN)
+* ..
+*
+* Purpose
+* =======
+* ZTESTBSBR: Test double complex broadcast
+*
+* Arguments
+* =========
+* OUTNUM (input) INTEGER
+* The device number to write output to.
+*
+* VERB (input) INTEGER
+* The level of verbosity (how much printing to do).
+*
+* NSCOPE (input) INTEGER
+* The number of scopes to be tested.
+*
+* SCOPE0 (input) CHARACTER*1 array of dimension (NSCOPE)
+* Values of the scopes to be tested.
+*
+* NTOP (input) INTEGER
+* The number of topologies to be tested.
+*
+* TOP0 (input) CHARACTER*1 array of dimension (NTOP)
+* Values of the topologies to be tested.
+*
+* NSHAPE (input) INTEGER
+* The number of matrix shapes to be tested.
+*
+* UPLO0 (input) CHARACTER*1 array of dimension (NSHAPE)
+* Values of UPLO to be tested.
+*
+* DIAG0 (input) CHARACTER*1 array of dimension (NSHAPE)
+* Values of DIAG to be tested.
+*
+* NMAT (input) INTEGER
+* The number of matrices to be tested.
+*
+* M0 (input) INTEGER array of dimension (NMAT)
+* Values of M to be tested.
+*
+* M0 (input) INTEGER array of dimension (NMAT)
+* Values of M to be tested.
+*
+* N0 (input) INTEGER array of dimension (NMAT)
+* Values of N to be tested.
+*
+* LDAS0 (input) INTEGER array of dimension (NMAT)
+* Values of LDAS (leading dimension of A on source process)
+* to be tested.
+*
+* LDAD0 (input) INTEGER array of dimension (NMAT)
+* Values of LDAD (leading dimension of A on destination
+* process) to be tested.
+* NSRC (input) INTEGER
+* The number of sources to be tested.
+*
+* RSRC0 (input) INTEGER array of dimension (NDEST)
+* Values of RSRC (row coordinate of source) to be tested.
+*
+* CSRC0 (input) INTEGER array of dimension (NDEST)
+* Values of CSRC (column coordinate of source) to be tested.
+*
+* NGRID (input) INTEGER
+* The number of process grids to be tested.
+*
+* CONTEXT0 (input) INTEGER array of dimension (NGRID)
+* The BLACS context handles corresponding to the grids.
+*
+* P0 (input) INTEGER array of dimension (NGRID)
+* Values of P (number of process rows, NPROW).
+*
+* Q0 (input) INTEGER array of dimension (NGRID)
+* Values of Q (number of process columns, NPCOL).
+*
+* TFAIL (workspace) INTEGER array of dimension (NTESTS)
+* If VERB < 2, serves to indicate which tests fail. This
+* requires workspace of NTESTS (number of tests performed).
+*
+* MEM (workspace) DOUBLE COMPLEX array of dimension (MEMLEN)
+* Used for all other workspaces, including the matrix A,
+* and its pre and post padding.
+*
+* MEMLEN (input) INTEGER
+* The length, in elements, of MEM.
+*
+* =====================================================================
+*
+* .. External Functions ..
+ LOGICAL ALLPASS, LSAME
+ INTEGER IBTMYPROC, IBTSIZEOF
+ EXTERNAL ALLPASS, LSAME, IBTMYPROC, IBTSIZEOF
+* ..
+* .. External Subroutines ..
+ EXTERNAL BLACS_GRIDINFO
+ EXTERNAL ZTRBS2D, ZGEBS2D, ZTRBR2D, ZGEBR2D
+ EXTERNAL ZINITMAT, ZCHKMAT, ZCHKPAD, ZBTCHECKIN
+* ..
+* .. Local Scalars ..
+ CHARACTER*1 SCOPE, TOP, UPLO, DIAG
+ LOGICAL TESTOK, INGRID
+ INTEGER IAM, I, K, J, IGR, ISH, IMA, ISO, ISC, ITO
+ INTEGER M, N, NPROW, NPCOL, MYROW, MYCOL, RSRC, CSRC
+ INTEGER ISTART, ISTOP, IPRE, IPOST, SETWHAT
+ INTEGER NERR, NSKIP, NFAIL, TESTNUM, CONTEXT, MAXERR, LDASRC
+ INTEGER LDADST, ERRDPTR, APTR, ERRIPTR, ISIZE, ZSIZE
+ DOUBLE COMPLEX SCHECKVAL, RCHECKVAL
+* ..
+* .. Executable Statements ..
+*
+ SCHECKVAL = DCMPLX( -0.01D0, -0.01D0 )
+ RCHECKVAL = DCMPLX( -0.02D0, -0.02D0 )
+*
+ IAM = IBTMYPROC()
+ ISIZE = IBTSIZEOF('I')
+ ZSIZE = IBTSIZEOF('Z')
+*
+* Verify file parameters
+*
+ IF( IAM .EQ. 0 ) THEN
+ WRITE(OUTNUM, *) ' '
+ WRITE(OUTNUM, *) ' '
+ WRITE(OUTNUM, 1000 )
+ IF( VERB .GT. 0 ) THEN
+ WRITE(OUTNUM,*) ' '
+ WRITE(OUTNUM, 2000) 'NSCOPE:', NSCOPE
+ WRITE(OUTNUM, 3000) ' SCOPE:', ( SCOPE0(I), I = 1, NSCOPE )
+ WRITE(OUTNUM, 2000) 'NTOP :', NTOP
+ WRITE(OUTNUM, 3000) ' TOP :', ( TOP0(I), I = 1, NTOP )
+ WRITE(OUTNUM, 2000) 'NSHAPE:', NSHAPE
+ WRITE(OUTNUM, 3000) ' UPLO :', ( UPLO0(I), I = 1, NSHAPE )
+ WRITE(OUTNUM, 3000) ' DIAG :', ( DIAG0(I), I = 1, NSHAPE )
+ WRITE(OUTNUM, 2000) 'NMAT :', NMAT
+ WRITE(OUTNUM, 2000) ' M :', ( M0(I), I = 1, NMAT )
+ WRITE(OUTNUM, 2000) ' N :', ( N0(I), I = 1, NMAT )
+ WRITE(OUTNUM, 2000) ' LDAS :', ( LDAS0(I), I = 1, NMAT )
+ WRITE(OUTNUM, 2000) ' LDAD :', ( LDAD0(I), I = 1, NMAT )
+ WRITE(OUTNUM, 2000) 'NSRC :', NSRC
+ WRITE(OUTNUM, 2000) ' RSRC :',( RSRC0(I), I = 1, NSRC )
+ WRITE(OUTNUM, 2000) ' CSRC :',( CSRC0(I), I = 1, NSRC )
+ WRITE(OUTNUM, 2000) 'NGRIDS:', NGRID
+ WRITE(OUTNUM, 2000) ' P :', ( P0(I), I = 1, NGRID )
+ WRITE(OUTNUM, 2000) ' Q :', ( Q0(I), I = 1, NGRID )
+ WRITE(OUTNUM, 2000) 'VERB :', VERB
+ WRITE(OUTNUM,*) ' '
+ END IF
+ IF( VERB .GT. 1 ) THEN
+ WRITE(OUTNUM,5000)
+ WRITE(OUTNUM,6000)
+ END IF
+ END IF
+*
+* Find biggest matrix, so we know where to stick error info
+*
+ I = 0
+ DO 10 IMA = 1, NMAT
+ K = N0(IMA) * MAX0( LDAS0(IMA), LDAD0(IMA) ) + 4 * M0(IMA)
+ IF( K .GT. I ) I = K
+ 10 CONTINUE
+ MAXERR = ( ZSIZE * (MEMLEN-I) ) / ( ZSIZE*2 + ISIZE*6 )
+ IF( MAXERR .LT. 1 ) THEN
+ WRITE(OUTNUM,*) 'ERROR: Not enough memory to run BSBR tests.'
+ CALL BLACS_ABORT(-1, 1)
+ END IF
+ ERRDPTR = I + 1
+ ERRIPTR = ERRDPTR + MAXERR
+ NERR = 0
+ TESTNUM = 0
+ NFAIL = 0
+ NSKIP = 0
+*
+* Loop over grids of matrix
+*
+ DO 110 IGR = 1, NGRID
+*
+ CONTEXT = CONTEXT0(IGR)
+ CALL BLACS_GRIDINFO( CONTEXT, NPROW, NPCOL, MYROW, MYCOL )
+*
+ INGRID = ( NPROW .GT. 0 )
+*
+ DO 100 ISC = 1, NSCOPE
+ SCOPE = SCOPE0(ISC)
+ DO 90 ITO = 1, NTOP
+ TOP = TOP0(ITO)
+*
+* If testing multipath ('M') or general tree ('T'),
+* need to loop over calls to BLACS_SET
+*
+ IF( LSAME(TOP, 'M') ) THEN
+ SETWHAT = 11
+ IF( SCOPE .EQ. 'R' ) THEN
+ ISTART = -(NPCOL - 1)
+ ISTOP = -ISTART
+ ELSE IF (SCOPE .EQ. 'C') THEN
+ ISTART = -(NPROW - 1)
+ ISTOP = -ISTART
+ ELSE
+ ISTART = -(NPROW*NPCOL - 1)
+ ISTOP = -ISTART
+ ENDIF
+ ELSE IF( LSAME(TOP, 'T') ) THEN
+ SETWHAT = 12
+ ISTART = 1
+ IF( SCOPE .EQ. 'R' ) THEN
+ ISTOP = NPCOL - 1
+ ELSE IF (SCOPE .EQ. 'C') THEN
+ ISTOP = NPROW - 1
+ ELSE
+ ISTOP = NPROW*NPCOL - 1
+ ENDIF
+ ELSE
+ SETWHAT = 0
+ ISTART = 1
+ ISTOP = 1
+ ENDIF
+ DO 80 ISH = 1, NSHAPE
+ UPLO = UPLO0(ISH)
+ DIAG = DIAG0(ISH)
+*
+ DO 70 IMA = 1, NMAT
+ M = M0(IMA)
+ N = N0(IMA)
+ LDASRC = LDAS0(IMA)
+ LDADST = LDAD0(IMA)
+*
+ DO 60 ISO = 1, NSRC
+ TESTNUM = TESTNUM + 1
+ RSRC = RSRC0(ISO)
+ CSRC = CSRC0(ISO)
+ IF( RSRC.GE.P0(IGR) .OR. CSRC.GE.Q0(IGR) ) THEN
+ NSKIP = NSKIP + 1
+ GOTO 60
+ END IF
+ IF( VERB .GT. 1 ) THEN
+ IF( IAM .EQ. 0 ) THEN
+ WRITE(OUTNUM, 7000)
+ $ TESTNUM, 'RUNNING',SCOPE, TOP, UPLO, DIAG,
+ $ M, N, LDASRC, LDADST, RSRC, CSRC,
+ $ NPROW, NPCOL
+ END IF
+ END IF
+*
+ TESTOK = .TRUE.
+ IPRE = 2 * M
+ IPOST = IPRE
+ APTR = IPRE + 1
+*
+* If I am in scope
+*
+ IF( (MYROW.EQ.RSRC .AND. SCOPE.EQ.'R') .OR.
+ $ (MYCOL.EQ.CSRC .AND. SCOPE.EQ.'C') .OR.
+ $ (SCOPE .EQ. 'A') ) THEN
+*
+* source process generates matrix and sends it
+*
+ IF( MYROW.EQ.RSRC .AND. MYCOL.EQ.CSRC ) THEN
+ CALL ZINITMAT(UPLO, DIAG, M, N, MEM,
+ $ LDASRC, IPRE, IPOST,
+ $ SCHECKVAL, TESTNUM,
+ $ MYROW, MYCOL )
+*
+ DO 20 J = ISTART, ISTOP
+ IF( J.EQ.0 ) GOTO 20
+ IF( SETWHAT.NE.0 )
+ $ CALL BLACS_SET(CONTEXT, SETWHAT, J)
+ IF( UPLO.EQ.'U' .OR. UPLO.EQ.'L' ) THEN
+ CALL ZTRBS2D(CONTEXT, SCOPE, TOP,
+ $ UPLO, DIAG, M, N,
+ $ MEM(APTR), LDASRC )
+ ELSE
+ CALL ZGEBS2D(CONTEXT, SCOPE, TOP,
+ $ M, N, MEM(APTR),
+ $ LDASRC )
+ END IF
+ 20 CONTINUE
+*
+* Destination processes
+*
+ ELSE IF( INGRID ) THEN
+ DO 40 J = ISTART, ISTOP
+ IF( J.EQ.0 ) GOTO 40
+ IF( SETWHAT.NE.0 )
+ $ CALL BLACS_SET(CONTEXT, SETWHAT, J)
+*
+* Pad entire matrix area
+*
+ DO 30 K = 1, IPRE+IPOST+LDADST*N
+ MEM(K) = RCHECKVAL
+ 30 CONTINUE
+*
+* Receive matrix
+*
+ IF( UPLO.EQ.'U' .OR. UPLO.EQ.'L' ) THEN
+ CALL ZTRBR2D(CONTEXT, SCOPE, TOP,
+ $ UPLO, DIAG, M, N,
+ $ MEM(APTR), LDADST,
+ $ RSRC, CSRC)
+ ELSE
+ CALL ZGEBR2D(CONTEXT, SCOPE, TOP,
+ $ M, N, MEM(APTR),
+ $ LDADST, RSRC, CSRC)
+ END IF
+*
+* Check for errors in matrix or padding
+*
+ I = NERR
+ CALL ZCHKMAT(UPLO, DIAG, M, N,
+ $ MEM(APTR), LDADST, RSRC, CSRC,
+ $ MYROW, MYCOL, TESTNUM, MAXERR,
+ $ NERR, MEM(ERRIPTR),
+ $ MEM(ERRDPTR))
+*
+ CALL ZCHKPAD(UPLO, DIAG, M, N, MEM,
+ $ LDADST, RSRC, CSRC, MYROW,
+ $ MYCOL, IPRE, IPOST, RCHECKVAL,
+ $ TESTNUM, MAXERR, NERR,
+ $ MEM(ERRIPTR), MEM(ERRDPTR))
+ 40 CONTINUE
+ TESTOK = ( I .EQ. NERR )
+ END IF
+ END IF
+*
+ IF( VERB .GT. 1 ) THEN
+ I = NERR
+ CALL ZBTCHECKIN(0, OUTNUM, MAXERR, NERR,
+ $ MEM(ERRIPTR), MEM(ERRDPTR),
+ $ TFAIL)
+ IF( IAM .EQ. 0 ) THEN
+ TESTOK = ( TESTOK .AND. (I.EQ.NERR) )
+ IF( TESTOK ) THEN
+ WRITE(OUTNUM,7000)TESTNUM,'PASSED ',
+ $ SCOPE, TOP, UPLO, DIAG, M, N,
+ $ LDASRC, LDADST, RSRC, CSRC,
+ $ NPROW, NPCOL
+ ELSE
+ NFAIL = NFAIL + 1
+ WRITE(OUTNUM,7000)TESTNUM,'FAILED ',
+ $ SCOPE, TOP, UPLO, DIAG, M, N,
+ $ LDASRC, LDADST, RSRC, CSRC,
+ $ NPROW, NPCOL
+ END IF
+ END IF
+*
+* Once we've printed out errors, can re-use buf space
+*
+ NERR = 0
+ END IF
+ 60 CONTINUE
+ 70 CONTINUE
+ 80 CONTINUE
+ 90 CONTINUE
+ 100 CONTINUE
+ 110 CONTINUE
+*
+ IF( VERB .LT. 2 ) THEN
+ NFAIL = TESTNUM
+ CALL ZBTCHECKIN( NFAIL, OUTNUM, MAXERR, NERR, MEM(ERRIPTR),
+ $ MEM(ERRDPTR), TFAIL )
+ END IF
+ IF( IAM .EQ. 0 ) THEN
+ IF( VERB .GT. 1 ) WRITE(OUTNUM,*) ' '
+ IF( NFAIL+NSKIP .EQ. 0 ) THEN
+ WRITE(OUTNUM, 8000 ) TESTNUM
+ ELSE
+ WRITE(OUTNUM, 9000 ) TESTNUM, TESTNUM-NSKIP-NFAIL,
+ $ NSKIP, NFAIL
+ END IF
+ END IF
+*
+* Log whether their were any failures
+*
+ TESTOK = ALLPASS( (NFAIL.EQ.0) )
+*
+ 1000 FORMAT('DOUBLE COMPLEX BSBR TESTS: BEGIN.' )
+ 2000 FORMAT(1X,A7,3X,10I6)
+ 3000 FORMAT(1X,A7,3X,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1,
+ $ 5X,A1,5X,A1)
+ 5000 FORMAT(' TEST# STATUS SCOPE TOP UPLO DIAG M N LDAS ',
+ $ ' LDAD RSRC CSRC P Q')
+ 6000 FORMAT(' ----- ------- ----- --- ---- ---- ----- ----- ----- ',
+ $ '----- ---- ---- ---- ----')
+ 7000 FORMAT(I6,1X,A7,5X,A1,3X,A1,2(4X,A1), 4I6, 4I5)
+ 8000 FORMAT('DOUBLE COMPLEX BSBR TESTS: PASSED ALL',
+ $ I5, ' TESTS.')
+ 9000 FORMAT('DOUBLE COMPLEX BSBR TESTS:',I5,' TESTS;',I5,' PASSED,',
+ $ I5,' SKIPPED,',I5,' FAILED.')
+*
+ RETURN
+*
+* End of ZBSBRTEST.
+*
+ END
+*
+*
+ SUBROUTINE RDCOMB( MEMUSED, MEM, MEMLEN, CMEMUSED, CMEM, CMEMLEN,
+ $ OUTNUM )
+*
+* -- BLACS tester (version 1.0) --
+* University of Tennessee
+* December 15, 1994
+*
+*
+* .. Scalar Arguments ..
+ INTEGER MEMUSED, MEMLEN, CMEMUSED, CMEMLEN, OUTNUM
+* ..
+* .. Array Arguments ..
+ CHARACTER*1 CMEM(CMEMLEN)
+ INTEGER MEM(MEMLEN)
+* ..
+*
+* Purpose
+* =======
+* RDCOMB: Read and process the input file COMB.dat.
+*
+* Arguments
+* =========
+* MEMUSED (output) INTEGER
+* Number of elements in MEM that this subroutine ends up using.
+*
+* MEM (output) INTEGER array of dimension memlen
+* On output, holds information read in from sdrv.dat.
+*
+* MEMLEN (input) INTEGER
+* Number of elements of MEM that this subroutine
+* may safely write into.
+*
+* CMEMUSED (output) INTEGER
+* Number of elements in CMEM that this subroutine ends up using.
+*
+* CMEM (output) CHARACTER*1 array of dimension cmemlen
+* On output, holds the values for UPLO and DIAG.
+*
+* CMEMLEN (input) INTEGER
+* Number of elements of CMEM that this subroutine
+* may safely write into.
+*
+* OUTNUM (input) INTEGER
+* Unit number of the output file.
+*
+* =================================================================
+*
+* .. Parameters ..
+ INTEGER SDIN
+ PARAMETER( SDIN = 12 )
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. Local Scalars ..
+ INTEGER TOPSREPEAT, TOPSCOHRNT, NOPS, NSCOPE, NTOP, NMAT, NDEST
+ INTEGER NGRID, I, J, OPPTR, SCOPEPTR, TOPPTR, MPTR, NPTR
+ INTEGER LDSPTR, LDDPTR, LDIPTR, RDESTPTR, CDESTPTR, PPTR, QPTR
+* ..
+* .. Executable Statements
+*
+* Open and read the file comb.dat. The expected format is
+* below.
+*
+*------
+*integer Number of operations
+*array of CHAR*1's OPs: '+', '>', '<'
+*integer Number of scopes
+*array of CHAR*1's Values for Scopes
+*HAR*1 Repeatability flag ('R', 'N', 'B')
+*HAR*1 Coherency flag ('C', 'N', 'B')
+*integer Number of topologies
+*array of CHAR*1's Values for TOP
+*integer number of nmat
+*array of integers M: number of rows in matrix
+*array of integers N: number of columns in matrix
+*integer LDA: leading dimension on source proc
+*integer LDA: leading dimension on dest proc
+*integer number of source/dest pairs
+*array of integers RDEST: process row of msg. dest.
+*array of integers CDEST: process column of msg. dest.
+*integer Number of grids
+*array of integers NPROW: number of rows in process grid
+*array of integers NPCOL: number of col's in proc. grid
+*------
+* note: the text descriptions as shown above are present in
+* the sample comb.dat included with this distribution,
+* but are not required.
+*
+* Read input file
+*
+ MEMUSED = 1
+ CMEMUSED = 1
+ OPEN(UNIT = SDIN, FILE = 'comb.dat', STATUS = 'OLD')
+*
+* Get what operations to test (+, >, <)
+*
+ READ(SDIN, *) NOPS
+ OPPTR = CMEMUSED
+ CMEMUSED = OPPTR + NOPS
+ IF ( CMEMUSED .GT. CMEMLEN ) THEN
+ WRITE(OUTNUM, 1000) CMEMLEN, NOPS, 'OPERATIONS.'
+ IF( OUTNUM .NE. 6 .AND. OUTNUM .NE. 0 ) CLOSE(OUTNUM)
+ STOP
+ ELSE IF( NOPS .LT. 1 ) THEN
+ WRITE(OUTNUM, 2000) 'OPERATIONS.'
+ IF( OUTNUM .NE. 6 .AND. OUTNUM .NE. 0 ) CLOSE(OUTNUM)
+ STOP
+ END IF
+*
+ READ(SDIN, *) ( CMEM(OPPTR+I), I = 0, NOPS-1 )
+ DO 10 I = 0, NOPS-1
+ IF( (CMEM(OPPTR+I).NE.'+') .AND. (CMEM(OPPTR+I).NE.'>') .AND.
+ $ (CMEM(OPPTR+I).NE.'<') ) THEN
+ WRITE(OUTNUM,5000) CMEM(OPPTR+I)
+ IF( OUTNUM .NE. 6 .AND. OUTNUM .NE. 0 ) CLOSE(OUTNUM)
+ STOP
+ END IF
+ 10 CONTINUE
+*
+* Read in scopes and topologies
+*
+ READ(SDIN, *) NSCOPE
+ SCOPEPTR = CMEMUSED
+ CMEMUSED = SCOPEPTR + NSCOPE
+ IF ( CMEMUSED .GT. CMEMLEN ) THEN
+ WRITE(OUTNUM, 1000) CMEMLEN, NSCOPE, 'SCOPES.'
+ IF( OUTNUM .NE. 6 .AND. OUTNUM .NE. 0 ) CLOSE(OUTNUM)
+ STOP
+ ELSE IF( NSCOPE .LT. 1 ) THEN
+ WRITE(OUTNUM, 2000) 'SCOPE.'
+ IF( OUTNUM .NE. 6 .AND. OUTNUM .NE. 0 ) CLOSE(OUTNUM)
+ STOP
+ END IF
+*
+ READ(SDIN, *) ( CMEM(SCOPEPTR+I), I = 0, NSCOPE-1 )
+ DO 20 I = 0, NSCOPE-1
+ IF( LSAME(CMEM(SCOPEPTR+I), 'R') ) THEN
+ CMEM(SCOPEPTR+I) = 'R'
+ ELSE IF( LSAME(CMEM(SCOPEPTR+I), 'C') ) THEN
+ CMEM(SCOPEPTR+I) = 'C'
+ ELSE IF( LSAME(CMEM(SCOPEPTR+I), 'A') ) THEN
+ CMEM(SCOPEPTR+I) = 'A'
+ ELSE
+ WRITE(OUTNUM, 3000) 'SCOPE', CMEM(SCOPEPTR+I)
+ IF( OUTNUM .NE. 6 .AND. OUTNUM .NE. 0 ) CLOSE(OUTNUM)
+ STOP
+ END IF
+ 20 CONTINUE
+*
+ READ(SDIN, *) TOPSREPEAT
+ READ(SDIN, *) TOPSCOHRNT
+*
+ READ(SDIN, *) NTOP
+ TOPPTR = CMEMUSED
+ CMEMUSED = TOPPTR + NTOP
+ IF ( CMEMUSED .GT. CMEMLEN ) THEN
+ WRITE(OUTNUM, 1000) CMEMLEN, NTOP, 'TOPOLOGIES.'
+ IF( OUTNUM .NE. 6 .AND. OUTNUM .NE. 0 ) CLOSE(OUTNUM)
+ STOP
+ ELSE IF( NTOP .LT. 1 ) THEN
+ WRITE(OUTNUM, 2000) 'TOPOLOGY.'
+ IF( OUTNUM .NE. 6 .AND. OUTNUM .NE. 0 ) CLOSE(OUTNUM)
+ STOP
+ END IF
+ READ(SDIN, *) ( CMEM(TOPPTR+I), I = 0, NTOP-1 )
+*
+*
+* Read in number of matrices, and values for M, N, LDASRC, and LDADEST
+*
+ READ(SDIN, *) NMAT
+ MPTR = MEMUSED
+ NPTR = MPTR + NMAT
+ LDSPTR = NPTR + NMAT
+ LDDPTR = LDSPTR + NMAT
+ LDIPTR = LDDPTR + NMAT
+ MEMUSED = LDIPTR + NMAT
+ IF( MEMUSED .GT. MEMLEN ) THEN
+ WRITE(OUTNUM, 1000) MEMLEN, NMAT, 'MATRICES.'
+ IF( OUTNUM .NE. 6 .AND. OUTNUM .NE. 0 ) CLOSE(OUTNUM)
+ STOP
+ ELSE IF( NMAT .LT. 1 ) THEN
+ WRITE(OUTNUM, 2000) 'MATRIX.'
+ IF( OUTNUM .NE. 6 .AND. OUTNUM .NE. 0 ) CLOSE(OUTNUM)
+ STOP
+ END IF
+ READ(SDIN, *) ( MEM( MPTR+I ), I = 0, NMAT-1 )
+ READ(SDIN, *) ( MEM( NPTR+I ), I = 0, NMAT-1 )
+ READ(SDIN, *) ( MEM( LDSPTR+I ), I = 0, NMAT-1 )
+ READ(SDIN, *) ( MEM( LDDPTR+I ), I = 0, NMAT-1 )
+ READ(SDIN, *) ( MEM( LDIPTR+I ), I = 0, NMAT-1 )
+*
+* Make sure matrix values are legal
+*
+ CALL CHKMATDAT( OUTNUM, 'COMB.dat', .TRUE., NMAT, MEM(MPTR),
+ $ MEM(NPTR), MEM(LDSPTR), MEM(LDDPTR), MEM(LDIPTR) )
+*
+* Read in number of dest pairs, and values of dest
+*
+ READ(SDIN, *) NDEST
+ RDESTPTR = MEMUSED
+ CDESTPTR = RDESTPTR + NDEST
+ MEMUSED = CDESTPTR + NDEST
+ IF( MEMUSED .GT. MEMLEN ) THEN
+ WRITE(OUTNUM, 1000) MEMLEN, NMAT, 'DEST.'
+ IF( OUTNUM .NE. 6 .AND. OUTNUM .NE. 0 ) CLOSE(OUTNUM)
+ STOP
+ ELSE IF( NDEST .LT. 1 ) THEN
+ WRITE(OUTNUM, 2000) 'DEST.'
+ IF( OUTNUM .NE. 6 .AND. OUTNUM .NE. 0 ) CLOSE(OUTNUM)
+ STOP
+ END IF
+ READ(SDIN, *) ( MEM(RDESTPTR+I), I = 0, NDEST-1 )
+ READ(SDIN, *) ( MEM(CDESTPTR+I), I = 0, NDEST-1 )
+*
+* Read in number of grids pairs, and values of P (process rows) and
+* Q (process columns)
+*
+ READ(SDIN, *) NGRID
+ PPTR = MEMUSED
+ QPTR = PPTR + NGRID
+ MEMUSED = QPTR + NGRID
+ IF( MEMUSED .GT. MEMLEN ) THEN
+ WRITE(OUTNUM, 1000) MEMLEN, NGRID, 'PROCESS GRIDS.'
+ IF( OUTNUM .NE. 6 .AND. OUTNUM .NE. 0 ) CLOSE(OUTNUM)
+ STOP
+ ELSE IF( NGRID .LT. 1 ) THEN
+ WRITE(OUTNUM, 2000) 'PROCESS GRID'
+ IF( OUTNUM .NE. 6 .AND. OUTNUM .NE. 0 ) CLOSE( OUTNUM )
+ STOP
+ END IF
+*
+ READ(SDIN, *) ( MEM(PPTR+I), I = 0, NGRID-1 )
+ READ(SDIN, *) ( MEM(QPTR+I), I = 0, NGRID-1 )
+ IF( SDIN .NE. 6 .AND. SDIN .NE. 0 ) CLOSE( SDIN )
+*
+* Fatal error if we've got an illegal grid
+*
+ DO 70 J = 0, NGRID-1
+ IF( MEM(PPTR+J).LT.1 .OR. MEM(QPTR+J).LT.1 ) THEN
+ WRITE(OUTNUM, 4000) MEM(PPTR+J), MEM(QPTR+J)
+ IF( OUTNUM .NE. 6 .AND. OUTNUM .NE. 0 ) CLOSE(OUTNUM)
+ STOP
+ END IF
+ 70 CONTINUE
+*
+* Prepare output variables
+*
+ MEM(MEMUSED) = NOPS
+ MEM(MEMUSED+1) = NSCOPE
+ MEM(MEMUSED+2) = TOPSREPEAT
+ MEM(MEMUSED+3) = TOPSCOHRNT
+ MEM(MEMUSED+4) = NTOP
+ MEM(MEMUSED+5) = NMAT
+ MEM(MEMUSED+6) = NDEST
+ MEM(MEMUSED+7) = NGRID
+ MEMUSED = MEMUSED + 7
+ CMEMUSED = CMEMUSED - 1
+*
+ 1000 FORMAT('Mem too short (',I4,') to handle',I4,' ',A20)
+ 2000 FORMAT('Must have at least one ',A20)
+ 3000 FORMAT('UNRECOGNIZABLE ',A5,' ''', A1, '''.')
+ 4000 FORMAT('Illegal process grid: {',I3,',',I3,'}.')
+ 5000 FORMAT('Illegal OP value ''',A1,''':, expected ''+'' (SUM),',
+ $ ' ''>'' (MAX), or ''<'' (MIN).')
+*
+ RETURN
+*
+* End of RDCOMB.
+*
+ END
+*
+*
+ SUBROUTINE IBTCHECKIN( NFTESTS, OUTNUM, MAXERR, NERR, IERR,
+ $ IVAL, TFAILED )
+ INTEGER NFTESTS, OUTNUM, MAXERR, NERR
+ INTEGER IERR(*), TFAILED(*)
+ INTEGER IVAL(*)
+*
+* Purpose
+* =======
+* IBTCHECKIN: Process 0 receives error report from all processes.
+*
+* Arguments
+* =========
+* NFTESTS (input/output) INTEGER
+* if NFTESTS is <= 0 upon entry, NFTESTS is not written to.
+* Otherwise, on entry it specifies the total number of tests
+* run, and on exit it is the number of tests which failed.
+*
+* OUTNUM (input) INTEGER
+* Device number for output.
+*
+* MAXERR (input) INTEGER
+* Max number of errors that can be stored in ERRIBUFF or
+* ERRIBUFF
+*
+* NERR (output) INTEGER
+* The number of errors that have been found.
+*
+* ERRIBUF (output) INTEGER array, dimension (6,MAXERRS)
+* Buffer in which to store integer error information. It will
+* be built up in the following format for the call to TSEND.
+* All integer information is recorded in the following 6-tuple
+* {TESTNUM, SRC, DEST, I, J, WHAT}. These values are figured:
+* SRC = RSRC * NPROCS + CSRC
+* DEST = RDEST * NPROCS + CDEST
+* WHAT
+* = 1 : Error in pre-padding
+* = 2 : Error in post-padding
+* = 3 : Error in LDA-M gap
+* = 4 : Error in complementory triangle
+* ELSE: Error in matrix
+* If there are more errors than can fit in the error buffer,
+* the error number will indicate the actual number of errors
+* found, but the buffer will be truncated to the maximum
+* number of errors which can fit.
+*
+* ERRDBUF (output) @(doctype) array, dimension (2, MAXERRS)
+* Buffer in which to store error data information.
+* {Incorrect, Predicted}
+*
+* TFAILED (workspace) INTEGER array, dimension NFTESTS
+* Workspace used to keep track of which tests failed.
+* If input of NFTESTS < 1, this array not accessed.
+*
+* ===================================================================
+*
+* .. External Functions ..
+ INTEGER IBTMYPROC, IBTNPROCS, IBTMSGID
+ EXTERNAL IBTMYPROC, IBTNPROCS, IBTMSGID
+* ..
+* .. Local Scalars ..
+ LOGICAL COUNTING
+ INTEGER K, NERR2, IAM, NPROCS, NTESTS
+*
+* Proc 0 collects error info from everyone
+*
+ IAM = IBTMYPROC()
+ NPROCS = IBTNPROCS()
+*
+ IF( IAM .EQ. 0 ) THEN
+*
+* If we are finding out how many failed tests there are, initialize
+* the total number of tests (NTESTS), and zero the test failed array
+*
+ COUNTING = NFTESTS .GT. 0
+ IF( COUNTING ) THEN
+ NTESTS = NFTESTS
+ DO 10 K = 1, NTESTS
+ TFAILED(K) = 0
+ 10 CONTINUE
+ END IF
+*
+ CALL IPRINTERRS(OUTNUM, MAXERR, NERR, IERR, IVAL, COUNTING,
+ $ TFAILED)
+*
+ DO 20 K = 1, NPROCS-1
+ CALL BTSEND(3, 0, K, K, IBTMSGID()+50)
+ CALL BTRECV(3, 1, NERR2, K, IBTMSGID()+50)
+ IF( NERR2 .GT. 0 ) THEN
+ NERR = NERR + NERR2
+ CALL BTRECV(3, NERR2*6, IERR, K, IBTMSGID()+51)
+ CALL BTRECV(3, NERR2*2, IVAL, K, IBTMSGID()+51)
+ CALL IPRINTERRS(OUTNUM, MAXERR, NERR2, IERR, IVAL,
+ $ COUNTING, TFAILED)
+ END IF
+ 20 CONTINUE
+*
+* Count up number of tests that failed
+*
+ IF( COUNTING ) THEN
+ NFTESTS = 0
+ DO 30 K = 1, NTESTS
+ NFTESTS = NFTESTS + TFAILED(K)
+ 30 CONTINUE
+ END IF
+*
+* Send my error info to proc 0
+*
+ ELSE
+ CALL BTRECV(3, 0, K, 0, IBTMSGID()+50)
+ CALL BTSEND(3, 1, NERR, 0, IBTMSGID()+50)
+ IF( NERR .GT. 0 ) THEN
+ CALL BTSEND(3, NERR*6, IERR, 0, IBTMSGID()+51)
+ CALL BTSEND(3, NERR*2, IVAL, 0, IBTMSGID()+51)
+ END IF
+ ENDIF
+*
+ RETURN
+*
+* End of IBTCHECKIN
+*
+ END
+*
+ SUBROUTINE IINITMAT(UPLO, DIAG, M, N, MEM, LDA, IPRE, IPOST,
+ $ CHECKVAL, TESTNUM, MYROW, MYCOL)
+ CHARACTER*1 UPLO, DIAG
+ INTEGER M, N, LDA, IPRE, IPOST, TESTNUM, MYROW, MYCOL
+ INTEGER CHECKVAL
+ INTEGER MEM(*)
+*
+* .. External Subroutines ..
+ EXTERNAL IGENMAT, IPADMAT
+* ..
+* .. Executable Statements ..
+*
+ CALL IGENMAT( M, N, MEM(IPRE+1), LDA, TESTNUM, MYROW, MYCOL )
+ CALL IPADMAT( UPLO, DIAG, M, N, MEM, LDA, IPRE, IPOST, CHECKVAL )
+*
+ RETURN
+ END
+*
+ SUBROUTINE IGENMAT( M, N, A, LDA, TESTNUM, MYROW, MYCOL )
+*
+* -- BLACS tester (version 1.0) --
+* University of Tennessee
+* December 15, 1994
+*
+*
+* .. Scalar Arguments ..
+ INTEGER M, N, LDA, TESTNUM, MYROW, MYCOL
+* ..
+* .. Array Arguments ..
+ INTEGER A(LDA,N)
+* ..
+*
+* Purpose
+* =======
+* IGENMAT: Generates an M-by-N matrix filled with random elements.
+*
+* Arguments
+* =========
+* M (input) INTEGER
+* The number of rows of the matrix A. M >= 0.
+*
+* N (input) INTEGER
+* The number of columns of the matrix A. N >= 0.
+*
+* A (output) @up@(doctype) array, dimension (LDA,N)
+* The m by n matrix A. Fortran77 (column-major) storage
+* assumed.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1, M).
+*
+* TESTNUM (input) INTEGER
+* Unique number for this test case, used as a basis for
+* the random seeds.
+*
+* ====================================================================
+*
+* .. External Functions ..
+ INTEGER IBTNPROCS
+ INTEGER IBTRAN
+ EXTERNAL IBTRAN, IBTNPROCS
+* ..
+* .. Local Scalars ..
+ INTEGER I, J, NPROCS, SRC
+* ..
+* .. Local Arrays ..
+ INTEGER ISEED(4)
+* ..
+* .. Executable Statements ..
+*
+* ISEED's four values must be positive integers less than 4096,
+* fourth one has to be odd. (see _LARND). Use some goofy
+* functions to come up with seed values which together should
+* be unique.
+*
+ NPROCS = IBTNPROCS()
+ SRC = MYROW * NPROCS + MYCOL
+ ISEED(1) = MOD( 1002 + TESTNUM*5 + SRC*3, 4096 )
+ ISEED(2) = MOD( 2027 + TESTNUM*7 + SRC, 4096 )
+ ISEED(3) = MOD( 1234 + TESTNUM + SRC*3, 4096 )
+ ISEED(4) = MOD( 4311 + TESTNUM*10 + SRC*2, 4096 )
+*
+ DO 10 J = 1, N
+ DO 10 I = 1, M
+ A(I, J) = IBTRAN( ISEED )
+ 10 CONTINUE
+*
+ RETURN
+*
+* End of IGENMAT.
+*
+ END
+*
+ INTEGER FUNCTION IBTRAN(ISEED)
+ INTEGER ISEED(*)
+*
+* .. External Functions ..
+ DOUBLE PRECISION DLARND
+ EXTERNAL DLARND
+* ..
+* .. Local Scalars ..
+ DOUBLE PRECISION DVAL
+* ..
+* .. Executable Statements ..
+*
+ DVAL = 1.0D6 * DLARND(2, ISEED)
+ IBTRAN = INT(DVAL)
+*
+ RETURN
+*
+* End of Ibtran
+*
+ END
+*
+ SUBROUTINE IPADMAT( UPLO, DIAG, M, N, MEM, LDA, IPRE, IPOST,
+ $ CHECKVAL )
+*
+* -- BLACS tester (version 1.0) --
+* University of Tennessee
+* December 15, 1994
+*
+* .. Scalar Arguments ..
+ CHARACTER*1 UPLO, DIAG
+ INTEGER M, N, LDA, IPRE, IPOST
+ INTEGER CHECKVAL
+* ..
+* .. Array Arguments ..
+ INTEGER MEM( * )
+* ..
+*
+* Purpose
+* =======
+*
+* IPADMAT: Pad Matrix.
+* This routines surrounds a matrix with a guardzone initialized to the
+* value CHECKVAL. There are three distinct guardzones:
+* - A contiguous zone of size IPRE immediately before the start
+* of the matrix.
+* - A contiguous zone of size IPOST immedately after the end of the
+* matrix.
+* - Interstitial zones within each column of the matrix, in the
+* elements A( M+1:LDA, J ).
+*
+* Arguments
+* =========
+* UPLO (input) CHARACTER*1
+* Is the matrix A 'U'pper or 'L'ower trapezoidal, or 'G'eneral
+* rectangular?
+*
+* DIAG (input) CHARACTER*1
+* For trapezoidal matrices, is the main diagonal included
+* ('N') or not ('U')?
+*
+* M (input) INTEGER
+* The number of rows of the matrix A. M >= 0.
+*
+* N (input) INTEGER
+* The number of columns of the matrix A. N >= 0.
+*
+* MEM (output) integer array, dimension (IPRE+IPOST+LDA*N)
+* The address IPRE elements ahead of the matrix A you want to
+* pad, which is then of dimension (LDA,N).
+*
+* IPRE (input) INTEGER
+* The size of the guard zone ahead of the matrix A.
+*
+* IPOST (input) INTEGER
+* The size of the guard zone behind the matrix A.
+*
+* CHECKVAL (input) integer
+* The value to insert into the guard zones.
+*
+* ====================================================================
+*
+* .. Local Scalars ..
+ INTEGER I, J, K
+* ..
+* .. Executable Statements ..
+*
+* Put check buffer in front of A
+*
+ IF( IPRE .GT. 0 ) THEN
+ DO 10 I = 1, IPRE
+ MEM( I ) = CHECKVAL
+ 10 CONTINUE
+ END IF
+*
+* Put check buffer in back of A
+*
+ IF( IPOST .GT. 0 ) THEN
+ J = IPRE + LDA*N + 1
+ DO 20 I = J, J+IPOST-1
+ MEM( I ) = CHECKVAL
+ 20 CONTINUE
+ END IF
+*
+* Put check buffer in all (LDA-M) gaps
+*
+ IF( LDA .GT. M ) THEN
+ K = IPRE + M + 1
+ DO 40 J = 1, N
+ DO 30 I = K, K+LDA-M-1
+ MEM( I ) = CHECKVAL
+ 30 CONTINUE
+ K = K + LDA
+ 40 CONTINUE
+ END IF
+*
+* If the matrix is upper or lower trapezoidal, calculate the
+* additional triangular area which needs to be padded, Each
+* element referred to is in the Ith row and the Jth column.
+*
+ IF( UPLO .EQ. 'U' ) THEN
+ IF( M .LE. N ) THEN
+ IF( DIAG .EQ. 'U' ) THEN
+ DO 41 I = 1, M
+ DO 42 J = 1, I
+ K = IPRE + I + (J-1)*LDA
+ MEM( K ) = CHECKVAL
+ 42 CONTINUE
+ 41 CONTINUE
+ ELSE
+ DO 43 I = 2, M
+ DO 44 J = 1, I-1
+ K = IPRE + I + (J-1)*LDA
+ MEM( K ) = CHECKVAL
+ 44 CONTINUE
+ 43 CONTINUE
+ END IF
+ ELSE
+ IF( DIAG .EQ. 'U' ) THEN
+ DO 45 I = M-N+1, M
+ DO 46 J = 1, I-(M-N)
+ K = IPRE + I + (J-1)*LDA
+ MEM( K ) = CHECKVAL
+ 46 CONTINUE
+ 45 CONTINUE
+ ELSE
+ DO 47 I = M-N+2, M
+ DO 48 J = 1, I-(M-N)-1
+ K = IPRE + I + (J-1)*LDA
+ MEM( K ) = CHECKVAL
+ 48 CONTINUE
+ 47 CONTINUE
+ END IF
+ END IF
+ ELSE IF( UPLO .EQ. 'L' ) THEN
+ IF( M .LE. N ) THEN
+ IF( DIAG .EQ. 'U' ) THEN
+ DO 49 I = 1, M
+ DO 50 J = N-M+I, N
+ K = IPRE + I + (J-1)*LDA
+ MEM( K ) = CHECKVAL
+ 50 CONTINUE
+ 49 CONTINUE
+ ELSE
+ DO 51 I = 1, M-1
+ DO 52 J = N-M+I+1, N
+ K = IPRE + I + (J-1)*LDA
+ MEM( K ) = CHECKVAL
+ 52 CONTINUE
+ 51 CONTINUE
+ END IF
+ ELSE
+ IF( UPLO .EQ. 'U' ) THEN
+ DO 53 I = 1, N
+ DO 54 J = I, N
+ K = IPRE + I + (J-1)*LDA
+ MEM( K ) = CHECKVAL
+ 54 CONTINUE
+ 53 CONTINUE
+ ELSE
+ DO 55 I = 1, N-1
+ DO 56 J = I+1, N
+ K = IPRE + I + (J-1)*LDA
+ MEM( K ) = CHECKVAL
+ 56 CONTINUE
+ 55 CONTINUE
+ END IF
+ END IF
+ END IF
+*
+* End of IPADMAT.
+*
+ RETURN
+ END
+*
+ SUBROUTINE ICHKPAD( UPLO, DIAG, M, N, MEM, LDA, RSRC, CSRC,
+ $ MYROW, MYCOL, IPRE, IPOST, CHECKVAL,
+ $ TESTNUM, MAXERR, NERR, ERRIBUF, ERRDBUF )
+*
+* -- BLACS tester (version 1.0) --
+* University of Tennessee
+* December 15, 1994
+*
+*
+* .. Scalar Arguments ..
+ CHARACTER*1 UPLO, DIAG
+ INTEGER M, N, LDA, RSRC, CSRC, MYROW, MYCOL, IPRE, IPOST
+ INTEGER TESTNUM, MAXERR, NERR
+ INTEGER CHECKVAL
+* ..
+* .. Array Arguments ..
+ INTEGER ERRIBUF(6, MAXERR)
+ INTEGER MEM(*), ERRDBUF(2, MAXERR)
+* ..
+*
+* Purpose
+* =======
+* ICHKPAD: Check padding put in by PADMAT.
+* Checks that padding around target matrix has not been overwritten
+* by the previous point-to-point or broadcast send.
+*
+* Arguments
+* =========
+* UPLO (input) CHARACTER*1
+* Is the matrix A 'U'pper or 'L'ower trapezoidal, or 'G'eneral
+* rectangular?
+*
+* DIAG (input) CHARACTER*1
+* For trapezoidal matrices, is the main diagonal included
+* ('N') or not ('U')?
+*
+* M (input) INTEGER
+* The number of rows of the matrix A. M >= 0.
+*
+* N (input) INTEGER
+* The number of columns of the matrix A. N >= 0.
+*
+* MEM (input) integer array, dimension(IPRE+IPOST+LDA*N).
+* Memory location IPRE elements in front of the matrix A.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1, M).
+*
+* RSRC (input) INTEGER
+* The process row of the source of the matrix.
+*
+* CSRC (input) INTEGER
+* The process column of the source of the matrix.
+*
+* MYROW (input) INTEGER
+* Row of this process in the process grid.
+*
+* MYCOL (input) INTEGER
+* Column of this process in the process grid.
+*
+* IPRE (input) INTEGER
+* The size of the guard zone before the start of A.
+*
+* IPOST (input) INTEGER
+* The size of guard zone after A.
+*
+* CHECKVAL (input) integer
+* The value to pad matrix with.
+*
+* TESTNUM (input) INTEGER
+* The number of the test being checked.
+*
+* MAXERR (input) INTEGER
+* Max number of errors that can be stored in ERRIBUFF or
+* ERRIBUFF
+*
+* NERR (output) INTEGER
+* The number of errors that have been found.
+*
+* ERRIBUF (output) INTEGER array, dimension (6,MAXERRS)
+* Buffer in which to store integer error information. It will
+* be built up in the following format for the call to TSEND.
+* All integer information is recorded in the following 6-tuple
+* {TESTNUM, SRC, DEST, I, J, WHAT}. These values are figured:
+* SRC = RSRC * NPROCS + CSRC
+* DEST = RDEST * NPROCS + CDEST
+* WHAT
+* = 1 : Error in pre-padding
+* = 2 : Error in post-padding
+* = 3 : Error in LDA-M gap
+* = 4 : Error in complementory triangle
+* ELSE: Error in matrix
+* If there are more errors than can fit in the error buffer,
+* the error number will indicate the actual number of errors
+* found, but the buffer will be truncated to the maximum
+* number of errors which can fit.
+*
+* ERRDBUF (output) @(doctype) array, dimension (2, MAXERRS)
+* Buffer in which to store error data information.
+* {Incorrect, Predicted}
+*
+* ===================================================================
+*
+* .. Parameters ..
+ INTEGER ERR_PRE, ERR_POST, ERR_GAP, ERR_TRI, ERR_MAT
+ PARAMETER( ERR_PRE = 1, ERR_POST = 2, ERR_GAP = 3, ERR_TRI = 4 )
+ PARAMETER( ERR_MAT = 5 )
+* ..
+* .. External Functions ..
+ INTEGER IBTNPROCS
+ EXTERNAL IBTNPROCS
+* ..
+* .. Local Scalars ..
+ LOGICAL ISTRAP
+ INTEGER I, J, K, IRST, IRND, ICST, ICND, SRC, DEST
+ INTEGER NPROCS
+* ..
+* .. Executable Statements ..
+*
+ NPROCS = IBTNPROCS()
+ SRC = RSRC * NPROCS + CSRC
+ DEST = MYROW * NPROCS + MYCOL
+*
+* Check buffer in front of A
+*
+ IF( IPRE .GT. 0 ) THEN
+ DO 10 I = 1, IPRE
+ IF( MEM(I) .NE. CHECKVAL ) THEN
+ NERR = NERR + 1
+ IF( NERR .LE. MAXERR ) THEN
+ ERRIBUF(1, NERR) = TESTNUM
+ ERRIBUF(2, NERR) = SRC
+ ERRIBUF(3, NERR) = DEST
+ ERRIBUF(4, NERR) = I
+ ERRIBUF(5, NERR) = IPRE - I + 1
+ ERRIBUF(6, NERR) = ERR_PRE
+ ERRDBUF(1, NERR) = MEM(I)
+ ERRDBUF(2, NERR) = CHECKVAL
+ END IF
+ END IF
+ 10 CONTINUE
+ END IF
+*
+* Check buffer behind A
+*
+ IF( IPOST .GT. 0 ) THEN
+ J = IPRE + LDA*N + 1
+ DO 20 I = J, J+IPOST-1
+ IF( MEM(I) .NE. CHECKVAL ) THEN
+ NERR = NERR + 1
+ IF( NERR .LE. MAXERR ) THEN
+ ERRIBUF(1, NERR) = TESTNUM
+ ERRIBUF(2, NERR) = SRC
+ ERRIBUF(3, NERR) = DEST
+ ERRIBUF(4, NERR) = I - J + 1
+ ERRIBUF(5, NERR) = J
+ ERRIBUF(6, NERR) = ERR_POST
+ ERRDBUF(1, NERR) = MEM(I)
+ ERRDBUF(2, NERR) = CHECKVAL
+ END IF
+ END IF
+ 20 CONTINUE
+ END IF
+*
+* Check all (LDA-M) gaps
+*
+ IF( LDA .GT. M ) THEN
+ DO 40 J = 1, N
+ DO 30 I = M+1, LDA
+ K = IPRE + (J-1)*LDA + I
+ IF( MEM(K) .NE. CHECKVAL) THEN
+ NERR = NERR + 1
+ IF( NERR .LE. MAXERR ) THEN
+ ERRIBUF(1, NERR) = TESTNUM
+ ERRIBUF(2, NERR) = SRC
+ ERRIBUF(3, NERR) = DEST
+ ERRIBUF(4, NERR) = I
+ ERRIBUF(5, NERR) = J
+ ERRIBUF(6, NERR) = ERR_GAP
+ ERRDBUF(1, NERR) = MEM(K)
+ ERRDBUF(2, NERR) = CHECKVAL
+ END IF
+ END IF
+ 30 CONTINUE
+ 40 CONTINUE
+ END IF
+*
+* Determine limits of trapezoidal matrix
+*
+ ISTRAP = .FALSE.
+ IF( UPLO .EQ. 'U' ) THEN
+ ISTRAP = .TRUE.
+ IF( M .LE. N ) THEN
+ IRST = 2
+ IRND = M
+ ICST = 1
+ ICND = M - 1
+ ELSEIF( M .GT. N ) THEN
+ IRST = ( M-N ) + 2
+ IRND = M
+ ICST = 1
+ ICND = N - 1
+ ENDIF
+ IF( DIAG .EQ. 'U' ) THEN
+ IRST = IRST - 1
+ ICND = ICND + 1
+ ENDIF
+ ELSE IF( UPLO .EQ. 'L' ) THEN
+ ISTRAP = .TRUE.
+ IF( M .LE. N ) THEN
+ IRST = 1
+ IRND = 1
+ ICST = ( N-M ) + 2
+ ICND = N
+ ELSEIF( M .GT. N ) THEN
+ IRST = 1
+ IRND = 1
+ ICST = 2
+ ICND = N
+ ENDIF
+ IF( DIAG .EQ. 'U' ) THEN
+ ICST = ICST - 1
+ ENDIF
+ ENDIF
+*
+* Check elements and report any errors
+*
+ IF( ISTRAP ) THEN
+ DO 100 J = ICST, ICND
+ DO 105 I = IRST, IRND
+ IF( MEM( IPRE + (J-1)*LDA + I ) .NE. CHECKVAL ) THEN
+ NERR = NERR + 1
+ IF( NERR .LE. MAXERR ) THEN
+ ERRIBUF(1, NERR) = TESTNUM
+ ERRIBUF(2, NERR) = SRC
+ ERRIBUF(3, NERR) = DEST
+ ERRIBUF(4, NERR) = I
+ ERRIBUF(5, NERR) = J
+ ERRIBUF(6, NERR) = ERR_TRI
+ ERRDBUF(1, NERR) = MEM( IPRE + (J-1)*LDA + I )
+ ERRDBUF(2, NERR) = CHECKVAL
+ END IF
+ END IF
+ 105 CONTINUE
+*
+* Update the limits to allow filling in padding
+*
+ IF( UPLO .EQ. 'U' ) THEN
+ IRST = IRST + 1
+ ELSE
+ IRND = IRND + 1
+ ENDIF
+ 100 CONTINUE
+ END IF
+*
+ RETURN
+*
+* End of ICHKPAD.
+*
+ END
+*
+ SUBROUTINE ICHKMAT( UPLO, DIAG, M, N, A, LDA, RSRC, CSRC,
+ $ MYROW, MYCOL, TESTNUM, MAXERR, NERR,
+ $ ERRIBUF, ERRDBUF )
+*
+* -- BLACS tester (version 1.0) --
+* University of Tennessee
+* December 15, 1994
+*
+*
+* .. Scalar Arguments ..
+ CHARACTER*1 UPLO, DIAG
+ INTEGER M, N, LDA, RSRC, CSRC, MYROW, MYCOL, TESTNUM
+ INTEGER MAXERR, NERR
+* ..
+* .. Array Arguments ..
+ INTEGER ERRIBUF(6, MAXERR)
+ INTEGER A(LDA,N), ERRDBUF(2, MAXERR)
+* ..
+*
+* Purpose
+* =======
+* iCHKMAT: Check matrix to see whether there were any transmission
+* errors.
+*
+* Arguments
+* =========
+* UPLO (input) CHARACTER*1
+* Is the matrix A 'U'pper or 'L'ower trapezoidal, or 'G'eneral
+* rectangular?
+*
+* DIAG (input) CHARACTER*1
+* For trapezoidal matrices, is the main diagonal included
+* ('N') or not ('U')?
+*
+* M (input) INTEGER
+* The number of rows of the matrix A. M >= 0.
+*
+* N (input) INTEGER
+* The number of columns of the matrix A. N >= 0.
+*
+* A (input) @up@(doctype) array, dimension (LDA,N)
+* The m by n matrix A. Fortran77 (column-major) storage
+* assumed.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1, M).
+*
+* RSRC (input) INTEGER
+* The process row of the source of the matrix.
+*
+* CSRC (input) INTEGER
+* The process column of the source of the matrix.
+*
+* MYROW (input) INTEGER
+* Row of this process in the process grid.
+*
+* MYCOL (input) INTEGER
+* Column of this process in the process grid.
+*
+*
+* TESTNUM (input) INTEGER
+* The number of the test being checked.
+*
+* MAXERR (input) INTEGER
+* Max number of errors that can be stored in ERRIBUFF or
+* ERRIBUFF
+*
+* NERR (output) INTEGER
+* The number of errors that have been found.
+*
+* ERRIBUF (output) INTEGER array, dimension (6,MAXERRS)
+* Buffer in which to store integer error information. It will
+* be built up in the following format for the call to TSEND.
+* All integer information is recorded in the following 6-tuple
+* {TESTNUM, SRC, DEST, I, J, WHAT}. These values are figured:
+* SRC = RSRC * NPROCS + CSRC
+* DEST = RDEST * NPROCS + CDEST
+* WHAT
+* = 1 : Error in pre-padding
+* = 2 : Error in post-padding
+* = 3 : Error in LDA-M gap
+* = 4 : Error in complementory triangle
+* ELSE: Error in matrix
+* If there are more errors than can fit in the error buffer,
+* the error number will indicate the actual number of errors
+* found, but the buffer will be truncated to the maximum
+* number of errors which can fit.
+*
+* ERRDBUF (output) @(doctype) array, dimension (2, MAXERRS)
+* Buffer in which to store error data information.
+* {Incorrect, Predicted}
+*
+* ===================================================================
+*
+* .. Local Scalars ..
+ INTEGER I, J, NPROCS, SRC, DEST
+ LOGICAL USEIT
+ INTEGER COMPVAL
+* ..
+* .. Local Arrays ..
+ INTEGER ISEED(4)
+* ..
+* .. External Functions ..
+ INTEGER IBTNPROCS
+ INTEGER IBTRAN
+ EXTERNAL IBTRAN, IBTNPROCS
+* ..
+* .. Executable Statements ..
+*
+ NPROCS = IBTNPROCS()
+ SRC = RSRC * NPROCS + CSRC
+ DEST = MYROW * NPROCS + MYCOL
+*
+* Initialize ISEED with the same values as used in IGENMAT.
+*
+ ISEED(1) = MOD( 1002 + TESTNUM*5 + SRC*3, 4096 )
+ ISEED(2) = MOD( 2027 + TESTNUM*7 + SRC, 4096 )
+ ISEED(3) = MOD( 1234 + TESTNUM + SRC*3, 4096 )
+ ISEED(4) = MOD( 4311 + TESTNUM*10 + SRC*2, 4096 )
+*
+* Generate the elements randomly with the same method used in GENMAT.
+* Note that for trapezoidal matrices, we generate all elements in the
+* enclosing rectangle and then ignore the complementary triangle.
+*
+ DO 100 J = 1, N
+ DO 105 I = 1, M
+ COMPVAL = IBTRAN( ISEED )
+*
+* Now determine whether we actually need this value. The
+* strategy is to chop out the proper triangle based on what
+* particular kind of trapezoidal matrix we're dealing with.
+*
+ USEIT = .TRUE.
+ IF( UPLO .EQ. 'U' ) THEN
+ IF( M .LE. N ) THEN
+ IF( DIAG .EQ. 'U' ) THEN
+ IF( I .GE. J ) THEN
+ USEIT = .FALSE.
+ END IF
+ ELSE
+ IF( I .GT. J ) THEN
+ USEIT = .FALSE.
+ END IF
+ END IF
+ ELSE
+ IF( DIAG .EQ. 'U' ) THEN
+ IF( I .GE. M-N+J ) THEN
+ USEIT = .FALSE.
+ END IF
+ ELSE
+ IF( I .GT. M-N+J ) THEN
+ USEIT = .FALSE.
+ END IF
+ END IF
+ END IF
+ ELSE IF( UPLO .EQ. 'L' ) THEN
+ IF( M .LE. N ) THEN
+ IF( DIAG .EQ. 'U' ) THEN
+ IF( J. GE. I+(N-M) ) THEN
+ USEIT = .FALSE.
+ END IF
+ ELSE
+ IF( J .GT. I+(N-M) ) THEN
+ USEIT = .FALSE.
+ END IF
+ END IF
+ ELSE
+ IF( DIAG .EQ. 'U' ) THEN
+ IF( J .GE. I ) THEN
+ USEIT = .FALSE.
+ END IF
+ ELSE
+ IF( J .GT. I ) THEN
+ USEIT = .FALSE.
+ END IF
+ END IF
+ END IF
+ END IF
+*
+* Compare the generated value to the one that's in the
+* received matrix. If they don't match, tack another
+* error record onto what's already there.
+*
+ IF( USEIT ) THEN
+ IF( A(I,J) .NE. COMPVAL ) THEN
+ NERR = NERR + 1
+ IF( NERR .LE. MAXERR ) THEN
+ ERRIBUF(1, NERR) = TESTNUM
+ ERRIBUF(2, NERR) = SRC
+ ERRIBUF(3, NERR) = DEST
+ ERRIBUF(4, NERR) = I
+ ERRIBUF(5, NERR) = J
+ ERRIBUF(6, NERR) = 5
+ ERRDBUF(1, NERR) = A(I, J)
+ ERRDBUF(2, NERR) = COMPVAL
+ END IF
+ END IF
+ END IF
+ 105 CONTINUE
+ 100 CONTINUE
+ RETURN
+*
+* End of ICHKMAT.
+*
+ END
+*
+ SUBROUTINE IPRINTERRS( OUTNUM, MAXERR, NERR,
+ $ ERRIBUF, ERRDBUF, COUNTING, TFAILED )
+*
+* -- BLACS tester (version 1.0) --
+* University of Tennessee
+* December 15, 1994
+*
+*
+* .. Scalar Arguments ..
+ LOGICAL COUNTING
+ INTEGER OUTNUM, MAXERR, NERR
+* ..
+* .. Array Arguments ..
+ INTEGER ERRIBUF(6, MAXERR), TFAILED(*)
+ INTEGER ERRDBUF(2, MAXERR)
+* ..
+*
+* Purpose
+* =======
+* IPRINTERRS: Print errors that have been recorded
+*
+* Arguments
+* =========
+* OUTNUM (input) INTEGER
+* Device number for output.
+*
+* MAXERR (input) INTEGER
+* Max number of errors that can be stored in ERRIBUFF or
+* ERRIBUFF
+*
+* NERR (output) INTEGER
+* The number of errors that have been found.
+*
+* ERRIBUF (output) INTEGER array, dimension (6,MAXERRS)
+* Buffer in which to store integer error information. It will
+* be built up in the following format for the call to TSEND.
+* All integer information is recorded in the following 6-tuple
+* {TESTNUM, SRC, DEST, I, J, WHAT}. These values are figured:
+* SRC = RSRC * NPROCS + CSRC
+* DEST = RDEST * NPROCS + CDEST
+* WHAT
+* = 1 : Error in pre-padding
+* = 2 : Error in post-padding
+* = 3 : Error in LDA-M gap
+* = 4 : Error in complementory triangle
+* ELSE: Error in matrix
+* If there are more errors than can fit in the error buffer,
+* the error number will indicate the actual number of errors
+* found, but the buffer will be truncated to the maximum
+* number of errors which can fit.
+*
+* ERRDBUF (output) @(doctype) array, dimension (2, MAXERRS)
+* Buffer in which to store error data information.
+* {Incorrect, Predicted}
+*
+* TFAILED (input/ourput) INTEGER array, dimension NTESTS
+* Workspace used to keep track of which tests failed.
+* This array not accessed unless COUNTING is true.
+*
+* ===================================================================
+*
+* .. Parameters ..
+ INTEGER ERR_PRE, ERR_POST, ERR_GAP, ERR_TRI, ERR_MAT
+ PARAMETER( ERR_PRE = 1, ERR_POST = 2, ERR_GAP = 3, ERR_TRI = 4 )
+ PARAMETER( ERR_MAT = 5 )
+* ..
+* .. External Functions ..
+ INTEGER IBTMYPROC, IBTNPROCS
+ EXTERNAL IBTMYPROC, IBTNPROCS
+* ..
+* .. Local Scalars ..
+ CHARACTER*1 MAT
+ LOGICAL MATISINT
+ INTEGER OLDTEST, NPROCS, PROW, PCOL, I, ERRTYPE
+* ..
+* .. Executable Statements ..
+*
+ IF( (IBTMYPROC().NE.0) .OR. (NERR.LE.0) ) RETURN
+ OLDTEST = -1
+ NPROCS = IBTNPROCS()
+ PROW = ERRIBUF(3,1) / NPROCS
+ PCOL = MOD( ERRIBUF(3,1), NPROCS )
+ IF( NERR .GT. MAXERR ) WRITE(OUTNUM,13000)
+*
+ DO 20 I = 1, MIN( NERR, MAXERR )
+ IF( ERRIBUF(1,I) .NE. OLDTEST ) THEN
+ IF( OLDTEST .NE. -1 )
+ $ WRITE(OUTNUM,12000) PROW, PCOL, OLDTEST
+ WRITE(OUTNUM,*) ' '
+ WRITE(OUTNUM,1000) PROW, PCOL, ERRIBUF(1,I)
+ IF( COUNTING ) TFAILED( ERRIBUF(1,I) ) = 1
+ OLDTEST = ERRIBUF(1, I)
+ END IF
+*
+* Print out error message depending on type of error
+*
+ ERRTYPE = ERRIBUF(6, I)
+ IF( ERRTYPE .LT. -10 ) THEN
+ ERRTYPE = -ERRTYPE - 10
+ MAT = 'C'
+ MATISINT = .TRUE.
+ ELSE IF( ERRTYPE .LT. 0 ) THEN
+ ERRTYPE = -ERRTYPE
+ MAT = 'R'
+ MATISINT = .TRUE.
+ ELSE
+ MATISINT = .FALSE.
+ END IF
+*
+* RA/CA arrays from MAX/MIN have different printing protocol
+*
+ IF( MATISINT ) THEN
+ IF( ERRIBUF(2, I) .EQ. -1 ) THEN
+ WRITE(OUTNUM,11000) ERRIBUF(4,I), ERRIBUF(5,I), MAT,
+ $ INT( ERRDBUF(2,I) ), INT( ERRDBUF(1,I) )
+ ELSE IF( ERRTYPE .EQ. ERR_PRE ) THEN
+ WRITE(OUTNUM,7000) ERRIBUF(5,I), MAT,
+ $ INT( ERRDBUF(2,I) ), INT( ERRDBUF(1,I) )
+ ELSE IF( ERRTYPE .EQ. ERR_POST ) THEN
+ WRITE(OUTNUM,8000) ERRIBUF(4,I), MAT,
+ $ INT( ERRDBUF(2,I) ), INT( ERRDBUF(1,I) )
+ ELSE IF( ERRTYPE .EQ. ERR_GAP ) THEN
+ WRITE(OUTNUM,9000) MAT, ERRIBUF(4,I), ERRIBUF(5,I),
+ $ INT( ERRDBUF(2,I) ), INT( ERRDBUF(1,I) )
+ ELSE
+ WRITE(OUTNUM,10000) MAT, ERRIBUF(4,I), ERRIBUF(5,I),
+ $ INT( ERRDBUF(2,I) ),
+ $ INT( ERRDBUF(1,I) )
+ END IF
+*
+* Have memory overwrites in matrix A
+*
+ ELSE
+ IF( ERRTYPE .EQ. ERR_PRE ) THEN
+ WRITE(OUTNUM,2000) ERRIBUF(5,I), ERRDBUF(2,I),
+ $ ERRDBUF(1,I)
+ ELSE IF( ERRTYPE .EQ. ERR_POST ) THEN
+ WRITE(OUTNUM,3000) ERRIBUF(4,I), ERRDBUF(2,I),
+ $ ERRDBUF(1,I)
+ ELSE IF( ERRTYPE .EQ. ERR_GAP ) THEN
+ WRITE(OUTNUM,4000) ERRIBUF(4,I), ERRIBUF(5,I),
+ $ ERRDBUF(2,I), ERRDBUF(1,I)
+ ELSE IF( ERRTYPE .EQ. ERR_TRI ) THEN
+ WRITE(OUTNUM,5000) ERRIBUF(4,I), ERRIBUF(5,I),
+ $ ERRDBUF(2,I), ERRDBUF(1,I)
+ ELSE
+ WRITE(OUTNUM,6000) ERRIBUF(4,I), ERRIBUF(5,I),
+ $ ERRDBUF(2,I), ERRDBUF(1,I)
+ END IF
+ END IF
+ 20 CONTINUE
+ WRITE(OUTNUM,12000) PROW, PCOL, OLDTEST
+*
+ 1000 FORMAT('PROCESS {',I4,',',I4,'} REPORTS ERRORS IN TEST#',I6,':')
+ 2000 FORMAT(' Buffer overwrite ',I4,
+ $ ' elements before the start of A:',/,
+ $ ' Expected=',I12,
+ $ '; Received=',I12)
+ 3000 FORMAT(' Buffer overwrite ',I4,' elements after the end of A:',
+ $ /,' Expected=',I12,
+ $ '; Received=',I12)
+ 4000 FORMAT(' LDA-M gap overwrite at postion (',I4,',',I4,'):',/,
+ $ ' Expected=',I12,
+ $ '; Received=',I12)
+ 5000 FORMAT(' Complementory triangle overwrite at A(',I4,',',I4,
+ $ '):',/,' Expected=',I12,
+ $ '; Received=',I12)
+ 6000 FORMAT(' Invalid element at A(',I4,',',I4,'):',/,
+ $ ' Expected=',I12,
+ $ '; Received=',I12)
+ 7000 FORMAT(' Buffer overwrite ',I4,' elements before the start of ',
+ $ A1,'A:',/,' Expected=',I12,'; Received=',I12)
+ 8000 FORMAT(' Buffer overwrite ',I4,' elements after the end of ',
+ $ A1,'A:',/,' Expected=',I12,'; Received=',I12)
+*
+ 9000 FORMAT(' LD',A1,'A-M gap overwrite at postion (',I4,',',I4,'):'
+ $ ,/,' Expected=',I12,'; Received=',I12)
+*
+10000 FORMAT(' Invalid element at ',A1,'A(',I4,',',I4,'):',/,
+ $ ' Expected=',I12,'; Received=',I12)
+11000 FORMAT(' Overwrite at position (',I4,',',I4,') of non-existent '
+ $ ,A1,'A array.',/,' Expected=',I12,'; Received=',I12)
+12000 FORMAT('PROCESS {',I4,',',I4,'} DONE ERROR REPORT FOR TEST#',
+ $ I6,'.')
+13000 FORMAT('WARNING: There were more errors than could be recorded.',
+ $ /,'Increase MEMELTS to get complete listing.')
+ RETURN
+*
+* End IPRINTERRS
+*
+ END
+*
+*
+ SUBROUTINE SBTCHECKIN( NFTESTS, OUTNUM, MAXERR, NERR, IERR,
+ $ SVAL, TFAILED )
+ INTEGER NFTESTS, OUTNUM, MAXERR, NERR
+ INTEGER IERR(*), TFAILED(*)
+ REAL SVAL(*)
+*
+* Purpose
+* =======
+* SBTCHECKIN: Process 0 receives error report from all processes.
+*
+* Arguments
+* =========
+* NFTESTS (input/output) INTEGER
+* if NFTESTS is <= 0 upon entry, NFTESTS is not written to.
+* Otherwise, on entry it specifies the total number of tests
+* run, and on exit it is the number of tests which failed.
+*
+* OUTNUM (input) INTEGER
+* Device number for output.
+*
+* MAXERR (input) INTEGER
+* Max number of errors that can be stored in ERRIBUFF or
+* ERRSBUFF
+*
+* NERR (output) INTEGER
+* The number of errors that have been found.
+*
+* ERRIBUF (output) INTEGER array, dimension (6,MAXERRS)
+* Buffer in which to store integer error information. It will
+* be built up in the following format for the call to TSEND.
+* All integer information is recorded in the following 6-tuple
+* {TESTNUM, SRC, DEST, I, J, WHAT}. These values are figured:
+* SRC = RSRC * NPROCS + CSRC
+* DEST = RDEST * NPROCS + CDEST
+* WHAT
+* = 1 : Error in pre-padding
+* = 2 : Error in post-padding
+* = 3 : Error in LDA-M gap
+* = 4 : Error in complementory triangle
+* ELSE: Error in matrix
+* If there are more errors than can fit in the error buffer,
+* the error number will indicate the actual number of errors
+* found, but the buffer will be truncated to the maximum
+* number of errors which can fit.
+*
+* ERRDBUF (output) @(doctype) array, dimension (2, MAXERRS)
+* Buffer in which to store error data information.
+* {Incorrect, Predicted}
+*
+* TFAILED (workspace) INTEGER array, dimension NFTESTS
+* Workspace used to keep track of which tests failed.
+* If input of NFTESTS < 1, this array not accessed.
+*
+* ===================================================================
+*
+* .. External Functions ..
+ INTEGER IBTMYPROC, IBTNPROCS, IBTMSGID
+ EXTERNAL IBTMYPROC, IBTNPROCS, IBTMSGID
+* ..
+* .. Local Scalars ..
+ LOGICAL COUNTING
+ INTEGER K, NERR2, IAM, NPROCS, NTESTS
+*
+* Proc 0 collects error info from everyone
+*
+ IAM = IBTMYPROC()
+ NPROCS = IBTNPROCS()
+*
+ IF( IAM .EQ. 0 ) THEN
+*
+* If we are finding out how many failed tests there are, initialize
+* the total number of tests (NTESTS), and zero the test failed array
+*
+ COUNTING = NFTESTS .GT. 0
+ IF( COUNTING ) THEN
+ NTESTS = NFTESTS
+ DO 10 K = 1, NTESTS
+ TFAILED(K) = 0
+ 10 CONTINUE
+ END IF
+*
+ CALL SPRINTERRS(OUTNUM, MAXERR, NERR, IERR, SVAL, COUNTING,
+ $ TFAILED)
+*
+ DO 20 K = 1, NPROCS-1
+ CALL BTSEND(3, 0, K, K, IBTMSGID()+50)
+ CALL BTRECV(3, 1, NERR2, K, IBTMSGID()+50)
+ IF( NERR2 .GT. 0 ) THEN
+ NERR = NERR + NERR2
+ CALL BTRECV(3, NERR2*6, IERR, K, IBTMSGID()+51)
+ CALL BTRECV(4, NERR2*2, SVAL, K, IBTMSGID()+51)
+ CALL SPRINTERRS(OUTNUM, MAXERR, NERR2, IERR, SVAL,
+ $ COUNTING, TFAILED)
+ END IF
+ 20 CONTINUE
+*
+* Count up number of tests that failed
+*
+ IF( COUNTING ) THEN
+ NFTESTS = 0
+ DO 30 K = 1, NTESTS
+ NFTESTS = NFTESTS + TFAILED(K)
+ 30 CONTINUE
+ END IF
+*
+* Send my error info to proc 0
+*
+ ELSE
+ CALL BTRECV(3, 0, K, 0, IBTMSGID()+50)
+ CALL BTSEND(3, 1, NERR, 0, IBTMSGID()+50)
+ IF( NERR .GT. 0 ) THEN
+ CALL BTSEND(3, NERR*6, IERR, 0, IBTMSGID()+51)
+ CALL BTSEND(4, NERR*2, SVAL, 0, IBTMSGID()+51)
+ END IF
+ ENDIF
+*
+ RETURN
+*
+* End of SBTCHECKIN
+*
+ END
+*
+ SUBROUTINE SINITMAT(UPLO, DIAG, M, N, MEM, LDA, IPRE, IPOST,
+ $ CHECKVAL, TESTNUM, MYROW, MYCOL)
+ CHARACTER*1 UPLO, DIAG
+ INTEGER M, N, LDA, IPRE, IPOST, TESTNUM, MYROW, MYCOL
+ REAL CHECKVAL
+ REAL MEM(*)
+*
+* .. External Subroutines ..
+ EXTERNAL SGENMAT, SPADMAT
+* ..
+* .. Executable Statements ..
+*
+ CALL SGENMAT( M, N, MEM(IPRE+1), LDA, TESTNUM, MYROW, MYCOL )
+ CALL SPADMAT( UPLO, DIAG, M, N, MEM, LDA, IPRE, IPOST, CHECKVAL )
+*
+ RETURN
+ END
+*
+ SUBROUTINE SGENMAT( M, N, A, LDA, TESTNUM, MYROW, MYCOL )
+*
+* -- BLACS tester (version 1.0) --
+* University of Tennessee
+* December 15, 1994
+*
+*
+* .. Scalar Arguments ..
+ INTEGER M, N, LDA, TESTNUM, MYROW, MYCOL
+* ..
+* .. Array Arguments ..
+ REAL A(LDA,N)
+* ..
+*
+* Purpose
+* =======
+* SGENMAT: Generates an M-by-N matrix filled with random elements.
+*
+* Arguments
+* =========
+* M (input) INTEGER
+* The number of rows of the matrix A. M >= 0.
+*
+* N (input) INTEGER
+* The number of columns of the matrix A. N >= 0.
+*
+* A (output) @up@(doctype) array, dimension (LDA,N)
+* The m by n matrix A. Fortran77 (column-major) storage
+* assumed.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1, M).
+*
+* TESTNUM (input) INTEGER
+* Unique number for this test case, used as a basis for
+* the random seeds.
+*
+* ====================================================================
+*
+* .. External Functions ..
+ INTEGER IBTNPROCS
+ REAL SBTRAN
+ EXTERNAL SBTRAN, IBTNPROCS
+* ..
+* .. Local Scalars ..
+ INTEGER I, J, NPROCS, SRC
+* ..
+* .. Local Arrays ..
+ INTEGER ISEED(4)
+* ..
+* .. Executable Statements ..
+*
+* ISEED's four values must be positive integers less than 4096,
+* fourth one has to be odd. (see _LARND). Use some goofy
+* functions to come up with seed values which together should
+* be unique.
+*
+ NPROCS = IBTNPROCS()
+ SRC = MYROW * NPROCS + MYCOL
+ ISEED(1) = MOD( 1002 + TESTNUM*5 + SRC*3, 4096 )
+ ISEED(2) = MOD( 2027 + TESTNUM*7 + SRC, 4096 )
+ ISEED(3) = MOD( 1234 + TESTNUM + SRC*3, 4096 )
+ ISEED(4) = MOD( 4311 + TESTNUM*10 + SRC*2, 4096 )
+*
+ DO 10 J = 1, N
+ DO 10 I = 1, M
+ A(I, J) = SBTRAN( ISEED )
+ 10 CONTINUE
+*
+ RETURN
+*
+* End of SGENMAT.
+*
+ END
+*
+ REAL FUNCTION SBTRAN(ISEED)
+ INTEGER ISEED(*)
+*
+* .. External Functions ..
+ DOUBLE PRECISION DLARND
+ EXTERNAL DLARND
+* .. Executable Statements ..
+*
+ SBTRAN = REAL( DLARND(2, ISEED) )
+*
+ RETURN
+*
+* End of Sbtran
+*
+ END
+*
+ SUBROUTINE SPADMAT( UPLO, DIAG, M, N, MEM, LDA, IPRE, IPOST,
+ $ CHECKVAL )
+*
+* -- BLACS tester (version 1.0) --
+* University of Tennessee
+* December 15, 1994
+*
+* .. Scalar Arguments ..
+ CHARACTER*1 UPLO, DIAG
+ INTEGER M, N, LDA, IPRE, IPOST
+ REAL CHECKVAL
+* ..
+* .. Array Arguments ..
+ REAL MEM( * )
+* ..
+*
+* Purpose
+* =======
+*
+* SPADMAT: Pad Matrix.
+* This routines surrounds a matrix with a guardzone initialized to the
+* value CHECKVAL. There are three distinct guardzones:
+* - A contiguous zone of size IPRE immediately before the start
+* of the matrix.
+* - A contiguous zone of size IPOST immedately after the end of the
+* matrix.
+* - Interstitial zones within each column of the matrix, in the
+* elements A( M+1:LDA, J ).
+*
+* Arguments
+* =========
+* UPLO (input) CHARACTER*1
+* Is the matrix A 'U'pper or 'L'ower trapezoidal, or 'G'eneral
+* rectangular?
+*
+* DIAG (input) CHARACTER*1
+* For trapezoidal matrices, is the main diagonal included
+* ('N') or not ('U')?
+*
+* M (input) INTEGER
+* The number of rows of the matrix A. M >= 0.
+*
+* N (input) INTEGER
+* The number of columns of the matrix A. N >= 0.
+*
+* MEM (output) real array, dimension (IPRE+IPOST+LDA*N)
+* The address IPRE elements ahead of the matrix A you want to
+* pad, which is then of dimension (LDA,N).
+*
+* IPRE (input) INTEGER
+* The size of the guard zone ahead of the matrix A.
+*
+* IPOST (input) INTEGER
+* The size of the guard zone behind the matrix A.
+*
+* CHECKVAL (input) real
+* The value to insert into the guard zones.
+*
+* ====================================================================
+*
+* .. Local Scalars ..
+ INTEGER I, J, K
+* ..
+* .. Executable Statements ..
+*
+* Put check buffer in front of A
+*
+ IF( IPRE .GT. 0 ) THEN
+ DO 10 I = 1, IPRE
+ MEM( I ) = CHECKVAL
+ 10 CONTINUE
+ END IF
+*
+* Put check buffer in back of A
+*
+ IF( IPOST .GT. 0 ) THEN
+ J = IPRE + LDA*N + 1
+ DO 20 I = J, J+IPOST-1
+ MEM( I ) = CHECKVAL
+ 20 CONTINUE
+ END IF
+*
+* Put check buffer in all (LDA-M) gaps
+*
+ IF( LDA .GT. M ) THEN
+ K = IPRE + M + 1
+ DO 40 J = 1, N
+ DO 30 I = K, K+LDA-M-1
+ MEM( I ) = CHECKVAL
+ 30 CONTINUE
+ K = K + LDA
+ 40 CONTINUE
+ END IF
+*
+* If the matrix is upper or lower trapezoidal, calculate the
+* additional triangular area which needs to be padded, Each
+* element referred to is in the Ith row and the Jth column.
+*
+ IF( UPLO .EQ. 'U' ) THEN
+ IF( M .LE. N ) THEN
+ IF( DIAG .EQ. 'U' ) THEN
+ DO 41 I = 1, M
+ DO 42 J = 1, I
+ K = IPRE + I + (J-1)*LDA
+ MEM( K ) = CHECKVAL
+ 42 CONTINUE
+ 41 CONTINUE
+ ELSE
+ DO 43 I = 2, M
+ DO 44 J = 1, I-1
+ K = IPRE + I + (J-1)*LDA
+ MEM( K ) = CHECKVAL
+ 44 CONTINUE
+ 43 CONTINUE
+ END IF
+ ELSE
+ IF( DIAG .EQ. 'U' ) THEN
+ DO 45 I = M-N+1, M
+ DO 46 J = 1, I-(M-N)
+ K = IPRE + I + (J-1)*LDA
+ MEM( K ) = CHECKVAL
+ 46 CONTINUE
+ 45 CONTINUE
+ ELSE
+ DO 47 I = M-N+2, M
+ DO 48 J = 1, I-(M-N)-1
+ K = IPRE + I + (J-1)*LDA
+ MEM( K ) = CHECKVAL
+ 48 CONTINUE
+ 47 CONTINUE
+ END IF
+ END IF
+ ELSE IF( UPLO .EQ. 'L' ) THEN
+ IF( M .LE. N ) THEN
+ IF( DIAG .EQ. 'U' ) THEN
+ DO 49 I = 1, M
+ DO 50 J = N-M+I, N
+ K = IPRE + I + (J-1)*LDA
+ MEM( K ) = CHECKVAL
+ 50 CONTINUE
+ 49 CONTINUE
+ ELSE
+ DO 51 I = 1, M-1
+ DO 52 J = N-M+I+1, N
+ K = IPRE + I + (J-1)*LDA
+ MEM( K ) = CHECKVAL
+ 52 CONTINUE
+ 51 CONTINUE
+ END IF
+ ELSE
+ IF( UPLO .EQ. 'U' ) THEN
+ DO 53 I = 1, N
+ DO 54 J = I, N
+ K = IPRE + I + (J-1)*LDA
+ MEM( K ) = CHECKVAL
+ 54 CONTINUE
+ 53 CONTINUE
+ ELSE
+ DO 55 I = 1, N-1
+ DO 56 J = I+1, N
+ K = IPRE + I + (J-1)*LDA
+ MEM( K ) = CHECKVAL
+ 56 CONTINUE
+ 55 CONTINUE
+ END IF
+ END IF
+ END IF
+*
+* End of SPADMAT.
+*
+ RETURN
+ END
+*
+ SUBROUTINE SCHKPAD( UPLO, DIAG, M, N, MEM, LDA, RSRC, CSRC,
+ $ MYROW, MYCOL, IPRE, IPOST, CHECKVAL,
+ $ TESTNUM, MAXERR, NERR, ERRIBUF, ERRDBUF )
+*
+* -- BLACS tester (version 1.0) --
+* University of Tennessee
+* December 15, 1994
+*
+*
+* .. Scalar Arguments ..
+ CHARACTER*1 UPLO, DIAG
+ INTEGER M, N, LDA, RSRC, CSRC, MYROW, MYCOL, IPRE, IPOST
+ INTEGER TESTNUM, MAXERR, NERR
+ REAL CHECKVAL
+* ..
+* .. Array Arguments ..
+ INTEGER ERRIBUF(6, MAXERR)
+ REAL MEM(*), ERRDBUF(2, MAXERR)
+* ..
+*
+* Purpose
+* =======
+* SCHKPAD: Check padding put in by PADMAT.
+* Checks that padding around target matrix has not been overwritten
+* by the previous point-to-point or broadcast send.
+*
+* Arguments
+* =========
+* UPLO (input) CHARACTER*1
+* Is the matrix A 'U'pper or 'L'ower trapezoidal, or 'G'eneral
+* rectangular?
+*
+* DIAG (input) CHARACTER*1
+* For trapezoidal matrices, is the main diagonal included
+* ('N') or not ('U')?
+*
+* M (input) INTEGER
+* The number of rows of the matrix A. M >= 0.
+*
+* N (input) INTEGER
+* The number of columns of the matrix A. N >= 0.
+*
+* MEM (input) real array, dimension(IPRE+IPOST+LDA*N).
+* Memory location IPRE elements in front of the matrix A.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1, M).
+*
+* RSRC (input) INTEGER
+* The process row of the source of the matrix.
+*
+* CSRC (input) INTEGER
+* The process column of the source of the matrix.
+*
+* MYROW (input) INTEGER
+* Row of this process in the process grid.
+*
+* MYCOL (input) INTEGER
+* Column of this process in the process grid.
+*
+* IPRE (input) INTEGER
+* The size of the guard zone before the start of A.
+*
+* IPOST (input) INTEGER
+* The size of guard zone after A.
+*
+* CHECKVAL (input) real
+* The value to pad matrix with.
+*
+* TESTNUM (input) INTEGER
+* The number of the test being checked.
+*
+* MAXERR (input) INTEGER
+* Max number of errors that can be stored in ERRIBUFF or
+* ERRSBUFF
+*
+* NERR (output) INTEGER
+* The number of errors that have been found.
+*
+* ERRIBUF (output) INTEGER array, dimension (6,MAXERRS)
+* Buffer in which to store integer error information. It will
+* be built up in the following format for the call to TSEND.
+* All integer information is recorded in the following 6-tuple
+* {TESTNUM, SRC, DEST, I, J, WHAT}. These values are figured:
+* SRC = RSRC * NPROCS + CSRC
+* DEST = RDEST * NPROCS + CDEST
+* WHAT
+* = 1 : Error in pre-padding
+* = 2 : Error in post-padding
+* = 3 : Error in LDA-M gap
+* = 4 : Error in complementory triangle
+* ELSE: Error in matrix
+* If there are more errors than can fit in the error buffer,
+* the error number will indicate the actual number of errors
+* found, but the buffer will be truncated to the maximum
+* number of errors which can fit.
+*
+* ERRDBUF (output) @(doctype) array, dimension (2, MAXERRS)
+* Buffer in which to store error data information.
+* {Incorrect, Predicted}
+*
+* ===================================================================
+*
+* .. Parameters ..
+ INTEGER ERR_PRE, ERR_POST, ERR_GAP, ERR_TRI, ERR_MAT
+ PARAMETER( ERR_PRE = 1, ERR_POST = 2, ERR_GAP = 3, ERR_TRI = 4 )
+ PARAMETER( ERR_MAT = 5 )
+* ..
+* .. External Functions ..
+ INTEGER IBTNPROCS
+ EXTERNAL IBTNPROCS
+* ..
+* .. Local Scalars ..
+ LOGICAL ISTRAP
+ INTEGER I, J, K, IRST, IRND, ICST, ICND, SRC, DEST
+ INTEGER NPROCS
+* ..
+* .. Executable Statements ..
+*
+ NPROCS = IBTNPROCS()
+ SRC = RSRC * NPROCS + CSRC
+ DEST = MYROW * NPROCS + MYCOL
+*
+* Check buffer in front of A
+*
+ IF( IPRE .GT. 0 ) THEN
+ DO 10 I = 1, IPRE
+ IF( MEM(I) .NE. CHECKVAL ) THEN
+ NERR = NERR + 1
+ IF( NERR .LE. MAXERR ) THEN
+ ERRIBUF(1, NERR) = TESTNUM
+ ERRIBUF(2, NERR) = SRC
+ ERRIBUF(3, NERR) = DEST
+ ERRIBUF(4, NERR) = I
+ ERRIBUF(5, NERR) = IPRE - I + 1
+ ERRIBUF(6, NERR) = ERR_PRE
+ ERRDBUF(1, NERR) = MEM(I)
+ ERRDBUF(2, NERR) = CHECKVAL
+ END IF
+ END IF
+ 10 CONTINUE
+ END IF
+*
+* Check buffer behind A
+*
+ IF( IPOST .GT. 0 ) THEN
+ J = IPRE + LDA*N + 1
+ DO 20 I = J, J+IPOST-1
+ IF( MEM(I) .NE. CHECKVAL ) THEN
+ NERR = NERR + 1
+ IF( NERR .LE. MAXERR ) THEN
+ ERRIBUF(1, NERR) = TESTNUM
+ ERRIBUF(2, NERR) = SRC
+ ERRIBUF(3, NERR) = DEST
+ ERRIBUF(4, NERR) = I - J + 1
+ ERRIBUF(5, NERR) = J
+ ERRIBUF(6, NERR) = ERR_POST
+ ERRDBUF(1, NERR) = MEM(I)
+ ERRDBUF(2, NERR) = CHECKVAL
+ END IF
+ END IF
+ 20 CONTINUE
+ END IF
+*
+* Check all (LDA-M) gaps
+*
+ IF( LDA .GT. M ) THEN
+ DO 40 J = 1, N
+ DO 30 I = M+1, LDA
+ K = IPRE + (J-1)*LDA + I
+ IF( MEM(K) .NE. CHECKVAL) THEN
+ NERR = NERR + 1
+ IF( NERR .LE. MAXERR ) THEN
+ ERRIBUF(1, NERR) = TESTNUM
+ ERRIBUF(2, NERR) = SRC
+ ERRIBUF(3, NERR) = DEST
+ ERRIBUF(4, NERR) = I
+ ERRIBUF(5, NERR) = J
+ ERRIBUF(6, NERR) = ERR_GAP
+ ERRDBUF(1, NERR) = MEM(K)
+ ERRDBUF(2, NERR) = CHECKVAL
+ END IF
+ END IF
+ 30 CONTINUE
+ 40 CONTINUE
+ END IF
+*
+* Determine limits of trapezoidal matrix
+*
+ ISTRAP = .FALSE.
+ IF( UPLO .EQ. 'U' ) THEN
+ ISTRAP = .TRUE.
+ IF( M .LE. N ) THEN
+ IRST = 2
+ IRND = M
+ ICST = 1
+ ICND = M - 1
+ ELSEIF( M .GT. N ) THEN
+ IRST = ( M-N ) + 2
+ IRND = M
+ ICST = 1
+ ICND = N - 1
+ ENDIF
+ IF( DIAG .EQ. 'U' ) THEN
+ IRST = IRST - 1
+ ICND = ICND + 1
+ ENDIF
+ ELSE IF( UPLO .EQ. 'L' ) THEN
+ ISTRAP = .TRUE.
+ IF( M .LE. N ) THEN
+ IRST = 1
+ IRND = 1
+ ICST = ( N-M ) + 2
+ ICND = N
+ ELSEIF( M .GT. N ) THEN
+ IRST = 1
+ IRND = 1
+ ICST = 2
+ ICND = N
+ ENDIF
+ IF( DIAG .EQ. 'U' ) THEN
+ ICST = ICST - 1
+ ENDIF
+ ENDIF
+*
+* Check elements and report any errors
+*
+ IF( ISTRAP ) THEN
+ DO 100 J = ICST, ICND
+ DO 105 I = IRST, IRND
+ IF( MEM( IPRE + (J-1)*LDA + I ) .NE. CHECKVAL ) THEN
+ NERR = NERR + 1
+ IF( NERR .LE. MAXERR ) THEN
+ ERRIBUF(1, NERR) = TESTNUM
+ ERRIBUF(2, NERR) = SRC
+ ERRIBUF(3, NERR) = DEST
+ ERRIBUF(4, NERR) = I
+ ERRIBUF(5, NERR) = J
+ ERRIBUF(6, NERR) = ERR_TRI
+ ERRDBUF(1, NERR) = MEM( IPRE + (J-1)*LDA + I )
+ ERRDBUF(2, NERR) = CHECKVAL
+ END IF
+ END IF
+ 105 CONTINUE
+*
+* Update the limits to allow filling in padding
+*
+ IF( UPLO .EQ. 'U' ) THEN
+ IRST = IRST + 1
+ ELSE
+ IRND = IRND + 1
+ ENDIF
+ 100 CONTINUE
+ END IF
+*
+ RETURN
+*
+* End of SCHKPAD.
+*
+ END
+*
+ SUBROUTINE SCHKMAT( UPLO, DIAG, M, N, A, LDA, RSRC, CSRC,
+ $ MYROW, MYCOL, TESTNUM, MAXERR, NERR,
+ $ ERRIBUF, ERRDBUF )
+*
+* -- BLACS tester (version 1.0) --
+* University of Tennessee
+* December 15, 1994
+*
+*
+* .. Scalar Arguments ..
+ CHARACTER*1 UPLO, DIAG
+ INTEGER M, N, LDA, RSRC, CSRC, MYROW, MYCOL, TESTNUM
+ INTEGER MAXERR, NERR
+* ..
+* .. Array Arguments ..
+ INTEGER ERRIBUF(6, MAXERR)
+ REAL A(LDA,N), ERRDBUF(2, MAXERR)
+* ..
+*
+* Purpose
+* =======
+* sCHKMAT: Check matrix to see whether there were any transmission
+* errors.
+*
+* Arguments
+* =========
+* UPLO (input) CHARACTER*1
+* Is the matrix A 'U'pper or 'L'ower trapezoidal, or 'G'eneral
+* rectangular?
+*
+* DIAG (input) CHARACTER*1
+* For trapezoidal matrices, is the main diagonal included
+* ('N') or not ('U')?
+*
+* M (input) INTEGER
+* The number of rows of the matrix A. M >= 0.
+*
+* N (input) INTEGER
+* The number of columns of the matrix A. N >= 0.
+*
+* A (input) @up@(doctype) array, dimension (LDA,N)
+* The m by n matrix A. Fortran77 (column-major) storage
+* assumed.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1, M).
+*
+* RSRC (input) INTEGER
+* The process row of the source of the matrix.
+*
+* CSRC (input) INTEGER
+* The process column of the source of the matrix.
+*
+* MYROW (input) INTEGER
+* Row of this process in the process grid.
+*
+* MYCOL (input) INTEGER
+* Column of this process in the process grid.
+*
+*
+* TESTNUM (input) INTEGER
+* The number of the test being checked.
+*
+* MAXERR (input) INTEGER
+* Max number of errors that can be stored in ERRIBUFF or
+* ERRSBUFF
+*
+* NERR (output) INTEGER
+* The number of errors that have been found.
+*
+* ERRIBUF (output) INTEGER array, dimension (6,MAXERRS)
+* Buffer in which to store integer error information. It will
+* be built up in the following format for the call to TSEND.
+* All integer information is recorded in the following 6-tuple
+* {TESTNUM, SRC, DEST, I, J, WHAT}. These values are figured:
+* SRC = RSRC * NPROCS + CSRC
+* DEST = RDEST * NPROCS + CDEST
+* WHAT
+* = 1 : Error in pre-padding
+* = 2 : Error in post-padding
+* = 3 : Error in LDA-M gap
+* = 4 : Error in complementory triangle
+* ELSE: Error in matrix
+* If there are more errors than can fit in the error buffer,
+* the error number will indicate the actual number of errors
+* found, but the buffer will be truncated to the maximum
+* number of errors which can fit.
+*
+* ERRDBUF (output) @(doctype) array, dimension (2, MAXERRS)
+* Buffer in which to store error data information.
+* {Incorrect, Predicted}
+*
+* ===================================================================
+*
+* .. Local Scalars ..
+ INTEGER I, J, NPROCS, SRC, DEST
+ LOGICAL USEIT
+ REAL COMPVAL
+* ..
+* .. Local Arrays ..
+ INTEGER ISEED(4)
+* ..
+* .. External Functions ..
+ INTEGER IBTNPROCS
+ REAL SBTRAN
+ EXTERNAL SBTRAN, IBTNPROCS
+* ..
+* .. Executable Statements ..
+*
+ NPROCS = IBTNPROCS()
+ SRC = RSRC * NPROCS + CSRC
+ DEST = MYROW * NPROCS + MYCOL
+*
+* Initialize ISEED with the same values as used in SGENMAT.
+*
+ ISEED(1) = MOD( 1002 + TESTNUM*5 + SRC*3, 4096 )
+ ISEED(2) = MOD( 2027 + TESTNUM*7 + SRC, 4096 )
+ ISEED(3) = MOD( 1234 + TESTNUM + SRC*3, 4096 )
+ ISEED(4) = MOD( 4311 + TESTNUM*10 + SRC*2, 4096 )
+*
+* Generate the elements randomly with the same method used in GENMAT.
+* Note that for trapezoidal matrices, we generate all elements in the
+* enclosing rectangle and then ignore the complementary triangle.
+*
+ DO 100 J = 1, N
+ DO 105 I = 1, M
+ COMPVAL = SBTRAN( ISEED )
+*
+* Now determine whether we actually need this value. The
+* strategy is to chop out the proper triangle based on what
+* particular kind of trapezoidal matrix we're dealing with.
+*
+ USEIT = .TRUE.
+ IF( UPLO .EQ. 'U' ) THEN
+ IF( M .LE. N ) THEN
+ IF( DIAG .EQ. 'U' ) THEN
+ IF( I .GE. J ) THEN
+ USEIT = .FALSE.
+ END IF
+ ELSE
+ IF( I .GT. J ) THEN
+ USEIT = .FALSE.
+ END IF
+ END IF
+ ELSE
+ IF( DIAG .EQ. 'U' ) THEN
+ IF( I .GE. M-N+J ) THEN
+ USEIT = .FALSE.
+ END IF
+ ELSE
+ IF( I .GT. M-N+J ) THEN
+ USEIT = .FALSE.
+ END IF
+ END IF
+ END IF
+ ELSE IF( UPLO .EQ. 'L' ) THEN
+ IF( M .LE. N ) THEN
+ IF( DIAG .EQ. 'U' ) THEN
+ IF( J. GE. I+(N-M) ) THEN
+ USEIT = .FALSE.
+ END IF
+ ELSE
+ IF( J .GT. I+(N-M) ) THEN
+ USEIT = .FALSE.
+ END IF
+ END IF
+ ELSE
+ IF( DIAG .EQ. 'U' ) THEN
+ IF( J .GE. I ) THEN
+ USEIT = .FALSE.
+ END IF
+ ELSE
+ IF( J .GT. I ) THEN
+ USEIT = .FALSE.
+ END IF
+ END IF
+ END IF
+ END IF
+*
+* Compare the generated value to the one that's in the
+* received matrix. If they don't match, tack another
+* error record onto what's already there.
+*
+ IF( USEIT ) THEN
+ IF( A(I,J) .NE. COMPVAL ) THEN
+ NERR = NERR + 1
+ IF( NERR .LE. MAXERR ) THEN
+ ERRIBUF(1, NERR) = TESTNUM
+ ERRIBUF(2, NERR) = SRC
+ ERRIBUF(3, NERR) = DEST
+ ERRIBUF(4, NERR) = I
+ ERRIBUF(5, NERR) = J
+ ERRIBUF(6, NERR) = 5
+ ERRDBUF(1, NERR) = A(I, J)
+ ERRDBUF(2, NERR) = COMPVAL
+ END IF
+ END IF
+ END IF
+ 105 CONTINUE
+ 100 CONTINUE
+ RETURN
+*
+* End of SCHKMAT.
+*
+ END
+*
+ SUBROUTINE SPRINTERRS( OUTNUM, MAXERR, NERR,
+ $ ERRIBUF, ERRDBUF, COUNTING, TFAILED )
+*
+* -- BLACS tester (version 1.0) --
+* University of Tennessee
+* December 15, 1994
+*
+*
+* .. Scalar Arguments ..
+ LOGICAL COUNTING
+ INTEGER OUTNUM, MAXERR, NERR
+* ..
+* .. Array Arguments ..
+ INTEGER ERRIBUF(6, MAXERR), TFAILED(*)
+ REAL ERRDBUF(2, MAXERR)
+* ..
+*
+* Purpose
+* =======
+* SPRINTERRS: Print errors that have been recorded
+*
+* Arguments
+* =========
+* OUTNUM (input) INTEGER
+* Device number for output.
+*
+* MAXERR (input) INTEGER
+* Max number of errors that can be stored in ERRIBUFF or
+* ERRSBUFF
+*
+* NERR (output) INTEGER
+* The number of errors that have been found.
+*
+* ERRIBUF (output) INTEGER array, dimension (6,MAXERRS)
+* Buffer in which to store integer error information. It will
+* be built up in the following format for the call to TSEND.
+* All integer information is recorded in the following 6-tuple
+* {TESTNUM, SRC, DEST, I, J, WHAT}. These values are figured:
+* SRC = RSRC * NPROCS + CSRC
+* DEST = RDEST * NPROCS + CDEST
+* WHAT
+* = 1 : Error in pre-padding
+* = 2 : Error in post-padding
+* = 3 : Error in LDA-M gap
+* = 4 : Error in complementory triangle
+* ELSE: Error in matrix
+* If there are more errors than can fit in the error buffer,
+* the error number will indicate the actual number of errors
+* found, but the buffer will be truncated to the maximum
+* number of errors which can fit.
+*
+* ERRDBUF (output) @(doctype) array, dimension (2, MAXERRS)
+* Buffer in which to store error data information.
+* {Incorrect, Predicted}
+*
+* TFAILED (input/ourput) INTEGER array, dimension NTESTS
+* Workspace used to keep track of which tests failed.
+* This array not accessed unless COUNTING is true.
+*
+* ===================================================================
+*
+* .. Parameters ..
+ INTEGER ERR_PRE, ERR_POST, ERR_GAP, ERR_TRI, ERR_MAT
+ PARAMETER( ERR_PRE = 1, ERR_POST = 2, ERR_GAP = 3, ERR_TRI = 4 )
+ PARAMETER( ERR_MAT = 5 )
+* ..
+* .. External Functions ..
+ INTEGER IBTMYPROC, IBTNPROCS
+ EXTERNAL IBTMYPROC, IBTNPROCS
+* ..
+* .. Local Scalars ..
+ CHARACTER*1 MAT
+ LOGICAL MATISINT
+ INTEGER OLDTEST, NPROCS, PROW, PCOL, I, ERRTYPE
+* ..
+* .. Executable Statements ..
+*
+ IF( (IBTMYPROC().NE.0) .OR. (NERR.LE.0) ) RETURN
+ OLDTEST = -1
+ NPROCS = IBTNPROCS()
+ PROW = ERRIBUF(3,1) / NPROCS
+ PCOL = MOD( ERRIBUF(3,1), NPROCS )
+ IF( NERR .GT. MAXERR ) WRITE(OUTNUM,13000)
+*
+ DO 20 I = 1, MIN( NERR, MAXERR )
+ IF( ERRIBUF(1,I) .NE. OLDTEST ) THEN
+ IF( OLDTEST .NE. -1 )
+ $ WRITE(OUTNUM,12000) PROW, PCOL, OLDTEST
+ WRITE(OUTNUM,*) ' '
+ WRITE(OUTNUM,1000) PROW, PCOL, ERRIBUF(1,I)
+ IF( COUNTING ) TFAILED( ERRIBUF(1,I) ) = 1
+ OLDTEST = ERRIBUF(1, I)
+ END IF
+*
+* Print out error message depending on type of error
+*
+ ERRTYPE = ERRIBUF(6, I)
+ IF( ERRTYPE .LT. -10 ) THEN
+ ERRTYPE = -ERRTYPE - 10
+ MAT = 'C'
+ MATISINT = .TRUE.
+ ELSE IF( ERRTYPE .LT. 0 ) THEN
+ ERRTYPE = -ERRTYPE
+ MAT = 'R'
+ MATISINT = .TRUE.
+ ELSE
+ MATISINT = .FALSE.
+ END IF
+*
+* RA/CA arrays from MAX/MIN have different printing protocol
+*
+ IF( MATISINT ) THEN
+ IF( ERRIBUF(2, I) .EQ. -1 ) THEN
+ WRITE(OUTNUM,11000) ERRIBUF(4,I), ERRIBUF(5,I), MAT,
+ $ INT( ERRDBUF(2,I) ), INT( ERRDBUF(1,I) )
+ ELSE IF( ERRTYPE .EQ. ERR_PRE ) THEN
+ WRITE(OUTNUM,7000) ERRIBUF(5,I), MAT,
+ $ INT( ERRDBUF(2,I) ), INT( ERRDBUF(1,I) )
+ ELSE IF( ERRTYPE .EQ. ERR_POST ) THEN
+ WRITE(OUTNUM,8000) ERRIBUF(4,I), MAT,
+ $ INT( ERRDBUF(2,I) ), INT( ERRDBUF(1,I) )
+ ELSE IF( ERRTYPE .EQ. ERR_GAP ) THEN
+ WRITE(OUTNUM,9000) MAT, ERRIBUF(4,I), ERRIBUF(5,I),
+ $ INT( ERRDBUF(2,I) ), INT( ERRDBUF(1,I) )
+ ELSE
+ WRITE(OUTNUM,10000) MAT, ERRIBUF(4,I), ERRIBUF(5,I),
+ $ INT( ERRDBUF(2,I) ),
+ $ INT( ERRDBUF(1,I) )
+ END IF
+*
+* Have memory overwrites in matrix A
+*
+ ELSE
+ IF( ERRTYPE .EQ. ERR_PRE ) THEN
+ WRITE(OUTNUM,2000) ERRIBUF(5,I), ERRDBUF(2,I),
+ $ ERRDBUF(1,I)
+ ELSE IF( ERRTYPE .EQ. ERR_POST ) THEN
+ WRITE(OUTNUM,3000) ERRIBUF(4,I), ERRDBUF(2,I),
+ $ ERRDBUF(1,I)
+ ELSE IF( ERRTYPE .EQ. ERR_GAP ) THEN
+ WRITE(OUTNUM,4000) ERRIBUF(4,I), ERRIBUF(5,I),
+ $ ERRDBUF(2,I), ERRDBUF(1,I)
+ ELSE IF( ERRTYPE .EQ. ERR_TRI ) THEN
+ WRITE(OUTNUM,5000) ERRIBUF(4,I), ERRIBUF(5,I),
+ $ ERRDBUF(2,I), ERRDBUF(1,I)
+ ELSE
+ WRITE(OUTNUM,6000) ERRIBUF(4,I), ERRIBUF(5,I),
+ $ ERRDBUF(2,I), ERRDBUF(1,I)
+ END IF
+ END IF
+ 20 CONTINUE
+ WRITE(OUTNUM,12000) PROW, PCOL, OLDTEST
+*
+ 1000 FORMAT('PROCESS {',I4,',',I4,'} REPORTS ERRORS IN TEST#',I6,':')
+ 2000 FORMAT(' Buffer overwrite ',I4,
+ $ ' elements before the start of A:',/,
+ $ ' Expected=',G15.8,
+ $ '; Received=',G15.8)
+ 3000 FORMAT(' Buffer overwrite ',I4,' elements after the end of A:',
+ $ /,' Expected=',G15.8,
+ $ '; Received=',G15.8)
+ 4000 FORMAT(' LDA-M gap overwrite at postion (',I4,',',I4,'):',/,
+ $ ' Expected=',G15.8,
+ $ '; Received=',G15.8)
+ 5000 FORMAT(' Complementory triangle overwrite at A(',I4,',',I4,
+ $ '):',/,' Expected=',G15.8,
+ $ '; Received=',G15.8)
+ 6000 FORMAT(' Invalid element at A(',I4,',',I4,'):',/,
+ $ ' Expected=',G15.8,
+ $ '; Received=',G15.8)
+ 7000 FORMAT(' Buffer overwrite ',I4,' elements before the start of ',
+ $ A1,'A:',/,' Expected=',I12,'; Received=',I12)
+ 8000 FORMAT(' Buffer overwrite ',I4,' elements after the end of ',
+ $ A1,'A:',/,' Expected=',I12,'; Received=',I12)
+*
+ 9000 FORMAT(' LD',A1,'A-M gap overwrite at postion (',I4,',',I4,'):'
+ $ ,/,' Expected=',I12,'; Received=',I12)
+*
+10000 FORMAT(' Invalid element at ',A1,'A(',I4,',',I4,'):',/,
+ $ ' Expected=',I12,'; Received=',I12)
+11000 FORMAT(' Overwrite at position (',I4,',',I4,') of non-existent '
+ $ ,A1,'A array.',/,' Expected=',I12,'; Received=',I12)
+12000 FORMAT('PROCESS {',I4,',',I4,'} DONE ERROR REPORT FOR TEST#',
+ $ I6,'.')
+13000 FORMAT('WARNING: There were more errors than could be recorded.',
+ $ /,'Increase MEMELTS to get complete listing.')
+ RETURN
+*
+* End SPRINTERRS
+*
+ END
+*
+*
+ SUBROUTINE DBTCHECKIN( NFTESTS, OUTNUM, MAXERR, NERR, IERR,
+ $ DVAL, TFAILED )
+ INTEGER NFTESTS, OUTNUM, MAXERR, NERR
+ INTEGER IERR(*), TFAILED(*)
+ DOUBLE PRECISION DVAL(*)
+*
+* Purpose
+* =======
+* DBTCHECKIN: Process 0 receives error report from all processes.
+*
+* Arguments
+* =========
+* NFTESTS (input/output) INTEGER
+* if NFTESTS is <= 0 upon entry, NFTESTS is not written to.
+* Otherwise, on entry it specifies the total number of tests
+* run, and on exit it is the number of tests which failed.
+*
+* OUTNUM (input) INTEGER
+* Device number for output.
+*
+* MAXERR (input) INTEGER
+* Max number of errors that can be stored in ERRIBUFF or
+* ERRDBUFF
+*
+* NERR (output) INTEGER
+* The number of errors that have been found.
+*
+* ERRIBUF (output) INTEGER array, dimension (6,MAXERRS)
+* Buffer in which to store integer error information. It will
+* be built up in the following format for the call to TSEND.
+* All integer information is recorded in the following 6-tuple
+* {TESTNUM, SRC, DEST, I, J, WHAT}. These values are figured:
+* SRC = RSRC * NPROCS + CSRC
+* DEST = RDEST * NPROCS + CDEST
+* WHAT
+* = 1 : Error in pre-padding
+* = 2 : Error in post-padding
+* = 3 : Error in LDA-M gap
+* = 4 : Error in complementory triangle
+* ELSE: Error in matrix
+* If there are more errors than can fit in the error buffer,
+* the error number will indicate the actual number of errors
+* found, but the buffer will be truncated to the maximum
+* number of errors which can fit.
+*
+* ERRDBUF (output) @(doctype) array, dimension (2, MAXERRS)
+* Buffer in which to store error data information.
+* {Incorrect, Predicted}
+*
+* TFAILED (workspace) INTEGER array, dimension NFTESTS
+* Workspace used to keep track of which tests failed.
+* If input of NFTESTS < 1, this array not accessed.
+*
+* ===================================================================
+*
+* .. External Functions ..
+ INTEGER IBTMYPROC, IBTNPROCS, IBTMSGID
+ EXTERNAL IBTMYPROC, IBTNPROCS, IBTMSGID
+* ..
+* .. Local Scalars ..
+ LOGICAL COUNTING
+ INTEGER K, NERR2, IAM, NPROCS, NTESTS
+*
+* Proc 0 collects error info from everyone
+*
+ IAM = IBTMYPROC()
+ NPROCS = IBTNPROCS()
+*
+ IF( IAM .EQ. 0 ) THEN
+*
+* If we are finding out how many failed tests there are, initialize
+* the total number of tests (NTESTS), and zero the test failed array
+*
+ COUNTING = NFTESTS .GT. 0
+ IF( COUNTING ) THEN
+ NTESTS = NFTESTS
+ DO 10 K = 1, NTESTS
+ TFAILED(K) = 0
+ 10 CONTINUE
+ END IF
+*
+ CALL DPRINTERRS(OUTNUM, MAXERR, NERR, IERR, DVAL, COUNTING,
+ $ TFAILED)
+*
+ DO 20 K = 1, NPROCS-1
+ CALL BTSEND(3, 0, K, K, IBTMSGID()+50)
+ CALL BTRECV(3, 1, NERR2, K, IBTMSGID()+50)
+ IF( NERR2 .GT. 0 ) THEN
+ NERR = NERR + NERR2
+ CALL BTRECV(3, NERR2*6, IERR, K, IBTMSGID()+51)
+ CALL BTRECV(6, NERR2*2, DVAL, K, IBTMSGID()+51)
+ CALL DPRINTERRS(OUTNUM, MAXERR, NERR2, IERR, DVAL,
+ $ COUNTING, TFAILED)
+ END IF
+ 20 CONTINUE
+*
+* Count up number of tests that failed
+*
+ IF( COUNTING ) THEN
+ NFTESTS = 0
+ DO 30 K = 1, NTESTS
+ NFTESTS = NFTESTS + TFAILED(K)
+ 30 CONTINUE
+ END IF
+*
+* Send my error info to proc 0
+*
+ ELSE
+ CALL BTRECV(3, 0, K, 0, IBTMSGID()+50)
+ CALL BTSEND(3, 1, NERR, 0, IBTMSGID()+50)
+ IF( NERR .GT. 0 ) THEN
+ CALL BTSEND(3, NERR*6, IERR, 0, IBTMSGID()+51)
+ CALL BTSEND(6, NERR*2, DVAL, 0, IBTMSGID()+51)
+ END IF
+ ENDIF
+*
+ RETURN
+*
+* End of DBTCHECKIN
+*
+ END
+*
+ SUBROUTINE DINITMAT(UPLO, DIAG, M, N, MEM, LDA, IPRE, IPOST,
+ $ CHECKVAL, TESTNUM, MYROW, MYCOL)
+ CHARACTER*1 UPLO, DIAG
+ INTEGER M, N, LDA, IPRE, IPOST, TESTNUM, MYROW, MYCOL
+ DOUBLE PRECISION CHECKVAL
+ DOUBLE PRECISION MEM(*)
+*
+* .. External Subroutines ..
+ EXTERNAL DGENMAT, DPADMAT
+* ..
+* .. Executable Statements ..
+*
+ CALL DGENMAT( M, N, MEM(IPRE+1), LDA, TESTNUM, MYROW, MYCOL )
+ CALL DPADMAT( UPLO, DIAG, M, N, MEM, LDA, IPRE, IPOST, CHECKVAL )
+*
+ RETURN
+ END
+*
+ SUBROUTINE DGENMAT( M, N, A, LDA, TESTNUM, MYROW, MYCOL )
+*
+* -- BLACS tester (version 1.0) --
+* University of Tennessee
+* December 15, 1994
+*
+*
+* .. Scalar Arguments ..
+ INTEGER M, N, LDA, TESTNUM, MYROW, MYCOL
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION A(LDA,N)
+* ..
+*
+* Purpose
+* =======
+* DGENMAT: Generates an M-by-N matrix filled with random elements.
+*
+* Arguments
+* =========
+* M (input) INTEGER
+* The number of rows of the matrix A. M >= 0.
+*
+* N (input) INTEGER
+* The number of columns of the matrix A. N >= 0.
+*
+* A (output) @up@(doctype) array, dimension (LDA,N)
+* The m by n matrix A. Fortran77 (column-major) storage
+* assumed.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1, M).
+*
+* TESTNUM (input) INTEGER
+* Unique number for this test case, used as a basis for
+* the random seeds.
+*
+* ====================================================================
+*
+* .. External Functions ..
+ INTEGER IBTNPROCS
+ DOUBLE PRECISION DBTRAN
+ EXTERNAL DBTRAN, IBTNPROCS
+* ..
+* .. Local Scalars ..
+ INTEGER I, J, NPROCS, SRC
+* ..
+* .. Local Arrays ..
+ INTEGER ISEED(4)
+* ..
+* .. Executable Statements ..
+*
+* ISEED's four values must be positive integers less than 4096,
+* fourth one has to be odd. (see _LARND). Use some goofy
+* functions to come up with seed values which together should
+* be unique.
+*
+ NPROCS = IBTNPROCS()
+ SRC = MYROW * NPROCS + MYCOL
+ ISEED(1) = MOD( 1002 + TESTNUM*5 + SRC*3, 4096 )
+ ISEED(2) = MOD( 2027 + TESTNUM*7 + SRC, 4096 )
+ ISEED(3) = MOD( 1234 + TESTNUM + SRC*3, 4096 )
+ ISEED(4) = MOD( 4311 + TESTNUM*10 + SRC*2, 4096 )
+*
+ DO 10 J = 1, N
+ DO 10 I = 1, M
+ A(I, J) = DBTRAN( ISEED )
+ 10 CONTINUE
+*
+ RETURN
+*
+* End of DGENMAT.
+*
+ END
+*
+ DOUBLE PRECISION FUNCTION DBTRAN(ISEED)
+ INTEGER ISEED(*)
+*
+* .. External Functions ..
+ DOUBLE PRECISION DLARND
+ EXTERNAL DLARND
+* .. Executable Statements ..
+*
+ DBTRAN = DLARND(2, ISEED)
+*
+ RETURN
+*
+* End of Dbtran
+*
+ END
+*
+ SUBROUTINE DPADMAT( UPLO, DIAG, M, N, MEM, LDA, IPRE, IPOST,
+ $ CHECKVAL )
+*
+* -- BLACS tester (version 1.0) --
+* University of Tennessee
+* December 15, 1994
+*
+* .. Scalar Arguments ..
+ CHARACTER*1 UPLO, DIAG
+ INTEGER M, N, LDA, IPRE, IPOST
+ DOUBLE PRECISION CHECKVAL
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION MEM( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DPADMAT: Pad Matrix.
+* This routines surrounds a matrix with a guardzone initialized to the
+* value CHECKVAL. There are three distinct guardzones:
+* - A contiguous zone of size IPRE immediately before the start
+* of the matrix.
+* - A contiguous zone of size IPOST immedately after the end of the
+* matrix.
+* - Interstitial zones within each column of the matrix, in the
+* elements A( M+1:LDA, J ).
+*
+* Arguments
+* =========
+* UPLO (input) CHARACTER*1
+* Is the matrix A 'U'pper or 'L'ower trapezoidal, or 'G'eneral
+* rectangular?
+*
+* DIAG (input) CHARACTER*1
+* For trapezoidal matrices, is the main diagonal included
+* ('N') or not ('U')?
+*
+* M (input) INTEGER
+* The number of rows of the matrix A. M >= 0.
+*
+* N (input) INTEGER
+* The number of columns of the matrix A. N >= 0.
+*
+* MEM (output) double precision array, dimension (IPRE+IPOST+LDA*N)
+* The address IPRE elements ahead of the matrix A you want to
+* pad, which is then of dimension (LDA,N).
+*
+* IPRE (input) INTEGER
+* The size of the guard zone ahead of the matrix A.
+*
+* IPOST (input) INTEGER
+* The size of the guard zone behind the matrix A.
+*
+* CHECKVAL (input) double precision
+* The value to insert into the guard zones.
+*
+* ====================================================================
+*
+* .. Local Scalars ..
+ INTEGER I, J, K
+* ..
+* .. Executable Statements ..
+*
+* Put check buffer in front of A
+*
+ IF( IPRE .GT. 0 ) THEN
+ DO 10 I = 1, IPRE
+ MEM( I ) = CHECKVAL
+ 10 CONTINUE
+ END IF
+*
+* Put check buffer in back of A
+*
+ IF( IPOST .GT. 0 ) THEN
+ J = IPRE + LDA*N + 1
+ DO 20 I = J, J+IPOST-1
+ MEM( I ) = CHECKVAL
+ 20 CONTINUE
+ END IF
+*
+* Put check buffer in all (LDA-M) gaps
+*
+ IF( LDA .GT. M ) THEN
+ K = IPRE + M + 1
+ DO 40 J = 1, N
+ DO 30 I = K, K+LDA-M-1
+ MEM( I ) = CHECKVAL
+ 30 CONTINUE
+ K = K + LDA
+ 40 CONTINUE
+ END IF
+*
+* If the matrix is upper or lower trapezoidal, calculate the
+* additional triangular area which needs to be padded, Each
+* element referred to is in the Ith row and the Jth column.
+*
+ IF( UPLO .EQ. 'U' ) THEN
+ IF( M .LE. N ) THEN
+ IF( DIAG .EQ. 'U' ) THEN
+ DO 41 I = 1, M
+ DO 42 J = 1, I
+ K = IPRE + I + (J-1)*LDA
+ MEM( K ) = CHECKVAL
+ 42 CONTINUE
+ 41 CONTINUE
+ ELSE
+ DO 43 I = 2, M
+ DO 44 J = 1, I-1
+ K = IPRE + I + (J-1)*LDA
+ MEM( K ) = CHECKVAL
+ 44 CONTINUE
+ 43 CONTINUE
+ END IF
+ ELSE
+ IF( DIAG .EQ. 'U' ) THEN
+ DO 45 I = M-N+1, M
+ DO 46 J = 1, I-(M-N)
+ K = IPRE + I + (J-1)*LDA
+ MEM( K ) = CHECKVAL
+ 46 CONTINUE
+ 45 CONTINUE
+ ELSE
+ DO 47 I = M-N+2, M
+ DO 48 J = 1, I-(M-N)-1
+ K = IPRE + I + (J-1)*LDA
+ MEM( K ) = CHECKVAL
+ 48 CONTINUE
+ 47 CONTINUE
+ END IF
+ END IF
+ ELSE IF( UPLO .EQ. 'L' ) THEN
+ IF( M .LE. N ) THEN
+ IF( DIAG .EQ. 'U' ) THEN
+ DO 49 I = 1, M
+ DO 50 J = N-M+I, N
+ K = IPRE + I + (J-1)*LDA
+ MEM( K ) = CHECKVAL
+ 50 CONTINUE
+ 49 CONTINUE
+ ELSE
+ DO 51 I = 1, M-1
+ DO 52 J = N-M+I+1, N
+ K = IPRE + I + (J-1)*LDA
+ MEM( K ) = CHECKVAL
+ 52 CONTINUE
+ 51 CONTINUE
+ END IF
+ ELSE
+ IF( UPLO .EQ. 'U' ) THEN
+ DO 53 I = 1, N
+ DO 54 J = I, N
+ K = IPRE + I + (J-1)*LDA
+ MEM( K ) = CHECKVAL
+ 54 CONTINUE
+ 53 CONTINUE
+ ELSE
+ DO 55 I = 1, N-1
+ DO 56 J = I+1, N
+ K = IPRE + I + (J-1)*LDA
+ MEM( K ) = CHECKVAL
+ 56 CONTINUE
+ 55 CONTINUE
+ END IF
+ END IF
+ END IF
+*
+* End of DPADMAT.
+*
+ RETURN
+ END
+*
+ SUBROUTINE DCHKPAD( UPLO, DIAG, M, N, MEM, LDA, RSRC, CSRC,
+ $ MYROW, MYCOL, IPRE, IPOST, CHECKVAL,
+ $ TESTNUM, MAXERR, NERR, ERRIBUF, ERRDBUF )
+*
+* -- BLACS tester (version 1.0) --
+* University of Tennessee
+* December 15, 1994
+*
+*
+* .. Scalar Arguments ..
+ CHARACTER*1 UPLO, DIAG
+ INTEGER M, N, LDA, RSRC, CSRC, MYROW, MYCOL, IPRE, IPOST
+ INTEGER TESTNUM, MAXERR, NERR
+ DOUBLE PRECISION CHECKVAL
+* ..
+* .. Array Arguments ..
+ INTEGER ERRIBUF(6, MAXERR)
+ DOUBLE PRECISION MEM(*), ERRDBUF(2, MAXERR)
+* ..
+*
+* Purpose
+* =======
+* DCHKPAD: Check padding put in by PADMAT.
+* Checks that padding around target matrix has not been overwritten
+* by the previous point-to-point or broadcast send.
+*
+* Arguments
+* =========
+* UPLO (input) CHARACTER*1
+* Is the matrix A 'U'pper or 'L'ower trapezoidal, or 'G'eneral
+* rectangular?
+*
+* DIAG (input) CHARACTER*1
+* For trapezoidal matrices, is the main diagonal included
+* ('N') or not ('U')?
+*
+* M (input) INTEGER
+* The number of rows of the matrix A. M >= 0.
+*
+* N (input) INTEGER
+* The number of columns of the matrix A. N >= 0.
+*
+* MEM (input) double precision array, dimension(IPRE+IPOST+LDA*N).
+* Memory location IPRE elements in front of the matrix A.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1, M).
+*
+* RSRC (input) INTEGER
+* The process row of the source of the matrix.
+*
+* CSRC (input) INTEGER
+* The process column of the source of the matrix.
+*
+* MYROW (input) INTEGER
+* Row of this process in the process grid.
+*
+* MYCOL (input) INTEGER
+* Column of this process in the process grid.
+*
+* IPRE (input) INTEGER
+* The size of the guard zone before the start of A.
+*
+* IPOST (input) INTEGER
+* The size of guard zone after A.
+*
+* CHECKVAL (input) double precision
+* The value to pad matrix with.
+*
+* TESTNUM (input) INTEGER
+* The number of the test being checked.
+*
+* MAXERR (input) INTEGER
+* Max number of errors that can be stored in ERRIBUFF or
+* ERRDBUFF
+*
+* NERR (output) INTEGER
+* The number of errors that have been found.
+*
+* ERRIBUF (output) INTEGER array, dimension (6,MAXERRS)
+* Buffer in which to store integer error information. It will
+* be built up in the following format for the call to TSEND.
+* All integer information is recorded in the following 6-tuple
+* {TESTNUM, SRC, DEST, I, J, WHAT}. These values are figured:
+* SRC = RSRC * NPROCS + CSRC
+* DEST = RDEST * NPROCS + CDEST
+* WHAT
+* = 1 : Error in pre-padding
+* = 2 : Error in post-padding
+* = 3 : Error in LDA-M gap
+* = 4 : Error in complementory triangle
+* ELSE: Error in matrix
+* If there are more errors than can fit in the error buffer,
+* the error number will indicate the actual number of errors
+* found, but the buffer will be truncated to the maximum
+* number of errors which can fit.
+*
+* ERRDBUF (output) @(doctype) array, dimension (2, MAXERRS)
+* Buffer in which to store error data information.
+* {Incorrect, Predicted}
+*
+* ===================================================================
+*
+* .. Parameters ..
+ INTEGER ERR_PRE, ERR_POST, ERR_GAP, ERR_TRI, ERR_MAT
+ PARAMETER( ERR_PRE = 1, ERR_POST = 2, ERR_GAP = 3, ERR_TRI = 4 )
+ PARAMETER( ERR_MAT = 5 )
+* ..
+* .. External Functions ..
+ INTEGER IBTNPROCS
+ EXTERNAL IBTNPROCS
+* ..
+* .. Local Scalars ..
+ LOGICAL ISTRAP
+ INTEGER I, J, K, IRST, IRND, ICST, ICND, SRC, DEST
+ INTEGER NPROCS
+* ..
+* .. Executable Statements ..
+*
+ NPROCS = IBTNPROCS()
+ SRC = RSRC * NPROCS + CSRC
+ DEST = MYROW * NPROCS + MYCOL
+*
+* Check buffer in front of A
+*
+ IF( IPRE .GT. 0 ) THEN
+ DO 10 I = 1, IPRE
+ IF( MEM(I) .NE. CHECKVAL ) THEN
+ NERR = NERR + 1
+ IF( NERR .LE. MAXERR ) THEN
+ ERRIBUF(1, NERR) = TESTNUM
+ ERRIBUF(2, NERR) = SRC
+ ERRIBUF(3, NERR) = DEST
+ ERRIBUF(4, NERR) = I
+ ERRIBUF(5, NERR) = IPRE - I + 1
+ ERRIBUF(6, NERR) = ERR_PRE
+ ERRDBUF(1, NERR) = MEM(I)
+ ERRDBUF(2, NERR) = CHECKVAL
+ END IF
+ END IF
+ 10 CONTINUE
+ END IF
+*
+* Check buffer behind A
+*
+ IF( IPOST .GT. 0 ) THEN
+ J = IPRE + LDA*N + 1
+ DO 20 I = J, J+IPOST-1
+ IF( MEM(I) .NE. CHECKVAL ) THEN
+ NERR = NERR + 1
+ IF( NERR .LE. MAXERR ) THEN
+ ERRIBUF(1, NERR) = TESTNUM
+ ERRIBUF(2, NERR) = SRC
+ ERRIBUF(3, NERR) = DEST
+ ERRIBUF(4, NERR) = I - J + 1
+ ERRIBUF(5, NERR) = J
+ ERRIBUF(6, NERR) = ERR_POST
+ ERRDBUF(1, NERR) = MEM(I)
+ ERRDBUF(2, NERR) = CHECKVAL
+ END IF
+ END IF
+ 20 CONTINUE
+ END IF
+*
+* Check all (LDA-M) gaps
+*
+ IF( LDA .GT. M ) THEN
+ DO 40 J = 1, N
+ DO 30 I = M+1, LDA
+ K = IPRE + (J-1)*LDA + I
+ IF( MEM(K) .NE. CHECKVAL) THEN
+ NERR = NERR + 1
+ IF( NERR .LE. MAXERR ) THEN
+ ERRIBUF(1, NERR) = TESTNUM
+ ERRIBUF(2, NERR) = SRC
+ ERRIBUF(3, NERR) = DEST
+ ERRIBUF(4, NERR) = I
+ ERRIBUF(5, NERR) = J
+ ERRIBUF(6, NERR) = ERR_GAP
+ ERRDBUF(1, NERR) = MEM(K)
+ ERRDBUF(2, NERR) = CHECKVAL
+ END IF
+ END IF
+ 30 CONTINUE
+ 40 CONTINUE
+ END IF
+*
+* Determine limits of trapezoidal matrix
+*
+ ISTRAP = .FALSE.
+ IF( UPLO .EQ. 'U' ) THEN
+ ISTRAP = .TRUE.
+ IF( M .LE. N ) THEN
+ IRST = 2
+ IRND = M
+ ICST = 1
+ ICND = M - 1
+ ELSEIF( M .GT. N ) THEN
+ IRST = ( M-N ) + 2
+ IRND = M
+ ICST = 1
+ ICND = N - 1
+ ENDIF
+ IF( DIAG .EQ. 'U' ) THEN
+ IRST = IRST - 1
+ ICND = ICND + 1
+ ENDIF
+ ELSE IF( UPLO .EQ. 'L' ) THEN
+ ISTRAP = .TRUE.
+ IF( M .LE. N ) THEN
+ IRST = 1
+ IRND = 1
+ ICST = ( N-M ) + 2
+ ICND = N
+ ELSEIF( M .GT. N ) THEN
+ IRST = 1
+ IRND = 1
+ ICST = 2
+ ICND = N
+ ENDIF
+ IF( DIAG .EQ. 'U' ) THEN
+ ICST = ICST - 1
+ ENDIF
+ ENDIF
+*
+* Check elements and report any errors
+*
+ IF( ISTRAP ) THEN
+ DO 100 J = ICST, ICND
+ DO 105 I = IRST, IRND
+ IF( MEM( IPRE + (J-1)*LDA + I ) .NE. CHECKVAL ) THEN
+ NERR = NERR + 1
+ IF( NERR .LE. MAXERR ) THEN
+ ERRIBUF(1, NERR) = TESTNUM
+ ERRIBUF(2, NERR) = SRC
+ ERRIBUF(3, NERR) = DEST
+ ERRIBUF(4, NERR) = I
+ ERRIBUF(5, NERR) = J
+ ERRIBUF(6, NERR) = ERR_TRI
+ ERRDBUF(1, NERR) = MEM( IPRE + (J-1)*LDA + I )
+ ERRDBUF(2, NERR) = CHECKVAL
+ END IF
+ END IF
+ 105 CONTINUE
+*
+* Update the limits to allow filling in padding
+*
+ IF( UPLO .EQ. 'U' ) THEN
+ IRST = IRST + 1
+ ELSE
+ IRND = IRND + 1
+ ENDIF
+ 100 CONTINUE
+ END IF
+*
+ RETURN
+*
+* End of DCHKPAD.
+*
+ END
+*
+ SUBROUTINE DCHKMAT( UPLO, DIAG, M, N, A, LDA, RSRC, CSRC,
+ $ MYROW, MYCOL, TESTNUM, MAXERR, NERR,
+ $ ERRIBUF, ERRDBUF )
+*
+* -- BLACS tester (version 1.0) --
+* University of Tennessee
+* December 15, 1994
+*
+*
+* .. Scalar Arguments ..
+ CHARACTER*1 UPLO, DIAG
+ INTEGER M, N, LDA, RSRC, CSRC, MYROW, MYCOL, TESTNUM
+ INTEGER MAXERR, NERR
+* ..
+* .. Array Arguments ..
+ INTEGER ERRIBUF(6, MAXERR)
+ DOUBLE PRECISION A(LDA,N), ERRDBUF(2, MAXERR)
+* ..
+*
+* Purpose
+* =======
+* dCHKMAT: Check matrix to see whether there were any transmission
+* errors.
+*
+* Arguments
+* =========
+* UPLO (input) CHARACTER*1
+* Is the matrix A 'U'pper or 'L'ower trapezoidal, or 'G'eneral
+* rectangular?
+*
+* DIAG (input) CHARACTER*1
+* For trapezoidal matrices, is the main diagonal included
+* ('N') or not ('U')?
+*
+* M (input) INTEGER
+* The number of rows of the matrix A. M >= 0.
+*
+* N (input) INTEGER
+* The number of columns of the matrix A. N >= 0.
+*
+* A (input) @up@(doctype) array, dimension (LDA,N)
+* The m by n matrix A. Fortran77 (column-major) storage
+* assumed.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1, M).
+*
+* RSRC (input) INTEGER
+* The process row of the source of the matrix.
+*
+* CSRC (input) INTEGER
+* The process column of the source of the matrix.
+*
+* MYROW (input) INTEGER
+* Row of this process in the process grid.
+*
+* MYCOL (input) INTEGER
+* Column of this process in the process grid.
+*
+*
+* TESTNUM (input) INTEGER
+* The number of the test being checked.
+*
+* MAXERR (input) INTEGER
+* Max number of errors that can be stored in ERRIBUFF or
+* ERRDBUFF
+*
+* NERR (output) INTEGER
+* The number of errors that have been found.
+*
+* ERRIBUF (output) INTEGER array, dimension (6,MAXERRS)
+* Buffer in which to store integer error information. It will
+* be built up in the following format for the call to TSEND.
+* All integer information is recorded in the following 6-tuple
+* {TESTNUM, SRC, DEST, I, J, WHAT}. These values are figured:
+* SRC = RSRC * NPROCS + CSRC
+* DEST = RDEST * NPROCS + CDEST
+* WHAT
+* = 1 : Error in pre-padding
+* = 2 : Error in post-padding
+* = 3 : Error in LDA-M gap
+* = 4 : Error in complementory triangle
+* ELSE: Error in matrix
+* If there are more errors than can fit in the error buffer,
+* the error number will indicate the actual number of errors
+* found, but the buffer will be truncated to the maximum
+* number of errors which can fit.
+*
+* ERRDBUF (output) @(doctype) array, dimension (2, MAXERRS)
+* Buffer in which to store error data information.
+* {Incorrect, Predicted}
+*
+* ===================================================================
+*
+* .. Local Scalars ..
+ INTEGER I, J, NPROCS, SRC, DEST
+ LOGICAL USEIT
+ DOUBLE PRECISION COMPVAL
+* ..
+* .. Local Arrays ..
+ INTEGER ISEED(4)
+* ..
+* .. External Functions ..
+ INTEGER IBTNPROCS
+ DOUBLE PRECISION DBTRAN
+ EXTERNAL DBTRAN, IBTNPROCS
+* ..
+* .. Executable Statements ..
+*
+ NPROCS = IBTNPROCS()
+ SRC = RSRC * NPROCS + CSRC
+ DEST = MYROW * NPROCS + MYCOL
+*
+* Initialize ISEED with the same values as used in DGENMAT.
+*
+ ISEED(1) = MOD( 1002 + TESTNUM*5 + SRC*3, 4096 )
+ ISEED(2) = MOD( 2027 + TESTNUM*7 + SRC, 4096 )
+ ISEED(3) = MOD( 1234 + TESTNUM + SRC*3, 4096 )
+ ISEED(4) = MOD( 4311 + TESTNUM*10 + SRC*2, 4096 )
+*
+* Generate the elements randomly with the same method used in GENMAT.
+* Note that for trapezoidal matrices, we generate all elements in the
+* enclosing rectangle and then ignore the complementary triangle.
+*
+ DO 100 J = 1, N
+ DO 105 I = 1, M
+ COMPVAL = DBTRAN( ISEED )
+*
+* Now determine whether we actually need this value. The
+* strategy is to chop out the proper triangle based on what
+* particular kind of trapezoidal matrix we're dealing with.
+*
+ USEIT = .TRUE.
+ IF( UPLO .EQ. 'U' ) THEN
+ IF( M .LE. N ) THEN
+ IF( DIAG .EQ. 'U' ) THEN
+ IF( I .GE. J ) THEN
+ USEIT = .FALSE.
+ END IF
+ ELSE
+ IF( I .GT. J ) THEN
+ USEIT = .FALSE.
+ END IF
+ END IF
+ ELSE
+ IF( DIAG .EQ. 'U' ) THEN
+ IF( I .GE. M-N+J ) THEN
+ USEIT = .FALSE.
+ END IF
+ ELSE
+ IF( I .GT. M-N+J ) THEN
+ USEIT = .FALSE.
+ END IF
+ END IF
+ END IF
+ ELSE IF( UPLO .EQ. 'L' ) THEN
+ IF( M .LE. N ) THEN
+ IF( DIAG .EQ. 'U' ) THEN
+ IF( J. GE. I+(N-M) ) THEN
+ USEIT = .FALSE.
+ END IF
+ ELSE
+ IF( J .GT. I+(N-M) ) THEN
+ USEIT = .FALSE.
+ END IF
+ END IF
+ ELSE
+ IF( DIAG .EQ. 'U' ) THEN
+ IF( J .GE. I ) THEN
+ USEIT = .FALSE.
+ END IF
+ ELSE
+ IF( J .GT. I ) THEN
+ USEIT = .FALSE.
+ END IF
+ END IF
+ END IF
+ END IF
+*
+* Compare the generated value to the one that's in the
+* received matrix. If they don't match, tack another
+* error record onto what's already there.
+*
+ IF( USEIT ) THEN
+ IF( A(I,J) .NE. COMPVAL ) THEN
+ NERR = NERR + 1
+ IF( NERR .LE. MAXERR ) THEN
+ ERRIBUF(1, NERR) = TESTNUM
+ ERRIBUF(2, NERR) = SRC
+ ERRIBUF(3, NERR) = DEST
+ ERRIBUF(4, NERR) = I
+ ERRIBUF(5, NERR) = J
+ ERRIBUF(6, NERR) = 5
+ ERRDBUF(1, NERR) = A(I, J)
+ ERRDBUF(2, NERR) = COMPVAL
+ END IF
+ END IF
+ END IF
+ 105 CONTINUE
+ 100 CONTINUE
+ RETURN
+*
+* End of DCHKMAT.
+*
+ END
+*
+ SUBROUTINE DPRINTERRS( OUTNUM, MAXERR, NERR,
+ $ ERRIBUF, ERRDBUF, COUNTING, TFAILED )
+*
+* -- BLACS tester (version 1.0) --
+* University of Tennessee
+* December 15, 1994
+*
+*
+* .. Scalar Arguments ..
+ LOGICAL COUNTING
+ INTEGER OUTNUM, MAXERR, NERR
+* ..
+* .. Array Arguments ..
+ INTEGER ERRIBUF(6, MAXERR), TFAILED(*)
+ DOUBLE PRECISION ERRDBUF(2, MAXERR)
+* ..
+*
+* Purpose
+* =======
+* DPRINTERRS: Print errors that have been recorded
+*
+* Arguments
+* =========
+* OUTNUM (input) INTEGER
+* Device number for output.
+*
+* MAXERR (input) INTEGER
+* Max number of errors that can be stored in ERRIBUFF or
+* ERRDBUFF
+*
+* NERR (output) INTEGER
+* The number of errors that have been found.
+*
+* ERRIBUF (output) INTEGER array, dimension (6,MAXERRS)
+* Buffer in which to store integer error information. It will
+* be built up in the following format for the call to TSEND.
+* All integer information is recorded in the following 6-tuple
+* {TESTNUM, SRC, DEST, I, J, WHAT}. These values are figured:
+* SRC = RSRC * NPROCS + CSRC
+* DEST = RDEST * NPROCS + CDEST
+* WHAT
+* = 1 : Error in pre-padding
+* = 2 : Error in post-padding
+* = 3 : Error in LDA-M gap
+* = 4 : Error in complementory triangle
+* ELSE: Error in matrix
+* If there are more errors than can fit in the error buffer,
+* the error number will indicate the actual number of errors
+* found, but the buffer will be truncated to the maximum
+* number of errors which can fit.
+*
+* ERRDBUF (output) @(doctype) array, dimension (2, MAXERRS)
+* Buffer in which to store error data information.
+* {Incorrect, Predicted}
+*
+* TFAILED (input/ourput) INTEGER array, dimension NTESTS
+* Workspace used to keep track of which tests failed.
+* This array not accessed unless COUNTING is true.
+*
+* ===================================================================
+*
+* .. Parameters ..
+ INTEGER ERR_PRE, ERR_POST, ERR_GAP, ERR_TRI, ERR_MAT
+ PARAMETER( ERR_PRE = 1, ERR_POST = 2, ERR_GAP = 3, ERR_TRI = 4 )
+ PARAMETER( ERR_MAT = 5 )
+* ..
+* .. External Functions ..
+ INTEGER IBTMYPROC, IBTNPROCS
+ EXTERNAL IBTMYPROC, IBTNPROCS
+* ..
+* .. Local Scalars ..
+ CHARACTER*1 MAT
+ LOGICAL MATISINT
+ INTEGER OLDTEST, NPROCS, PROW, PCOL, I, ERRTYPE
+* ..
+* .. Executable Statements ..
+*
+ IF( (IBTMYPROC().NE.0) .OR. (NERR.LE.0) ) RETURN
+ OLDTEST = -1
+ NPROCS = IBTNPROCS()
+ PROW = ERRIBUF(3,1) / NPROCS
+ PCOL = MOD( ERRIBUF(3,1), NPROCS )
+ IF( NERR .GT. MAXERR ) WRITE(OUTNUM,13000)
+*
+ DO 20 I = 1, MIN( NERR, MAXERR )
+ IF( ERRIBUF(1,I) .NE. OLDTEST ) THEN
+ IF( OLDTEST .NE. -1 )
+ $ WRITE(OUTNUM,12000) PROW, PCOL, OLDTEST
+ WRITE(OUTNUM,*) ' '
+ WRITE(OUTNUM,1000) PROW, PCOL, ERRIBUF(1,I)
+ IF( COUNTING ) TFAILED( ERRIBUF(1,I) ) = 1
+ OLDTEST = ERRIBUF(1, I)
+ END IF
+*
+* Print out error message depending on type of error
+*
+ ERRTYPE = ERRIBUF(6, I)
+ IF( ERRTYPE .LT. -10 ) THEN
+ ERRTYPE = -ERRTYPE - 10
+ MAT = 'C'
+ MATISINT = .TRUE.
+ ELSE IF( ERRTYPE .LT. 0 ) THEN
+ ERRTYPE = -ERRTYPE
+ MAT = 'R'
+ MATISINT = .TRUE.
+ ELSE
+ MATISINT = .FALSE.
+ END IF
+*
+* RA/CA arrays from MAX/MIN have different printing protocol
+*
+ IF( MATISINT ) THEN
+ IF( ERRIBUF(2, I) .EQ. -1 ) THEN
+ WRITE(OUTNUM,11000) ERRIBUF(4,I), ERRIBUF(5,I), MAT,
+ $ INT( ERRDBUF(2,I) ), INT( ERRDBUF(1,I) )
+ ELSE IF( ERRTYPE .EQ. ERR_PRE ) THEN
+ WRITE(OUTNUM,7000) ERRIBUF(5,I), MAT,
+ $ INT( ERRDBUF(2,I) ), INT( ERRDBUF(1,I) )
+ ELSE IF( ERRTYPE .EQ. ERR_POST ) THEN
+ WRITE(OUTNUM,8000) ERRIBUF(4,I), MAT,
+ $ INT( ERRDBUF(2,I) ), INT( ERRDBUF(1,I) )
+ ELSE IF( ERRTYPE .EQ. ERR_GAP ) THEN
+ WRITE(OUTNUM,9000) MAT, ERRIBUF(4,I), ERRIBUF(5,I),
+ $ INT( ERRDBUF(2,I) ), INT( ERRDBUF(1,I) )
+ ELSE
+ WRITE(OUTNUM,10000) MAT, ERRIBUF(4,I), ERRIBUF(5,I),
+ $ INT( ERRDBUF(2,I) ),
+ $ INT( ERRDBUF(1,I) )
+ END IF
+*
+* Have memory overwrites in matrix A
+*
+ ELSE
+ IF( ERRTYPE .EQ. ERR_PRE ) THEN
+ WRITE(OUTNUM,2000) ERRIBUF(5,I), ERRDBUF(2,I),
+ $ ERRDBUF(1,I)
+ ELSE IF( ERRTYPE .EQ. ERR_POST ) THEN
+ WRITE(OUTNUM,3000) ERRIBUF(4,I), ERRDBUF(2,I),
+ $ ERRDBUF(1,I)
+ ELSE IF( ERRTYPE .EQ. ERR_GAP ) THEN
+ WRITE(OUTNUM,4000) ERRIBUF(4,I), ERRIBUF(5,I),
+ $ ERRDBUF(2,I), ERRDBUF(1,I)
+ ELSE IF( ERRTYPE .EQ. ERR_TRI ) THEN
+ WRITE(OUTNUM,5000) ERRIBUF(4,I), ERRIBUF(5,I),
+ $ ERRDBUF(2,I), ERRDBUF(1,I)
+ ELSE
+ WRITE(OUTNUM,6000) ERRIBUF(4,I), ERRIBUF(5,I),
+ $ ERRDBUF(2,I), ERRDBUF(1,I)
+ END IF
+ END IF
+ 20 CONTINUE
+ WRITE(OUTNUM,12000) PROW, PCOL, OLDTEST
+*
+ 1000 FORMAT('PROCESS {',I4,',',I4,'} REPORTS ERRORS IN TEST#',I6,':')
+ 2000 FORMAT(' Buffer overwrite ',I4,
+ $ ' elements before the start of A:',/,
+ $ ' Expected=',G22.15,
+ $ '; Received=',G22.15)
+ 3000 FORMAT(' Buffer overwrite ',I4,' elements after the end of A:',
+ $ /,' Expected=',G22.15,
+ $ '; Received=',G22.15)
+ 4000 FORMAT(' LDA-M gap overwrite at postion (',I4,',',I4,'):',/,
+ $ ' Expected=',G22.15,
+ $ '; Received=',G22.15)
+ 5000 FORMAT(' Complementory triangle overwrite at A(',I4,',',I4,
+ $ '):',/,' Expected=',G22.15,
+ $ '; Received=',G22.15)
+ 6000 FORMAT(' Invalid element at A(',I4,',',I4,'):',/,
+ $ ' Expected=',G22.15,
+ $ '; Received=',G22.15)
+ 7000 FORMAT(' Buffer overwrite ',I4,' elements before the start of ',
+ $ A1,'A:',/,' Expected=',I12,'; Received=',I12)
+ 8000 FORMAT(' Buffer overwrite ',I4,' elements after the end of ',
+ $ A1,'A:',/,' Expected=',I12,'; Received=',I12)
+*
+ 9000 FORMAT(' LD',A1,'A-M gap overwrite at postion (',I4,',',I4,'):'
+ $ ,/,' Expected=',I12,'; Received=',I12)
+*
+10000 FORMAT(' Invalid element at ',A1,'A(',I4,',',I4,'):',/,
+ $ ' Expected=',I12,'; Received=',I12)
+11000 FORMAT(' Overwrite at position (',I4,',',I4,') of non-existent '
+ $ ,A1,'A array.',/,' Expected=',I12,'; Received=',I12)
+12000 FORMAT('PROCESS {',I4,',',I4,'} DONE ERROR REPORT FOR TEST#',
+ $ I6,'.')
+13000 FORMAT('WARNING: There were more errors than could be recorded.',
+ $ /,'Increase MEMELTS to get complete listing.')
+ RETURN
+*
+* End DPRINTERRS
+*
+ END
+*
+*
+ SUBROUTINE CBTCHECKIN( NFTESTS, OUTNUM, MAXERR, NERR, IERR,
+ $ CVAL, TFAILED )
+ INTEGER NFTESTS, OUTNUM, MAXERR, NERR
+ INTEGER IERR(*), TFAILED(*)
+ COMPLEX CVAL(*)
+*
+* Purpose
+* =======
+* CBTCHECKIN: Process 0 receives error report from all processes.
+*
+* Arguments
+* =========
+* NFTESTS (input/output) INTEGER
+* if NFTESTS is <= 0 upon entry, NFTESTS is not written to.
+* Otherwise, on entry it specifies the total number of tests
+* run, and on exit it is the number of tests which failed.
+*
+* OUTNUM (input) INTEGER
+* Device number for output.
+*
+* MAXERR (input) INTEGER
+* Max number of errors that can be stored in ERRIBUFF or
+* ERRCBUFF
+*
+* NERR (output) INTEGER
+* The number of errors that have been found.
+*
+* ERRIBUF (output) INTEGER array, dimension (6,MAXERRS)
+* Buffer in which to store integer error information. It will
+* be built up in the following format for the call to TSEND.
+* All integer information is recorded in the following 6-tuple
+* {TESTNUM, SRC, DEST, I, J, WHAT}. These values are figured:
+* SRC = RSRC * NPROCS + CSRC
+* DEST = RDEST * NPROCS + CDEST
+* WHAT
+* = 1 : Error in pre-padding
+* = 2 : Error in post-padding
+* = 3 : Error in LDA-M gap
+* = 4 : Error in complementory triangle
+* ELSE: Error in matrix
+* If there are more errors than can fit in the error buffer,
+* the error number will indicate the actual number of errors
+* found, but the buffer will be truncated to the maximum
+* number of errors which can fit.
+*
+* ERRDBUF (output) @(doctype) array, dimension (2, MAXERRS)
+* Buffer in which to store error data information.
+* {Incorrect, Predicted}
+*
+* TFAILED (workspace) INTEGER array, dimension NFTESTS
+* Workspace used to keep track of which tests failed.
+* If input of NFTESTS < 1, this array not accessed.
+*
+* ===================================================================
+*
+* .. External Functions ..
+ INTEGER IBTMYPROC, IBTNPROCS, IBTMSGID
+ EXTERNAL IBTMYPROC, IBTNPROCS, IBTMSGID
+* ..
+* .. Local Scalars ..
+ LOGICAL COUNTING
+ INTEGER K, NERR2, IAM, NPROCS, NTESTS
+*
+* Proc 0 collects error info from everyone
+*
+ IAM = IBTMYPROC()
+ NPROCS = IBTNPROCS()
+*
+ IF( IAM .EQ. 0 ) THEN
+*
+* If we are finding out how many failed tests there are, initialize
+* the total number of tests (NTESTS), and zero the test failed array
+*
+ COUNTING = NFTESTS .GT. 0
+ IF( COUNTING ) THEN
+ NTESTS = NFTESTS
+ DO 10 K = 1, NTESTS
+ TFAILED(K) = 0
+ 10 CONTINUE
+ END IF
+*
+ CALL CPRINTERRS(OUTNUM, MAXERR, NERR, IERR, CVAL, COUNTING,
+ $ TFAILED)
+*
+ DO 20 K = 1, NPROCS-1
+ CALL BTSEND(3, 0, K, K, IBTMSGID()+50)
+ CALL BTRECV(3, 1, NERR2, K, IBTMSGID()+50)
+ IF( NERR2 .GT. 0 ) THEN
+ NERR = NERR + NERR2
+ CALL BTRECV(3, NERR2*6, IERR, K, IBTMSGID()+51)
+ CALL BTRECV(5, NERR2*2, CVAL, K, IBTMSGID()+51)
+ CALL CPRINTERRS(OUTNUM, MAXERR, NERR2, IERR, CVAL,
+ $ COUNTING, TFAILED)
+ END IF
+ 20 CONTINUE
+*
+* Count up number of tests that failed
+*
+ IF( COUNTING ) THEN
+ NFTESTS = 0
+ DO 30 K = 1, NTESTS
+ NFTESTS = NFTESTS + TFAILED(K)
+ 30 CONTINUE
+ END IF
+*
+* Send my error info to proc 0
+*
+ ELSE
+ CALL BTRECV(3, 0, K, 0, IBTMSGID()+50)
+ CALL BTSEND(3, 1, NERR, 0, IBTMSGID()+50)
+ IF( NERR .GT. 0 ) THEN
+ CALL BTSEND(3, NERR*6, IERR, 0, IBTMSGID()+51)
+ CALL BTSEND(5, NERR*2, CVAL, 0, IBTMSGID()+51)
+ END IF
+ ENDIF
+*
+ RETURN
+*
+* End of CBTCHECKIN
+*
+ END
+*
+ SUBROUTINE CINITMAT(UPLO, DIAG, M, N, MEM, LDA, IPRE, IPOST,
+ $ CHECKVAL, TESTNUM, MYROW, MYCOL)
+ CHARACTER*1 UPLO, DIAG
+ INTEGER M, N, LDA, IPRE, IPOST, TESTNUM, MYROW, MYCOL
+ COMPLEX CHECKVAL
+ COMPLEX MEM(*)
+*
+* .. External Subroutines ..
+ EXTERNAL CGENMAT, CPADMAT
+* ..
+* .. Executable Statements ..
+*
+ CALL CGENMAT( M, N, MEM(IPRE+1), LDA, TESTNUM, MYROW, MYCOL )
+ CALL CPADMAT( UPLO, DIAG, M, N, MEM, LDA, IPRE, IPOST, CHECKVAL )
+*
+ RETURN
+ END
+*
+ SUBROUTINE CGENMAT( M, N, A, LDA, TESTNUM, MYROW, MYCOL )
+*
+* -- BLACS tester (version 1.0) --
+* University of Tennessee
+* December 15, 1994
+*
+*
+* .. Scalar Arguments ..
+ INTEGER M, N, LDA, TESTNUM, MYROW, MYCOL
+* ..
+* .. Array Arguments ..
+ COMPLEX A(LDA,N)
+* ..
+*
+* Purpose
+* =======
+* CGENMAT: Generates an M-by-N matrix filled with random elements.
+*
+* Arguments
+* =========
+* M (input) INTEGER
+* The number of rows of the matrix A. M >= 0.
+*
+* N (input) INTEGER
+* The number of columns of the matrix A. N >= 0.
+*
+* A (output) @up@(doctype) array, dimension (LDA,N)
+* The m by n matrix A. Fortran77 (column-major) storage
+* assumed.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1, M).
+*
+* TESTNUM (input) INTEGER
+* Unique number for this test case, used as a basis for
+* the random seeds.
+*
+* ====================================================================
+*
+* .. External Functions ..
+ INTEGER IBTNPROCS
+ COMPLEX CBTRAN
+ EXTERNAL CBTRAN, IBTNPROCS
+* ..
+* .. Local Scalars ..
+ INTEGER I, J, NPROCS, SRC
+* ..
+* .. Local Arrays ..
+ INTEGER ISEED(4)
+* ..
+* .. Executable Statements ..
+*
+* ISEED's four values must be positive integers less than 4096,
+* fourth one has to be odd. (see _LARND). Use some goofy
+* functions to come up with seed values which together should
+* be unique.
+*
+ NPROCS = IBTNPROCS()
+ SRC = MYROW * NPROCS + MYCOL
+ ISEED(1) = MOD( 1002 + TESTNUM*5 + SRC*3, 4096 )
+ ISEED(2) = MOD( 2027 + TESTNUM*7 + SRC, 4096 )
+ ISEED(3) = MOD( 1234 + TESTNUM + SRC*3, 4096 )
+ ISEED(4) = MOD( 4311 + TESTNUM*10 + SRC*2, 4096 )
+*
+ DO 10 J = 1, N
+ DO 10 I = 1, M
+ A(I, J) = CBTRAN( ISEED )
+ 10 CONTINUE
+*
+ RETURN
+*
+* End of CGENMAT.
+*
+ END
+*
+ COMPLEX FUNCTION CBTRAN(ISEED)
+ INTEGER ISEED(*)
+*
+* .. External Functions ..
+ DOUBLE COMPLEX ZLARND
+ EXTERNAL ZLARND
+ CBTRAN = CMPLX( ZLARND(2, ISEED) )
+*
+ RETURN
+*
+* End of Cbtran
+*
+ END
+*
+ SUBROUTINE CPADMAT( UPLO, DIAG, M, N, MEM, LDA, IPRE, IPOST,
+ $ CHECKVAL )
+*
+* -- BLACS tester (version 1.0) --
+* University of Tennessee
+* December 15, 1994
+*
+* .. Scalar Arguments ..
+ CHARACTER*1 UPLO, DIAG
+ INTEGER M, N, LDA, IPRE, IPOST
+ COMPLEX CHECKVAL
+* ..
+* .. Array Arguments ..
+ COMPLEX MEM( * )
+* ..
+*
+* Purpose
+* =======
+*
+* CPADMAT: Pad Matrix.
+* This routines surrounds a matrix with a guardzone initialized to the
+* value CHECKVAL. There are three distinct guardzones:
+* - A contiguous zone of size IPRE immediately before the start
+* of the matrix.
+* - A contiguous zone of size IPOST immedately after the end of the
+* matrix.
+* - Interstitial zones within each column of the matrix, in the
+* elements A( M+1:LDA, J ).
+*
+* Arguments
+* =========
+* UPLO (input) CHARACTER*1
+* Is the matrix A 'U'pper or 'L'ower trapezoidal, or 'G'eneral
+* rectangular?
+*
+* DIAG (input) CHARACTER*1
+* For trapezoidal matrices, is the main diagonal included
+* ('N') or not ('U')?
+*
+* M (input) INTEGER
+* The number of rows of the matrix A. M >= 0.
+*
+* N (input) INTEGER
+* The number of columns of the matrix A. N >= 0.
+*
+* MEM (output) complex array, dimension (IPRE+IPOST+LDA*N)
+* The address IPRE elements ahead of the matrix A you want to
+* pad, which is then of dimension (LDA,N).
+*
+* IPRE (input) INTEGER
+* The size of the guard zone ahead of the matrix A.
+*
+* IPOST (input) INTEGER
+* The size of the guard zone behind the matrix A.
+*
+* CHECKVAL (input) complex
+* The value to insert into the guard zones.
+*
+* ====================================================================
+*
+* .. Local Scalars ..
+ INTEGER I, J, K
+* ..
+* .. Executable Statements ..
+*
+* Put check buffer in front of A
+*
+ IF( IPRE .GT. 0 ) THEN
+ DO 10 I = 1, IPRE
+ MEM( I ) = CHECKVAL
+ 10 CONTINUE
+ END IF
+*
+* Put check buffer in back of A
+*
+ IF( IPOST .GT. 0 ) THEN
+ J = IPRE + LDA*N + 1
+ DO 20 I = J, J+IPOST-1
+ MEM( I ) = CHECKVAL
+ 20 CONTINUE
+ END IF
+*
+* Put check buffer in all (LDA-M) gaps
+*
+ IF( LDA .GT. M ) THEN
+ K = IPRE + M + 1
+ DO 40 J = 1, N
+ DO 30 I = K, K+LDA-M-1
+ MEM( I ) = CHECKVAL
+ 30 CONTINUE
+ K = K + LDA
+ 40 CONTINUE
+ END IF
+*
+* If the matrix is upper or lower trapezoidal, calculate the
+* additional triangular area which needs to be padded, Each
+* element referred to is in the Ith row and the Jth column.
+*
+ IF( UPLO .EQ. 'U' ) THEN
+ IF( M .LE. N ) THEN
+ IF( DIAG .EQ. 'U' ) THEN
+ DO 41 I = 1, M
+ DO 42 J = 1, I
+ K = IPRE + I + (J-1)*LDA
+ MEM( K ) = CHECKVAL
+ 42 CONTINUE
+ 41 CONTINUE
+ ELSE
+ DO 43 I = 2, M
+ DO 44 J = 1, I-1
+ K = IPRE + I + (J-1)*LDA
+ MEM( K ) = CHECKVAL
+ 44 CONTINUE
+ 43 CONTINUE
+ END IF
+ ELSE
+ IF( DIAG .EQ. 'U' ) THEN
+ DO 45 I = M-N+1, M
+ DO 46 J = 1, I-(M-N)
+ K = IPRE + I + (J-1)*LDA
+ MEM( K ) = CHECKVAL
+ 46 CONTINUE
+ 45 CONTINUE
+ ELSE
+ DO 47 I = M-N+2, M
+ DO 48 J = 1, I-(M-N)-1
+ K = IPRE + I + (J-1)*LDA
+ MEM( K ) = CHECKVAL
+ 48 CONTINUE
+ 47 CONTINUE
+ END IF
+ END IF
+ ELSE IF( UPLO .EQ. 'L' ) THEN
+ IF( M .LE. N ) THEN
+ IF( DIAG .EQ. 'U' ) THEN
+ DO 49 I = 1, M
+ DO 50 J = N-M+I, N
+ K = IPRE + I + (J-1)*LDA
+ MEM( K ) = CHECKVAL
+ 50 CONTINUE
+ 49 CONTINUE
+ ELSE
+ DO 51 I = 1, M-1
+ DO 52 J = N-M+I+1, N
+ K = IPRE + I + (J-1)*LDA
+ MEM( K ) = CHECKVAL
+ 52 CONTINUE
+ 51 CONTINUE
+ END IF
+ ELSE
+ IF( UPLO .EQ. 'U' ) THEN
+ DO 53 I = 1, N
+ DO 54 J = I, N
+ K = IPRE + I + (J-1)*LDA
+ MEM( K ) = CHECKVAL
+ 54 CONTINUE
+ 53 CONTINUE
+ ELSE
+ DO 55 I = 1, N-1
+ DO 56 J = I+1, N
+ K = IPRE + I + (J-1)*LDA
+ MEM( K ) = CHECKVAL
+ 56 CONTINUE
+ 55 CONTINUE
+ END IF
+ END IF
+ END IF
+*
+* End of CPADMAT.
+*
+ RETURN
+ END
+*
+ SUBROUTINE CCHKPAD( UPLO, DIAG, M, N, MEM, LDA, RSRC, CSRC,
+ $ MYROW, MYCOL, IPRE, IPOST, CHECKVAL,
+ $ TESTNUM, MAXERR, NERR, ERRIBUF, ERRDBUF )
+*
+* -- BLACS tester (version 1.0) --
+* University of Tennessee
+* December 15, 1994
+*
+*
+* .. Scalar Arguments ..
+ CHARACTER*1 UPLO, DIAG
+ INTEGER M, N, LDA, RSRC, CSRC, MYROW, MYCOL, IPRE, IPOST
+ INTEGER TESTNUM, MAXERR, NERR
+ COMPLEX CHECKVAL
+* ..
+* .. Array Arguments ..
+ INTEGER ERRIBUF(6, MAXERR)
+ COMPLEX MEM(*), ERRDBUF(2, MAXERR)
+* ..
+*
+* Purpose
+* =======
+* CCHKPAD: Check padding put in by PADMAT.
+* Checks that padding around target matrix has not been overwritten
+* by the previous point-to-point or broadcast send.
+*
+* Arguments
+* =========
+* UPLO (input) CHARACTER*1
+* Is the matrix A 'U'pper or 'L'ower trapezoidal, or 'G'eneral
+* rectangular?
+*
+* DIAG (input) CHARACTER*1
+* For trapezoidal matrices, is the main diagonal included
+* ('N') or not ('U')?
+*
+* M (input) INTEGER
+* The number of rows of the matrix A. M >= 0.
+*
+* N (input) INTEGER
+* The number of columns of the matrix A. N >= 0.
+*
+* MEM (input) complex array, dimension(IPRE+IPOST+LDA*N).
+* Memory location IPRE elements in front of the matrix A.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1, M).
+*
+* RSRC (input) INTEGER
+* The process row of the source of the matrix.
+*
+* CSRC (input) INTEGER
+* The process column of the source of the matrix.
+*
+* MYROW (input) INTEGER
+* Row of this process in the process grid.
+*
+* MYCOL (input) INTEGER
+* Column of this process in the process grid.
+*
+* IPRE (input) INTEGER
+* The size of the guard zone before the start of A.
+*
+* IPOST (input) INTEGER
+* The size of guard zone after A.
+*
+* CHECKVAL (input) complex
+* The value to pad matrix with.
+*
+* TESTNUM (input) INTEGER
+* The number of the test being checked.
+*
+* MAXERR (input) INTEGER
+* Max number of errors that can be stored in ERRIBUFF or
+* ERRCBUFF
+*
+* NERR (output) INTEGER
+* The number of errors that have been found.
+*
+* ERRIBUF (output) INTEGER array, dimension (6,MAXERRS)
+* Buffer in which to store integer error information. It will
+* be built up in the following format for the call to TSEND.
+* All integer information is recorded in the following 6-tuple
+* {TESTNUM, SRC, DEST, I, J, WHAT}. These values are figured:
+* SRC = RSRC * NPROCS + CSRC
+* DEST = RDEST * NPROCS + CDEST
+* WHAT
+* = 1 : Error in pre-padding
+* = 2 : Error in post-padding
+* = 3 : Error in LDA-M gap
+* = 4 : Error in complementory triangle
+* ELSE: Error in matrix
+* If there are more errors than can fit in the error buffer,
+* the error number will indicate the actual number of errors
+* found, but the buffer will be truncated to the maximum
+* number of errors which can fit.
+*
+* ERRDBUF (output) @(doctype) array, dimension (2, MAXERRS)
+* Buffer in which to store error data information.
+* {Incorrect, Predicted}
+*
+* ===================================================================
+*
+* .. Parameters ..
+ INTEGER ERR_PRE, ERR_POST, ERR_GAP, ERR_TRI, ERR_MAT
+ PARAMETER( ERR_PRE = 1, ERR_POST = 2, ERR_GAP = 3, ERR_TRI = 4 )
+ PARAMETER( ERR_MAT = 5 )
+* ..
+* .. External Functions ..
+ INTEGER IBTNPROCS
+ EXTERNAL IBTNPROCS
+* ..
+* .. Local Scalars ..
+ LOGICAL ISTRAP
+ INTEGER I, J, K, IRST, IRND, ICST, ICND, SRC, DEST
+ INTEGER NPROCS
+* ..
+* .. Executable Statements ..
+*
+ NPROCS = IBTNPROCS()
+ SRC = RSRC * NPROCS + CSRC
+ DEST = MYROW * NPROCS + MYCOL
+*
+* Check buffer in front of A
+*
+ IF( IPRE .GT. 0 ) THEN
+ DO 10 I = 1, IPRE
+ IF( MEM(I) .NE. CHECKVAL ) THEN
+ NERR = NERR + 1
+ IF( NERR .LE. MAXERR ) THEN
+ ERRIBUF(1, NERR) = TESTNUM
+ ERRIBUF(2, NERR) = SRC
+ ERRIBUF(3, NERR) = DEST
+ ERRIBUF(4, NERR) = I
+ ERRIBUF(5, NERR) = IPRE - I + 1
+ ERRIBUF(6, NERR) = ERR_PRE
+ ERRDBUF(1, NERR) = MEM(I)
+ ERRDBUF(2, NERR) = CHECKVAL
+ END IF
+ END IF
+ 10 CONTINUE
+ END IF
+*
+* Check buffer behind A
+*
+ IF( IPOST .GT. 0 ) THEN
+ J = IPRE + LDA*N + 1
+ DO 20 I = J, J+IPOST-1
+ IF( MEM(I) .NE. CHECKVAL ) THEN
+ NERR = NERR + 1
+ IF( NERR .LE. MAXERR ) THEN
+ ERRIBUF(1, NERR) = TESTNUM
+ ERRIBUF(2, NERR) = SRC
+ ERRIBUF(3, NERR) = DEST
+ ERRIBUF(4, NERR) = I - J + 1
+ ERRIBUF(5, NERR) = J
+ ERRIBUF(6, NERR) = ERR_POST
+ ERRDBUF(1, NERR) = MEM(I)
+ ERRDBUF(2, NERR) = CHECKVAL
+ END IF
+ END IF
+ 20 CONTINUE
+ END IF
+*
+* Check all (LDA-M) gaps
+*
+ IF( LDA .GT. M ) THEN
+ DO 40 J = 1, N
+ DO 30 I = M+1, LDA
+ K = IPRE + (J-1)*LDA + I
+ IF( MEM(K) .NE. CHECKVAL) THEN
+ NERR = NERR + 1
+ IF( NERR .LE. MAXERR ) THEN
+ ERRIBUF(1, NERR) = TESTNUM
+ ERRIBUF(2, NERR) = SRC
+ ERRIBUF(3, NERR) = DEST
+ ERRIBUF(4, NERR) = I
+ ERRIBUF(5, NERR) = J
+ ERRIBUF(6, NERR) = ERR_GAP
+ ERRDBUF(1, NERR) = MEM(K)
+ ERRDBUF(2, NERR) = CHECKVAL
+ END IF
+ END IF
+ 30 CONTINUE
+ 40 CONTINUE
+ END IF
+*
+* Determine limits of trapezoidal matrix
+*
+ ISTRAP = .FALSE.
+ IF( UPLO .EQ. 'U' ) THEN
+ ISTRAP = .TRUE.
+ IF( M .LE. N ) THEN
+ IRST = 2
+ IRND = M
+ ICST = 1
+ ICND = M - 1
+ ELSEIF( M .GT. N ) THEN
+ IRST = ( M-N ) + 2
+ IRND = M
+ ICST = 1
+ ICND = N - 1
+ ENDIF
+ IF( DIAG .EQ. 'U' ) THEN
+ IRST = IRST - 1
+ ICND = ICND + 1
+ ENDIF
+ ELSE IF( UPLO .EQ. 'L' ) THEN
+ ISTRAP = .TRUE.
+ IF( M .LE. N ) THEN
+ IRST = 1
+ IRND = 1
+ ICST = ( N-M ) + 2
+ ICND = N
+ ELSEIF( M .GT. N ) THEN
+ IRST = 1
+ IRND = 1
+ ICST = 2
+ ICND = N
+ ENDIF
+ IF( DIAG .EQ. 'U' ) THEN
+ ICST = ICST - 1
+ ENDIF
+ ENDIF
+*
+* Check elements and report any errors
+*
+ IF( ISTRAP ) THEN
+ DO 100 J = ICST, ICND
+ DO 105 I = IRST, IRND
+ IF( MEM( IPRE + (J-1)*LDA + I ) .NE. CHECKVAL ) THEN
+ NERR = NERR + 1
+ IF( NERR .LE. MAXERR ) THEN
+ ERRIBUF(1, NERR) = TESTNUM
+ ERRIBUF(2, NERR) = SRC
+ ERRIBUF(3, NERR) = DEST
+ ERRIBUF(4, NERR) = I
+ ERRIBUF(5, NERR) = J
+ ERRIBUF(6, NERR) = ERR_TRI
+ ERRDBUF(1, NERR) = MEM( IPRE + (J-1)*LDA + I )
+ ERRDBUF(2, NERR) = CHECKVAL
+ END IF
+ END IF
+ 105 CONTINUE
+*
+* Update the limits to allow filling in padding
+*
+ IF( UPLO .EQ. 'U' ) THEN
+ IRST = IRST + 1
+ ELSE
+ IRND = IRND + 1
+ ENDIF
+ 100 CONTINUE
+ END IF
+*
+ RETURN
+*
+* End of CCHKPAD.
+*
+ END
+*
+ SUBROUTINE CCHKMAT( UPLO, DIAG, M, N, A, LDA, RSRC, CSRC,
+ $ MYROW, MYCOL, TESTNUM, MAXERR, NERR,
+ $ ERRIBUF, ERRDBUF )
+*
+* -- BLACS tester (version 1.0) --
+* University of Tennessee
+* December 15, 1994
+*
+*
+* .. Scalar Arguments ..
+ CHARACTER*1 UPLO, DIAG
+ INTEGER M, N, LDA, RSRC, CSRC, MYROW, MYCOL, TESTNUM
+ INTEGER MAXERR, NERR
+* ..
+* .. Array Arguments ..
+ INTEGER ERRIBUF(6, MAXERR)
+ COMPLEX A(LDA,N), ERRDBUF(2, MAXERR)
+* ..
+*
+* Purpose
+* =======
+* cCHKMAT: Check matrix to see whether there were any transmission
+* errors.
+*
+* Arguments
+* =========
+* UPLO (input) CHARACTER*1
+* Is the matrix A 'U'pper or 'L'ower trapezoidal, or 'G'eneral
+* rectangular?
+*
+* DIAG (input) CHARACTER*1
+* For trapezoidal matrices, is the main diagonal included
+* ('N') or not ('U')?
+*
+* M (input) INTEGER
+* The number of rows of the matrix A. M >= 0.
+*
+* N (input) INTEGER
+* The number of columns of the matrix A. N >= 0.
+*
+* A (input) @up@(doctype) array, dimension (LDA,N)
+* The m by n matrix A. Fortran77 (column-major) storage
+* assumed.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1, M).
+*
+* RSRC (input) INTEGER
+* The process row of the source of the matrix.
+*
+* CSRC (input) INTEGER
+* The process column of the source of the matrix.
+*
+* MYROW (input) INTEGER
+* Row of this process in the process grid.
+*
+* MYCOL (input) INTEGER
+* Column of this process in the process grid.
+*
+*
+* TESTNUM (input) INTEGER
+* The number of the test being checked.
+*
+* MAXERR (input) INTEGER
+* Max number of errors that can be stored in ERRIBUFF or
+* ERRCBUFF
+*
+* NERR (output) INTEGER
+* The number of errors that have been found.
+*
+* ERRIBUF (output) INTEGER array, dimension (6,MAXERRS)
+* Buffer in which to store integer error information. It will
+* be built up in the following format for the call to TSEND.
+* All integer information is recorded in the following 6-tuple
+* {TESTNUM, SRC, DEST, I, J, WHAT}. These values are figured:
+* SRC = RSRC * NPROCS + CSRC
+* DEST = RDEST * NPROCS + CDEST
+* WHAT
+* = 1 : Error in pre-padding
+* = 2 : Error in post-padding
+* = 3 : Error in LDA-M gap
+* = 4 : Error in complementory triangle
+* ELSE: Error in matrix
+* If there are more errors than can fit in the error buffer,
+* the error number will indicate the actual number of errors
+* found, but the buffer will be truncated to the maximum
+* number of errors which can fit.
+*
+* ERRDBUF (output) @(doctype) array, dimension (2, MAXERRS)
+* Buffer in which to store error data information.
+* {Incorrect, Predicted}
+*
+* ===================================================================
+*
+* .. Local Scalars ..
+ INTEGER I, J, NPROCS, SRC, DEST
+ LOGICAL USEIT
+ COMPLEX COMPVAL
+* ..
+* .. Local Arrays ..
+ INTEGER ISEED(4)
+* ..
+* .. External Functions ..
+ INTEGER IBTNPROCS
+ COMPLEX CBTRAN
+ EXTERNAL CBTRAN, IBTNPROCS
+* ..
+* .. Executable Statements ..
+*
+ NPROCS = IBTNPROCS()
+ SRC = RSRC * NPROCS + CSRC
+ DEST = MYROW * NPROCS + MYCOL
+*
+* Initialize ISEED with the same values as used in CGENMAT.
+*
+ ISEED(1) = MOD( 1002 + TESTNUM*5 + SRC*3, 4096 )
+ ISEED(2) = MOD( 2027 + TESTNUM*7 + SRC, 4096 )
+ ISEED(3) = MOD( 1234 + TESTNUM + SRC*3, 4096 )
+ ISEED(4) = MOD( 4311 + TESTNUM*10 + SRC*2, 4096 )
+*
+* Generate the elements randomly with the same method used in GENMAT.
+* Note that for trapezoidal matrices, we generate all elements in the
+* enclosing rectangle and then ignore the complementary triangle.
+*
+ DO 100 J = 1, N
+ DO 105 I = 1, M
+ COMPVAL = CBTRAN( ISEED )
+*
+* Now determine whether we actually need this value. The
+* strategy is to chop out the proper triangle based on what
+* particular kind of trapezoidal matrix we're dealing with.
+*
+ USEIT = .TRUE.
+ IF( UPLO .EQ. 'U' ) THEN
+ IF( M .LE. N ) THEN
+ IF( DIAG .EQ. 'U' ) THEN
+ IF( I .GE. J ) THEN
+ USEIT = .FALSE.
+ END IF
+ ELSE
+ IF( I .GT. J ) THEN
+ USEIT = .FALSE.
+ END IF
+ END IF
+ ELSE
+ IF( DIAG .EQ. 'U' ) THEN
+ IF( I .GE. M-N+J ) THEN
+ USEIT = .FALSE.
+ END IF
+ ELSE
+ IF( I .GT. M-N+J ) THEN
+ USEIT = .FALSE.
+ END IF
+ END IF
+ END IF
+ ELSE IF( UPLO .EQ. 'L' ) THEN
+ IF( M .LE. N ) THEN
+ IF( DIAG .EQ. 'U' ) THEN
+ IF( J. GE. I+(N-M) ) THEN
+ USEIT = .FALSE.
+ END IF
+ ELSE
+ IF( J .GT. I+(N-M) ) THEN
+ USEIT = .FALSE.
+ END IF
+ END IF
+ ELSE
+ IF( DIAG .EQ. 'U' ) THEN
+ IF( J .GE. I ) THEN
+ USEIT = .FALSE.
+ END IF
+ ELSE
+ IF( J .GT. I ) THEN
+ USEIT = .FALSE.
+ END IF
+ END IF
+ END IF
+ END IF
+*
+* Compare the generated value to the one that's in the
+* received matrix. If they don't match, tack another
+* error record onto what's already there.
+*
+ IF( USEIT ) THEN
+ IF( A(I,J) .NE. COMPVAL ) THEN
+ NERR = NERR + 1
+ IF( NERR .LE. MAXERR ) THEN
+ ERRIBUF(1, NERR) = TESTNUM
+ ERRIBUF(2, NERR) = SRC
+ ERRIBUF(3, NERR) = DEST
+ ERRIBUF(4, NERR) = I
+ ERRIBUF(5, NERR) = J
+ ERRIBUF(6, NERR) = 5
+ ERRDBUF(1, NERR) = A(I, J)
+ ERRDBUF(2, NERR) = COMPVAL
+ END IF
+ END IF
+ END IF
+ 105 CONTINUE
+ 100 CONTINUE
+ RETURN
+*
+* End of CCHKMAT.
+*
+ END
+*
+ SUBROUTINE CPRINTERRS( OUTNUM, MAXERR, NERR,
+ $ ERRIBUF, ERRDBUF, COUNTING, TFAILED )
+*
+* -- BLACS tester (version 1.0) --
+* University of Tennessee
+* December 15, 1994
+*
+*
+* .. Scalar Arguments ..
+ LOGICAL COUNTING
+ INTEGER OUTNUM, MAXERR, NERR
+* ..
+* .. Array Arguments ..
+ INTEGER ERRIBUF(6, MAXERR), TFAILED(*)
+ COMPLEX ERRDBUF(2, MAXERR)
+* ..
+*
+* Purpose
+* =======
+* CPRINTERRS: Print errors that have been recorded
+*
+* Arguments
+* =========
+* OUTNUM (input) INTEGER
+* Device number for output.
+*
+* MAXERR (input) INTEGER
+* Max number of errors that can be stored in ERRIBUFF or
+* ERRCBUFF
+*
+* NERR (output) INTEGER
+* The number of errors that have been found.
+*
+* ERRIBUF (output) INTEGER array, dimension (6,MAXERRS)
+* Buffer in which to store integer error information. It will
+* be built up in the following format for the call to TSEND.
+* All integer information is recorded in the following 6-tuple
+* {TESTNUM, SRC, DEST, I, J, WHAT}. These values are figured:
+* SRC = RSRC * NPROCS + CSRC
+* DEST = RDEST * NPROCS + CDEST
+* WHAT
+* = 1 : Error in pre-padding
+* = 2 : Error in post-padding
+* = 3 : Error in LDA-M gap
+* = 4 : Error in complementory triangle
+* ELSE: Error in matrix
+* If there are more errors than can fit in the error buffer,
+* the error number will indicate the actual number of errors
+* found, but the buffer will be truncated to the maximum
+* number of errors which can fit.
+*
+* ERRDBUF (output) @(doctype) array, dimension (2, MAXERRS)
+* Buffer in which to store error data information.
+* {Incorrect, Predicted}
+*
+* TFAILED (input/ourput) INTEGER array, dimension NTESTS
+* Workspace used to keep track of which tests failed.
+* This array not accessed unless COUNTING is true.
+*
+* ===================================================================
+*
+* .. Parameters ..
+ INTEGER ERR_PRE, ERR_POST, ERR_GAP, ERR_TRI, ERR_MAT
+ PARAMETER( ERR_PRE = 1, ERR_POST = 2, ERR_GAP = 3, ERR_TRI = 4 )
+ PARAMETER( ERR_MAT = 5 )
+* ..
+* .. External Functions ..
+ INTEGER IBTMYPROC, IBTNPROCS
+ EXTERNAL IBTMYPROC, IBTNPROCS
+* ..
+* .. Local Scalars ..
+ CHARACTER*1 MAT
+ LOGICAL MATISINT
+ INTEGER OLDTEST, NPROCS, PROW, PCOL, I, ERRTYPE
+* ..
+* .. Executable Statements ..
+*
+ IF( (IBTMYPROC().NE.0) .OR. (NERR.LE.0) ) RETURN
+ OLDTEST = -1
+ NPROCS = IBTNPROCS()
+ PROW = ERRIBUF(3,1) / NPROCS
+ PCOL = MOD( ERRIBUF(3,1), NPROCS )
+ IF( NERR .GT. MAXERR ) WRITE(OUTNUM,13000)
+*
+ DO 20 I = 1, MIN( NERR, MAXERR )
+ IF( ERRIBUF(1,I) .NE. OLDTEST ) THEN
+ IF( OLDTEST .NE. -1 )
+ $ WRITE(OUTNUM,12000) PROW, PCOL, OLDTEST
+ WRITE(OUTNUM,*) ' '
+ WRITE(OUTNUM,1000) PROW, PCOL, ERRIBUF(1,I)
+ IF( COUNTING ) TFAILED( ERRIBUF(1,I) ) = 1
+ OLDTEST = ERRIBUF(1, I)
+ END IF
+*
+* Print out error message depending on type of error
+*
+ ERRTYPE = ERRIBUF(6, I)
+ IF( ERRTYPE .LT. -10 ) THEN
+ ERRTYPE = -ERRTYPE - 10
+ MAT = 'C'
+ MATISINT = .TRUE.
+ ELSE IF( ERRTYPE .LT. 0 ) THEN
+ ERRTYPE = -ERRTYPE
+ MAT = 'R'
+ MATISINT = .TRUE.
+ ELSE
+ MATISINT = .FALSE.
+ END IF
+*
+* RA/CA arrays from MAX/MIN have different printing protocol
+*
+ IF( MATISINT ) THEN
+ IF( ERRIBUF(2, I) .EQ. -1 ) THEN
+ WRITE(OUTNUM,11000) ERRIBUF(4,I), ERRIBUF(5,I), MAT,
+ $ INT( ERRDBUF(2,I) ), INT( ERRDBUF(1,I) )
+ ELSE IF( ERRTYPE .EQ. ERR_PRE ) THEN
+ WRITE(OUTNUM,7000) ERRIBUF(5,I), MAT,
+ $ INT( ERRDBUF(2,I) ), INT( ERRDBUF(1,I) )
+ ELSE IF( ERRTYPE .EQ. ERR_POST ) THEN
+ WRITE(OUTNUM,8000) ERRIBUF(4,I), MAT,
+ $ INT( ERRDBUF(2,I) ), INT( ERRDBUF(1,I) )
+ ELSE IF( ERRTYPE .EQ. ERR_GAP ) THEN
+ WRITE(OUTNUM,9000) MAT, ERRIBUF(4,I), ERRIBUF(5,I),
+ $ INT( ERRDBUF(2,I) ), INT( ERRDBUF(1,I) )
+ ELSE
+ WRITE(OUTNUM,10000) MAT, ERRIBUF(4,I), ERRIBUF(5,I),
+ $ INT( ERRDBUF(2,I) ),
+ $ INT( ERRDBUF(1,I) )
+ END IF
+*
+* Have memory overwrites in matrix A
+*
+ ELSE
+ IF( ERRTYPE .EQ. ERR_PRE ) THEN
+ WRITE(OUTNUM,2000) ERRIBUF(5,I),
+ $ REAL( ERRDBUF(2,I) ), AIMAG( ERRDBUF(2,I) ),
+ $ REAL( ERRDBUF(1,I) ), AIMAG( ERRDBUF(1,I) )
+ ELSE IF( ERRTYPE .EQ. ERR_POST ) THEN
+ WRITE(OUTNUM,3000) ERRIBUF(4,I),
+ $ REAL( ERRDBUF(2,I) ), AIMAG( ERRDBUF(2,I) ),
+ $ REAL( ERRDBUF(1,I) ), AIMAG( ERRDBUF(1,I) )
+ ELSE IF( ERRTYPE .EQ. ERR_GAP ) THEN
+ WRITE(OUTNUM,4000)
+ $ ERRIBUF(4,I), ERRIBUF(5,I),
+ $ REAL( ERRDBUF(2,I) ), AIMAG( ERRDBUF(2,I) ),
+ $ REAL( ERRDBUF(1,I) ), AIMAG( ERRDBUF(1,I) )
+ ELSE IF( ERRTYPE .EQ. ERR_TRI ) THEN
+ WRITE(OUTNUM,5000) ERRIBUF(4,I), ERRIBUF(5,I),
+ $ REAL( ERRDBUF(2,I) ), AIMAG( ERRDBUF(2,I) ),
+ $ REAL( ERRDBUF(1,I) ), AIMAG( ERRDBUF(1,I) )
+ ELSE
+ WRITE(OUTNUM,6000) ERRIBUF(4,I), ERRIBUF(5,I),
+ $ REAL( ERRDBUF(2,I) ), AIMAG( ERRDBUF(2,I) ),
+ $ REAL( ERRDBUF(1,I) ), AIMAG( ERRDBUF(1,I) )
+ END IF
+ END IF
+ 20 CONTINUE
+ WRITE(OUTNUM,12000) PROW, PCOL, OLDTEST
+*
+ 1000 FORMAT('PROCESS {',I4,',',I4,'} REPORTS ERRORS IN TEST#',I6,':')
+ 2000 FORMAT(' Buffer overwrite ',I4,
+ $ ' elements before the start of A:',/,
+ $ ' Expected=','[',G15.8,',',G15.8,']',
+ $ '; Received=','[',G15.8,',',G15.8,']')
+ 3000 FORMAT(' Buffer overwrite ',I4,' elements after the end of A:',
+ $ /,' Expected=','[',G15.8,',',G15.8,']',
+ $ '; Received=','[',G15.8,',',G15.8,']')
+ 4000 FORMAT(' LDA-M gap overwrite at postion (',I4,',',I4,'):',/,
+ $ ' Expected=','[',G15.8,',',G15.8,']',
+ $ '; Received=','[',G15.8,',',G15.8,']')
+ 5000 FORMAT(' Complementory triangle overwrite at A(',I4,',',I4,
+ $ '):',/,' Expected=','[',G15.8,',',G15.8,']',
+ $ '; Received=','[',G15.8,',',G15.8,']')
+ 6000 FORMAT(' Invalid element at A(',I4,',',I4,'):',/,
+ $ ' Expected=','[',G15.8,',',G15.8,']',
+ $ '; Received=','[',G15.8,',',G15.8,']')
+ 7000 FORMAT(' Buffer overwrite ',I4,' elements before the start of ',
+ $ A1,'A:',/,' Expected=',I12,'; Received=',I12)
+ 8000 FORMAT(' Buffer overwrite ',I4,' elements after the end of ',
+ $ A1,'A:',/,' Expected=',I12,'; Received=',I12)
+*
+ 9000 FORMAT(' LD',A1,'A-M gap overwrite at postion (',I4,',',I4,'):'
+ $ ,/,' Expected=',I12,'; Received=',I12)
+*
+10000 FORMAT(' Invalid element at ',A1,'A(',I4,',',I4,'):',/,
+ $ ' Expected=',I12,'; Received=',I12)
+11000 FORMAT(' Overwrite at position (',I4,',',I4,') of non-existent '
+ $ ,A1,'A array.',/,' Expected=',I12,'; Received=',I12)
+12000 FORMAT('PROCESS {',I4,',',I4,'} DONE ERROR REPORT FOR TEST#',
+ $ I6,'.')
+13000 FORMAT('WARNING: There were more errors than could be recorded.',
+ $ /,'Increase MEMELTS to get complete listing.')
+ RETURN
+*
+* End CPRINTERRS
+*
+ END
+*
+*
+ SUBROUTINE ZBTCHECKIN( NFTESTS, OUTNUM, MAXERR, NERR, IERR,
+ $ ZVAL, TFAILED )
+ INTEGER NFTESTS, OUTNUM, MAXERR, NERR
+ INTEGER IERR(*), TFAILED(*)
+ DOUBLE COMPLEX ZVAL(*)
+*
+* Purpose
+* =======
+* ZBTCHECKIN: Process 0 receives error report from all processes.
+*
+* Arguments
+* =========
+* NFTESTS (input/output) INTEGER
+* if NFTESTS is <= 0 upon entry, NFTESTS is not written to.
+* Otherwise, on entry it specifies the total number of tests
+* run, and on exit it is the number of tests which failed.
+*
+* OUTNUM (input) INTEGER
+* Device number for output.
+*
+* MAXERR (input) INTEGER
+* Max number of errors that can be stored in ERRIBUFF or
+* ERRZBUFF
+*
+* NERR (output) INTEGER
+* The number of errors that have been found.
+*
+* ERRIBUF (output) INTEGER array, dimension (6,MAXERRS)
+* Buffer in which to store integer error information. It will
+* be built up in the following format for the call to TSEND.
+* All integer information is recorded in the following 6-tuple
+* {TESTNUM, SRC, DEST, I, J, WHAT}. These values are figured:
+* SRC = RSRC * NPROCS + CSRC
+* DEST = RDEST * NPROCS + CDEST
+* WHAT
+* = 1 : Error in pre-padding
+* = 2 : Error in post-padding
+* = 3 : Error in LDA-M gap
+* = 4 : Error in complementory triangle
+* ELSE: Error in matrix
+* If there are more errors than can fit in the error buffer,
+* the error number will indicate the actual number of errors
+* found, but the buffer will be truncated to the maximum
+* number of errors which can fit.
+*
+* ERRDBUF (output) @(doctype) array, dimension (2, MAXERRS)
+* Buffer in which to store error data information.
+* {Incorrect, Predicted}
+*
+* TFAILED (workspace) INTEGER array, dimension NFTESTS
+* Workspace used to keep track of which tests failed.
+* If input of NFTESTS < 1, this array not accessed.
+*
+* ===================================================================
+*
+* .. External Functions ..
+ INTEGER IBTMYPROC, IBTNPROCS, IBTMSGID
+ EXTERNAL IBTMYPROC, IBTNPROCS, IBTMSGID
+* ..
+* .. Local Scalars ..
+ LOGICAL COUNTING
+ INTEGER K, NERR2, IAM, NPROCS, NTESTS
+*
+* Proc 0 collects error info from everyone
+*
+ IAM = IBTMYPROC()
+ NPROCS = IBTNPROCS()
+*
+ IF( IAM .EQ. 0 ) THEN
+*
+* If we are finding out how many failed tests there are, initialize
+* the total number of tests (NTESTS), and zero the test failed array
+*
+ COUNTING = NFTESTS .GT. 0
+ IF( COUNTING ) THEN
+ NTESTS = NFTESTS
+ DO 10 K = 1, NTESTS
+ TFAILED(K) = 0
+ 10 CONTINUE
+ END IF
+*
+ CALL ZPRINTERRS(OUTNUM, MAXERR, NERR, IERR, ZVAL, COUNTING,
+ $ TFAILED)
+*
+ DO 20 K = 1, NPROCS-1
+ CALL BTSEND(3, 0, K, K, IBTMSGID()+50)
+ CALL BTRECV(3, 1, NERR2, K, IBTMSGID()+50)
+ IF( NERR2 .GT. 0 ) THEN
+ NERR = NERR + NERR2
+ CALL BTRECV(3, NERR2*6, IERR, K, IBTMSGID()+51)
+ CALL BTRECV(7, NERR2*2, ZVAL, K, IBTMSGID()+51)
+ CALL ZPRINTERRS(OUTNUM, MAXERR, NERR2, IERR, ZVAL,
+ $ COUNTING, TFAILED)
+ END IF
+ 20 CONTINUE
+*
+* Count up number of tests that failed
+*
+ IF( COUNTING ) THEN
+ NFTESTS = 0
+ DO 30 K = 1, NTESTS
+ NFTESTS = NFTESTS + TFAILED(K)
+ 30 CONTINUE
+ END IF
+*
+* Send my error info to proc 0
+*
+ ELSE
+ CALL BTRECV(3, 0, K, 0, IBTMSGID()+50)
+ CALL BTSEND(3, 1, NERR, 0, IBTMSGID()+50)
+ IF( NERR .GT. 0 ) THEN
+ CALL BTSEND(3, NERR*6, IERR, 0, IBTMSGID()+51)
+ CALL BTSEND(7, NERR*2, ZVAL, 0, IBTMSGID()+51)
+ END IF
+ ENDIF
+*
+ RETURN
+*
+* End of ZBTCHECKIN
+*
+ END
+*
+ SUBROUTINE ZINITMAT(UPLO, DIAG, M, N, MEM, LDA, IPRE, IPOST,
+ $ CHECKVAL, TESTNUM, MYROW, MYCOL)
+ CHARACTER*1 UPLO, DIAG
+ INTEGER M, N, LDA, IPRE, IPOST, TESTNUM, MYROW, MYCOL
+ DOUBLE COMPLEX CHECKVAL
+ DOUBLE COMPLEX MEM(*)
+*
+* .. External Subroutines ..
+ EXTERNAL ZGENMAT, ZPADMAT
+* ..
+* .. Executable Statements ..
+*
+ CALL ZGENMAT( M, N, MEM(IPRE+1), LDA, TESTNUM, MYROW, MYCOL )
+ CALL ZPADMAT( UPLO, DIAG, M, N, MEM, LDA, IPRE, IPOST, CHECKVAL )
+*
+ RETURN
+ END
+*
+ SUBROUTINE ZGENMAT( M, N, A, LDA, TESTNUM, MYROW, MYCOL )
+*
+* -- BLACS tester (version 1.0) --
+* University of Tennessee
+* December 15, 1994
+*
+*
+* .. Scalar Arguments ..
+ INTEGER M, N, LDA, TESTNUM, MYROW, MYCOL
+* ..
+* .. Array Arguments ..
+ DOUBLE COMPLEX A(LDA,N)
+* ..
+*
+* Purpose
+* =======
+* ZGENMAT: Generates an M-by-N matrix filled with random elements.
+*
+* Arguments
+* =========
+* M (input) INTEGER
+* The number of rows of the matrix A. M >= 0.
+*
+* N (input) INTEGER
+* The number of columns of the matrix A. N >= 0.
+*
+* A (output) @up@(doctype) array, dimension (LDA,N)
+* The m by n matrix A. Fortran77 (column-major) storage
+* assumed.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1, M).
+*
+* TESTNUM (input) INTEGER
+* Unique number for this test case, used as a basis for
+* the random seeds.
+*
+* ====================================================================
+*
+* .. External Functions ..
+ INTEGER IBTNPROCS
+ DOUBLE COMPLEX ZBTRAN
+ EXTERNAL ZBTRAN, IBTNPROCS
+* ..
+* .. Local Scalars ..
+ INTEGER I, J, NPROCS, SRC
+* ..
+* .. Local Arrays ..
+ INTEGER ISEED(4)
+* ..
+* .. Executable Statements ..
+*
+* ISEED's four values must be positive integers less than 4096,
+* fourth one has to be odd. (see _LARND). Use some goofy
+* functions to come up with seed values which together should
+* be unique.
+*
+ NPROCS = IBTNPROCS()
+ SRC = MYROW * NPROCS + MYCOL
+ ISEED(1) = MOD( 1002 + TESTNUM*5 + SRC*3, 4096 )
+ ISEED(2) = MOD( 2027 + TESTNUM*7 + SRC, 4096 )
+ ISEED(3) = MOD( 1234 + TESTNUM + SRC*3, 4096 )
+ ISEED(4) = MOD( 4311 + TESTNUM*10 + SRC*2, 4096 )
+*
+ DO 10 J = 1, N
+ DO 10 I = 1, M
+ A(I, J) = ZBTRAN( ISEED )
+ 10 CONTINUE
+*
+ RETURN
+*
+* End of ZGENMAT.
+*
+ END
+*
+ DOUBLE COMPLEX FUNCTION ZBTRAN(ISEED)
+ INTEGER ISEED(*)
+*
+* .. External Functions ..
+ DOUBLE COMPLEX ZLARND
+ EXTERNAL ZLARND
+ ZBTRAN = ZLARND(2, ISEED)
+*
+ RETURN
+*
+* End of Zbtran
+*
+ END
+*
+ SUBROUTINE ZPADMAT( UPLO, DIAG, M, N, MEM, LDA, IPRE, IPOST,
+ $ CHECKVAL )
+*
+* -- BLACS tester (version 1.0) --
+* University of Tennessee
+* December 15, 1994
+*
+* .. Scalar Arguments ..
+ CHARACTER*1 UPLO, DIAG
+ INTEGER M, N, LDA, IPRE, IPOST
+ DOUBLE COMPLEX CHECKVAL
+* ..
+* .. Array Arguments ..
+ DOUBLE COMPLEX MEM( * )
+* ..
+*
+* Purpose
+* =======
+*
+* ZPADMAT: Pad Matrix.
+* This routines surrounds a matrix with a guardzone initialized to the
+* value CHECKVAL. There are three distinct guardzones:
+* - A contiguous zone of size IPRE immediately before the start
+* of the matrix.
+* - A contiguous zone of size IPOST immedately after the end of the
+* matrix.
+* - Interstitial zones within each column of the matrix, in the
+* elements A( M+1:LDA, J ).
+*
+* Arguments
+* =========
+* UPLO (input) CHARACTER*1
+* Is the matrix A 'U'pper or 'L'ower trapezoidal, or 'G'eneral
+* rectangular?
+*
+* DIAG (input) CHARACTER*1
+* For trapezoidal matrices, is the main diagonal included
+* ('N') or not ('U')?
+*
+* M (input) INTEGER
+* The number of rows of the matrix A. M >= 0.
+*
+* N (input) INTEGER
+* The number of columns of the matrix A. N >= 0.
+*
+* MEM (output) double complex array, dimension (IPRE+IPOST+LDA*N)
+* The address IPRE elements ahead of the matrix A you want to
+* pad, which is then of dimension (LDA,N).
+*
+* IPRE (input) INTEGER
+* The size of the guard zone ahead of the matrix A.
+*
+* IPOST (input) INTEGER
+* The size of the guard zone behind the matrix A.
+*
+* CHECKVAL (input) double complex
+* The value to insert into the guard zones.
+*
+* ====================================================================
+*
+* .. Local Scalars ..
+ INTEGER I, J, K
+* ..
+* .. Executable Statements ..
+*
+* Put check buffer in front of A
+*
+ IF( IPRE .GT. 0 ) THEN
+ DO 10 I = 1, IPRE
+ MEM( I ) = CHECKVAL
+ 10 CONTINUE
+ END IF
+*
+* Put check buffer in back of A
+*
+ IF( IPOST .GT. 0 ) THEN
+ J = IPRE + LDA*N + 1
+ DO 20 I = J, J+IPOST-1
+ MEM( I ) = CHECKVAL
+ 20 CONTINUE
+ END IF
+*
+* Put check buffer in all (LDA-M) gaps
+*
+ IF( LDA .GT. M ) THEN
+ K = IPRE + M + 1
+ DO 40 J = 1, N
+ DO 30 I = K, K+LDA-M-1
+ MEM( I ) = CHECKVAL
+ 30 CONTINUE
+ K = K + LDA
+ 40 CONTINUE
+ END IF
+*
+* If the matrix is upper or lower trapezoidal, calculate the
+* additional triangular area which needs to be padded, Each
+* element referred to is in the Ith row and the Jth column.
+*
+ IF( UPLO .EQ. 'U' ) THEN
+ IF( M .LE. N ) THEN
+ IF( DIAG .EQ. 'U' ) THEN
+ DO 41 I = 1, M
+ DO 42 J = 1, I
+ K = IPRE + I + (J-1)*LDA
+ MEM( K ) = CHECKVAL
+ 42 CONTINUE
+ 41 CONTINUE
+ ELSE
+ DO 43 I = 2, M
+ DO 44 J = 1, I-1
+ K = IPRE + I + (J-1)*LDA
+ MEM( K ) = CHECKVAL
+ 44 CONTINUE
+ 43 CONTINUE
+ END IF
+ ELSE
+ IF( DIAG .EQ. 'U' ) THEN
+ DO 45 I = M-N+1, M
+ DO 46 J = 1, I-(M-N)
+ K = IPRE + I + (J-1)*LDA
+ MEM( K ) = CHECKVAL
+ 46 CONTINUE
+ 45 CONTINUE
+ ELSE
+ DO 47 I = M-N+2, M
+ DO 48 J = 1, I-(M-N)-1
+ K = IPRE + I + (J-1)*LDA
+ MEM( K ) = CHECKVAL
+ 48 CONTINUE
+ 47 CONTINUE
+ END IF
+ END IF
+ ELSE IF( UPLO .EQ. 'L' ) THEN
+ IF( M .LE. N ) THEN
+ IF( DIAG .EQ. 'U' ) THEN
+ DO 49 I = 1, M
+ DO 50 J = N-M+I, N
+ K = IPRE + I + (J-1)*LDA
+ MEM( K ) = CHECKVAL
+ 50 CONTINUE
+ 49 CONTINUE
+ ELSE
+ DO 51 I = 1, M-1
+ DO 52 J = N-M+I+1, N
+ K = IPRE + I + (J-1)*LDA
+ MEM( K ) = CHECKVAL
+ 52 CONTINUE
+ 51 CONTINUE
+ END IF
+ ELSE
+ IF( UPLO .EQ. 'U' ) THEN
+ DO 53 I = 1, N
+ DO 54 J = I, N
+ K = IPRE + I + (J-1)*LDA
+ MEM( K ) = CHECKVAL
+ 54 CONTINUE
+ 53 CONTINUE
+ ELSE
+ DO 55 I = 1, N-1
+ DO 56 J = I+1, N
+ K = IPRE + I + (J-1)*LDA
+ MEM( K ) = CHECKVAL
+ 56 CONTINUE
+ 55 CONTINUE
+ END IF
+ END IF
+ END IF
+*
+* End of ZPADMAT.
+*
+ RETURN
+ END
+*
+ SUBROUTINE ZCHKPAD( UPLO, DIAG, M, N, MEM, LDA, RSRC, CSRC,
+ $ MYROW, MYCOL, IPRE, IPOST, CHECKVAL,
+ $ TESTNUM, MAXERR, NERR, ERRIBUF, ERRDBUF )
+*
+* -- BLACS tester (version 1.0) --
+* University of Tennessee
+* December 15, 1994
+*
+*
+* .. Scalar Arguments ..
+ CHARACTER*1 UPLO, DIAG
+ INTEGER M, N, LDA, RSRC, CSRC, MYROW, MYCOL, IPRE, IPOST
+ INTEGER TESTNUM, MAXERR, NERR
+ DOUBLE COMPLEX CHECKVAL
+* ..
+* .. Array Arguments ..
+ INTEGER ERRIBUF(6, MAXERR)
+ DOUBLE COMPLEX MEM(*), ERRDBUF(2, MAXERR)
+* ..
+*
+* Purpose
+* =======
+* ZCHKPAD: Check padding put in by PADMAT.
+* Checks that padding around target matrix has not been overwritten
+* by the previous point-to-point or broadcast send.
+*
+* Arguments
+* =========
+* UPLO (input) CHARACTER*1
+* Is the matrix A 'U'pper or 'L'ower trapezoidal, or 'G'eneral
+* rectangular?
+*
+* DIAG (input) CHARACTER*1
+* For trapezoidal matrices, is the main diagonal included
+* ('N') or not ('U')?
+*
+* M (input) INTEGER
+* The number of rows of the matrix A. M >= 0.
+*
+* N (input) INTEGER
+* The number of columns of the matrix A. N >= 0.
+*
+* MEM (input) double complex array, dimension(IPRE+IPOST+LDA*N).
+* Memory location IPRE elements in front of the matrix A.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1, M).
+*
+* RSRC (input) INTEGER
+* The process row of the source of the matrix.
+*
+* CSRC (input) INTEGER
+* The process column of the source of the matrix.
+*
+* MYROW (input) INTEGER
+* Row of this process in the process grid.
+*
+* MYCOL (input) INTEGER
+* Column of this process in the process grid.
+*
+* IPRE (input) INTEGER
+* The size of the guard zone before the start of A.
+*
+* IPOST (input) INTEGER
+* The size of guard zone after A.
+*
+* CHECKVAL (input) double complex
+* The value to pad matrix with.
+*
+* TESTNUM (input) INTEGER
+* The number of the test being checked.
+*
+* MAXERR (input) INTEGER
+* Max number of errors that can be stored in ERRIBUFF or
+* ERRZBUFF
+*
+* NERR (output) INTEGER
+* The number of errors that have been found.
+*
+* ERRIBUF (output) INTEGER array, dimension (6,MAXERRS)
+* Buffer in which to store integer error information. It will
+* be built up in the following format for the call to TSEND.
+* All integer information is recorded in the following 6-tuple
+* {TESTNUM, SRC, DEST, I, J, WHAT}. These values are figured:
+* SRC = RSRC * NPROCS + CSRC
+* DEST = RDEST * NPROCS + CDEST
+* WHAT
+* = 1 : Error in pre-padding
+* = 2 : Error in post-padding
+* = 3 : Error in LDA-M gap
+* = 4 : Error in complementory triangle
+* ELSE: Error in matrix
+* If there are more errors than can fit in the error buffer,
+* the error number will indicate the actual number of errors
+* found, but the buffer will be truncated to the maximum
+* number of errors which can fit.
+*
+* ERRDBUF (output) @(doctype) array, dimension (2, MAXERRS)
+* Buffer in which to store error data information.
+* {Incorrect, Predicted}
+*
+* ===================================================================
+*
+* .. Parameters ..
+ INTEGER ERR_PRE, ERR_POST, ERR_GAP, ERR_TRI, ERR_MAT
+ PARAMETER( ERR_PRE = 1, ERR_POST = 2, ERR_GAP = 3, ERR_TRI = 4 )
+ PARAMETER( ERR_MAT = 5 )
+* ..
+* .. External Functions ..
+ INTEGER IBTNPROCS
+ EXTERNAL IBTNPROCS
+* ..
+* .. Local Scalars ..
+ LOGICAL ISTRAP
+ INTEGER I, J, K, IRST, IRND, ICST, ICND, SRC, DEST
+ INTEGER NPROCS
+* ..
+* .. Executable Statements ..
+*
+ NPROCS = IBTNPROCS()
+ SRC = RSRC * NPROCS + CSRC
+ DEST = MYROW * NPROCS + MYCOL
+*
+* Check buffer in front of A
+*
+ IF( IPRE .GT. 0 ) THEN
+ DO 10 I = 1, IPRE
+ IF( MEM(I) .NE. CHECKVAL ) THEN
+ NERR = NERR + 1
+ IF( NERR .LE. MAXERR ) THEN
+ ERRIBUF(1, NERR) = TESTNUM
+ ERRIBUF(2, NERR) = SRC
+ ERRIBUF(3, NERR) = DEST
+ ERRIBUF(4, NERR) = I
+ ERRIBUF(5, NERR) = IPRE - I + 1
+ ERRIBUF(6, NERR) = ERR_PRE
+ ERRDBUF(1, NERR) = MEM(I)
+ ERRDBUF(2, NERR) = CHECKVAL
+ END IF
+ END IF
+ 10 CONTINUE
+ END IF
+*
+* Check buffer behind A
+*
+ IF( IPOST .GT. 0 ) THEN
+ J = IPRE + LDA*N + 1
+ DO 20 I = J, J+IPOST-1
+ IF( MEM(I) .NE. CHECKVAL ) THEN
+ NERR = NERR + 1
+ IF( NERR .LE. MAXERR ) THEN
+ ERRIBUF(1, NERR) = TESTNUM
+ ERRIBUF(2, NERR) = SRC
+ ERRIBUF(3, NERR) = DEST
+ ERRIBUF(4, NERR) = I - J + 1
+ ERRIBUF(5, NERR) = J
+ ERRIBUF(6, NERR) = ERR_POST
+ ERRDBUF(1, NERR) = MEM(I)
+ ERRDBUF(2, NERR) = CHECKVAL
+ END IF
+ END IF
+ 20 CONTINUE
+ END IF
+*
+* Check all (LDA-M) gaps
+*
+ IF( LDA .GT. M ) THEN
+ DO 40 J = 1, N
+ DO 30 I = M+1, LDA
+ K = IPRE + (J-1)*LDA + I
+ IF( MEM(K) .NE. CHECKVAL) THEN
+ NERR = NERR + 1
+ IF( NERR .LE. MAXERR ) THEN
+ ERRIBUF(1, NERR) = TESTNUM
+ ERRIBUF(2, NERR) = SRC
+ ERRIBUF(3, NERR) = DEST
+ ERRIBUF(4, NERR) = I
+ ERRIBUF(5, NERR) = J
+ ERRIBUF(6, NERR) = ERR_GAP
+ ERRDBUF(1, NERR) = MEM(K)
+ ERRDBUF(2, NERR) = CHECKVAL
+ END IF
+ END IF
+ 30 CONTINUE
+ 40 CONTINUE
+ END IF
+*
+* Determine limits of trapezoidal matrix
+*
+ ISTRAP = .FALSE.
+ IF( UPLO .EQ. 'U' ) THEN
+ ISTRAP = .TRUE.
+ IF( M .LE. N ) THEN
+ IRST = 2
+ IRND = M
+ ICST = 1
+ ICND = M - 1
+ ELSEIF( M .GT. N ) THEN
+ IRST = ( M-N ) + 2
+ IRND = M
+ ICST = 1
+ ICND = N - 1
+ ENDIF
+ IF( DIAG .EQ. 'U' ) THEN
+ IRST = IRST - 1
+ ICND = ICND + 1
+ ENDIF
+ ELSE IF( UPLO .EQ. 'L' ) THEN
+ ISTRAP = .TRUE.
+ IF( M .LE. N ) THEN
+ IRST = 1
+ IRND = 1
+ ICST = ( N-M ) + 2
+ ICND = N
+ ELSEIF( M .GT. N ) THEN
+ IRST = 1
+ IRND = 1
+ ICST = 2
+ ICND = N
+ ENDIF
+ IF( DIAG .EQ. 'U' ) THEN
+ ICST = ICST - 1
+ ENDIF
+ ENDIF
+*
+* Check elements and report any errors
+*
+ IF( ISTRAP ) THEN
+ DO 100 J = ICST, ICND
+ DO 105 I = IRST, IRND
+ IF( MEM( IPRE + (J-1)*LDA + I ) .NE. CHECKVAL ) THEN
+ NERR = NERR + 1
+ IF( NERR .LE. MAXERR ) THEN
+ ERRIBUF(1, NERR) = TESTNUM
+ ERRIBUF(2, NERR) = SRC
+ ERRIBUF(3, NERR) = DEST
+ ERRIBUF(4, NERR) = I
+ ERRIBUF(5, NERR) = J
+ ERRIBUF(6, NERR) = ERR_TRI
+ ERRDBUF(1, NERR) = MEM( IPRE + (J-1)*LDA + I )
+ ERRDBUF(2, NERR) = CHECKVAL
+ END IF
+ END IF
+ 105 CONTINUE
+*
+* Update the limits to allow filling in padding
+*
+ IF( UPLO .EQ. 'U' ) THEN
+ IRST = IRST + 1
+ ELSE
+ IRND = IRND + 1
+ ENDIF
+ 100 CONTINUE
+ END IF
+*
+ RETURN
+*
+* End of ZCHKPAD.
+*
+ END
+*
+ SUBROUTINE ZCHKMAT( UPLO, DIAG, M, N, A, LDA, RSRC, CSRC,
+ $ MYROW, MYCOL, TESTNUM, MAXERR, NERR,
+ $ ERRIBUF, ERRDBUF )
+*
+* -- BLACS tester (version 1.0) --
+* University of Tennessee
+* December 15, 1994
+*
+*
+* .. Scalar Arguments ..
+ CHARACTER*1 UPLO, DIAG
+ INTEGER M, N, LDA, RSRC, CSRC, MYROW, MYCOL, TESTNUM
+ INTEGER MAXERR, NERR
+* ..
+* .. Array Arguments ..
+ INTEGER ERRIBUF(6, MAXERR)
+ DOUBLE COMPLEX A(LDA,N), ERRDBUF(2, MAXERR)
+* ..
+*
+* Purpose
+* =======
+* zCHKMAT: Check matrix to see whether there were any transmission
+* errors.
+*
+* Arguments
+* =========
+* UPLO (input) CHARACTER*1
+* Is the matrix A 'U'pper or 'L'ower trapezoidal, or 'G'eneral
+* rectangular?
+*
+* DIAG (input) CHARACTER*1
+* For trapezoidal matrices, is the main diagonal included
+* ('N') or not ('U')?
+*
+* M (input) INTEGER
+* The number of rows of the matrix A. M >= 0.
+*
+* N (input) INTEGER
+* The number of columns of the matrix A. N >= 0.
+*
+* A (input) @up@(doctype) array, dimension (LDA,N)
+* The m by n matrix A. Fortran77 (column-major) storage
+* assumed.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1, M).
+*
+* RSRC (input) INTEGER
+* The process row of the source of the matrix.
+*
+* CSRC (input) INTEGER
+* The process column of the source of the matrix.
+*
+* MYROW (input) INTEGER
+* Row of this process in the process grid.
+*
+* MYCOL (input) INTEGER
+* Column of this process in the process grid.
+*
+*
+* TESTNUM (input) INTEGER
+* The number of the test being checked.
+*
+* MAXERR (input) INTEGER
+* Max number of errors that can be stored in ERRIBUFF or
+* ERRZBUFF
+*
+* NERR (output) INTEGER
+* The number of errors that have been found.
+*
+* ERRIBUF (output) INTEGER array, dimension (6,MAXERRS)
+* Buffer in which to store integer error information. It will
+* be built up in the following format for the call to TSEND.
+* All integer information is recorded in the following 6-tuple
+* {TESTNUM, SRC, DEST, I, J, WHAT}. These values are figured:
+* SRC = RSRC * NPROCS + CSRC
+* DEST = RDEST * NPROCS + CDEST
+* WHAT
+* = 1 : Error in pre-padding
+* = 2 : Error in post-padding
+* = 3 : Error in LDA-M gap
+* = 4 : Error in complementory triangle
+* ELSE: Error in matrix
+* If there are more errors than can fit in the error buffer,
+* the error number will indicate the actual number of errors
+* found, but the buffer will be truncated to the maximum
+* number of errors which can fit.
+*
+* ERRDBUF (output) @(doctype) array, dimension (2, MAXERRS)
+* Buffer in which to store error data information.
+* {Incorrect, Predicted}
+*
+* ===================================================================
+*
+* .. Local Scalars ..
+ INTEGER I, J, NPROCS, SRC, DEST
+ LOGICAL USEIT
+ DOUBLE COMPLEX COMPVAL
+* ..
+* .. Local Arrays ..
+ INTEGER ISEED(4)
+* ..
+* .. External Functions ..
+ INTEGER IBTNPROCS
+ DOUBLE COMPLEX ZBTRAN
+ EXTERNAL ZBTRAN, IBTNPROCS
+* ..
+* .. Executable Statements ..
+*
+ NPROCS = IBTNPROCS()
+ SRC = RSRC * NPROCS + CSRC
+ DEST = MYROW * NPROCS + MYCOL
+*
+* Initialize ISEED with the same values as used in ZGENMAT.
+*
+ ISEED(1) = MOD( 1002 + TESTNUM*5 + SRC*3, 4096 )
+ ISEED(2) = MOD( 2027 + TESTNUM*7 + SRC, 4096 )
+ ISEED(3) = MOD( 1234 + TESTNUM + SRC*3, 4096 )
+ ISEED(4) = MOD( 4311 + TESTNUM*10 + SRC*2, 4096 )
+*
+* Generate the elements randomly with the same method used in GENMAT.
+* Note that for trapezoidal matrices, we generate all elements in the
+* enclosing rectangle and then ignore the complementary triangle.
+*
+ DO 100 J = 1, N
+ DO 105 I = 1, M
+ COMPVAL = ZBTRAN( ISEED )
+*
+* Now determine whether we actually need this value. The
+* strategy is to chop out the proper triangle based on what
+* particular kind of trapezoidal matrix we're dealing with.
+*
+ USEIT = .TRUE.
+ IF( UPLO .EQ. 'U' ) THEN
+ IF( M .LE. N ) THEN
+ IF( DIAG .EQ. 'U' ) THEN
+ IF( I .GE. J ) THEN
+ USEIT = .FALSE.
+ END IF
+ ELSE
+ IF( I .GT. J ) THEN
+ USEIT = .FALSE.
+ END IF
+ END IF
+ ELSE
+ IF( DIAG .EQ. 'U' ) THEN
+ IF( I .GE. M-N+J ) THEN
+ USEIT = .FALSE.
+ END IF
+ ELSE
+ IF( I .GT. M-N+J ) THEN
+ USEIT = .FALSE.
+ END IF
+ END IF
+ END IF
+ ELSE IF( UPLO .EQ. 'L' ) THEN
+ IF( M .LE. N ) THEN
+ IF( DIAG .EQ. 'U' ) THEN
+ IF( J. GE. I+(N-M) ) THEN
+ USEIT = .FALSE.
+ END IF
+ ELSE
+ IF( J .GT. I+(N-M) ) THEN
+ USEIT = .FALSE.
+ END IF
+ END IF
+ ELSE
+ IF( DIAG .EQ. 'U' ) THEN
+ IF( J .GE. I ) THEN
+ USEIT = .FALSE.
+ END IF
+ ELSE
+ IF( J .GT. I ) THEN
+ USEIT = .FALSE.
+ END IF
+ END IF
+ END IF
+ END IF
+*
+* Compare the generated value to the one that's in the
+* received matrix. If they don't match, tack another
+* error record onto what's already there.
+*
+ IF( USEIT ) THEN
+ IF( A(I,J) .NE. COMPVAL ) THEN
+ NERR = NERR + 1
+ IF( NERR .LE. MAXERR ) THEN
+ ERRIBUF(1, NERR) = TESTNUM
+ ERRIBUF(2, NERR) = SRC
+ ERRIBUF(3, NERR) = DEST
+ ERRIBUF(4, NERR) = I
+ ERRIBUF(5, NERR) = J
+ ERRIBUF(6, NERR) = 5
+ ERRDBUF(1, NERR) = A(I, J)
+ ERRDBUF(2, NERR) = COMPVAL
+ END IF
+ END IF
+ END IF
+ 105 CONTINUE
+ 100 CONTINUE
+ RETURN
+*
+* End of ZCHKMAT.
+*
+ END
+*
+ SUBROUTINE ZPRINTERRS( OUTNUM, MAXERR, NERR,
+ $ ERRIBUF, ERRDBUF, COUNTING, TFAILED )
+*
+* -- BLACS tester (version 1.0) --
+* University of Tennessee
+* December 15, 1994
+*
+*
+* .. Scalar Arguments ..
+ LOGICAL COUNTING
+ INTEGER OUTNUM, MAXERR, NERR
+* ..
+* .. Array Arguments ..
+ INTEGER ERRIBUF(6, MAXERR), TFAILED(*)
+ DOUBLE COMPLEX ERRDBUF(2, MAXERR)
+* ..
+*
+* Purpose
+* =======
+* ZPRINTERRS: Print errors that have been recorded
+*
+* Arguments
+* =========
+* OUTNUM (input) INTEGER
+* Device number for output.
+*
+* MAXERR (input) INTEGER
+* Max number of errors that can be stored in ERRIBUFF or
+* ERRZBUFF
+*
+* NERR (output) INTEGER
+* The number of errors that have been found.
+*
+* ERRIBUF (output) INTEGER array, dimension (6,MAXERRS)
+* Buffer in which to store integer error information. It will
+* be built up in the following format for the call to TSEND.
+* All integer information is recorded in the following 6-tuple
+* {TESTNUM, SRC, DEST, I, J, WHAT}. These values are figured:
+* SRC = RSRC * NPROCS + CSRC
+* DEST = RDEST * NPROCS + CDEST
+* WHAT
+* = 1 : Error in pre-padding
+* = 2 : Error in post-padding
+* = 3 : Error in LDA-M gap
+* = 4 : Error in complementory triangle
+* ELSE: Error in matrix
+* If there are more errors than can fit in the error buffer,
+* the error number will indicate the actual number of errors
+* found, but the buffer will be truncated to the maximum
+* number of errors which can fit.
+*
+* ERRDBUF (output) @(doctype) array, dimension (2, MAXERRS)
+* Buffer in which to store error data information.
+* {Incorrect, Predicted}
+*
+* TFAILED (input/ourput) INTEGER array, dimension NTESTS
+* Workspace used to keep track of which tests failed.
+* This array not accessed unless COUNTING is true.
+*
+* ===================================================================
+*
+* .. Parameters ..
+ INTEGER ERR_PRE, ERR_POST, ERR_GAP, ERR_TRI, ERR_MAT
+ PARAMETER( ERR_PRE = 1, ERR_POST = 2, ERR_GAP = 3, ERR_TRI = 4 )
+ PARAMETER( ERR_MAT = 5 )
+* ..
+* .. External Functions ..
+ INTEGER IBTMYPROC, IBTNPROCS
+ EXTERNAL IBTMYPROC, IBTNPROCS
+* ..
+* .. Local Scalars ..
+ CHARACTER*1 MAT
+ LOGICAL MATISINT
+ INTEGER OLDTEST, NPROCS, PROW, PCOL, I, ERRTYPE
+* ..
+* .. Executable Statements ..
+*
+ IF( (IBTMYPROC().NE.0) .OR. (NERR.LE.0) ) RETURN
+ OLDTEST = -1
+ NPROCS = IBTNPROCS()
+ PROW = ERRIBUF(3,1) / NPROCS
+ PCOL = MOD( ERRIBUF(3,1), NPROCS )
+ IF( NERR .GT. MAXERR ) WRITE(OUTNUM,13000)
+*
+ DO 20 I = 1, MIN( NERR, MAXERR )
+ IF( ERRIBUF(1,I) .NE. OLDTEST ) THEN
+ IF( OLDTEST .NE. -1 )
+ $ WRITE(OUTNUM,12000) PROW, PCOL, OLDTEST
+ WRITE(OUTNUM,*) ' '
+ WRITE(OUTNUM,1000) PROW, PCOL, ERRIBUF(1,I)
+ IF( COUNTING ) TFAILED( ERRIBUF(1,I) ) = 1
+ OLDTEST = ERRIBUF(1, I)
+ END IF
+*
+* Print out error message depending on type of error
+*
+ ERRTYPE = ERRIBUF(6, I)
+ IF( ERRTYPE .LT. -10 ) THEN
+ ERRTYPE = -ERRTYPE - 10
+ MAT = 'C'
+ MATISINT = .TRUE.
+ ELSE IF( ERRTYPE .LT. 0 ) THEN
+ ERRTYPE = -ERRTYPE
+ MAT = 'R'
+ MATISINT = .TRUE.
+ ELSE
+ MATISINT = .FALSE.
+ END IF
+*
+* RA/CA arrays from MAX/MIN have different printing protocol
+*
+ IF( MATISINT ) THEN
+ IF( ERRIBUF(2, I) .EQ. -1 ) THEN
+ WRITE(OUTNUM,11000) ERRIBUF(4,I), ERRIBUF(5,I), MAT,
+ $ INT( ERRDBUF(2,I) ), INT( ERRDBUF(1,I) )
+ ELSE IF( ERRTYPE .EQ. ERR_PRE ) THEN
+ WRITE(OUTNUM,7000) ERRIBUF(5,I), MAT,
+ $ INT( ERRDBUF(2,I) ), INT( ERRDBUF(1,I) )
+ ELSE IF( ERRTYPE .EQ. ERR_POST ) THEN
+ WRITE(OUTNUM,8000) ERRIBUF(4,I), MAT,
+ $ INT( ERRDBUF(2,I) ), INT( ERRDBUF(1,I) )
+ ELSE IF( ERRTYPE .EQ. ERR_GAP ) THEN
+ WRITE(OUTNUM,9000) MAT, ERRIBUF(4,I), ERRIBUF(5,I),
+ $ INT( ERRDBUF(2,I) ), INT( ERRDBUF(1,I) )
+ ELSE
+ WRITE(OUTNUM,10000) MAT, ERRIBUF(4,I), ERRIBUF(5,I),
+ $ INT( ERRDBUF(2,I) ),
+ $ INT( ERRDBUF(1,I) )
+ END IF
+*
+* Have memory overwrites in matrix A
+*
+ ELSE
+ IF( ERRTYPE .EQ. ERR_PRE ) THEN
+ WRITE(OUTNUM,2000) ERRIBUF(5,I),
+ $ REAL( ERRDBUF(2,I) ), DIMAG( ERRDBUF(2,I) ),
+ $ REAL( ERRDBUF(1,I) ), DIMAG( ERRDBUF(1,I) )
+ ELSE IF( ERRTYPE .EQ. ERR_POST ) THEN
+ WRITE(OUTNUM,3000) ERRIBUF(4,I),
+ $ REAL( ERRDBUF(2,I) ), DIMAG( ERRDBUF(2,I) ),
+ $ REAL( ERRDBUF(1,I) ), DIMAG( ERRDBUF(1,I) )
+ ELSE IF( ERRTYPE .EQ. ERR_GAP ) THEN
+ WRITE(OUTNUM,4000)
+ $ ERRIBUF(4,I), ERRIBUF(5,I),
+ $ REAL( ERRDBUF(2,I) ), DIMAG( ERRDBUF(2,I) ),
+ $ REAL( ERRDBUF(1,I) ), DIMAG( ERRDBUF(1,I) )
+ ELSE IF( ERRTYPE .EQ. ERR_TRI ) THEN
+ WRITE(OUTNUM,5000) ERRIBUF(4,I), ERRIBUF(5,I),
+ $ REAL( ERRDBUF(2,I) ), DIMAG( ERRDBUF(2,I) ),
+ $ REAL( ERRDBUF(1,I) ), DIMAG( ERRDBUF(1,I) )
+ ELSE
+ WRITE(OUTNUM,6000) ERRIBUF(4,I), ERRIBUF(5,I),
+ $ REAL( ERRDBUF(2,I) ), DIMAG( ERRDBUF(2,I) ),
+ $ REAL( ERRDBUF(1,I) ), DIMAG( ERRDBUF(1,I) )
+ END IF
+ END IF
+ 20 CONTINUE
+ WRITE(OUTNUM,12000) PROW, PCOL, OLDTEST
+*
+ 1000 FORMAT('PROCESS {',I4,',',I4,'} REPORTS ERRORS IN TEST#',I6,':')
+ 2000 FORMAT(' Buffer overwrite ',I4,
+ $ ' elements before the start of A:',/,
+ $ ' Expected=','[',G22.15,',',G22.15,']',
+ $ '; Received=','[',G22.15,',',G22.15,']')
+ 3000 FORMAT(' Buffer overwrite ',I4,' elements after the end of A:',
+ $ /,' Expected=','[',G22.15,',',G22.15,']',
+ $ '; Received=','[',G22.15,',',G22.15,']')
+ 4000 FORMAT(' LDA-M gap overwrite at postion (',I4,',',I4,'):',/,
+ $ ' Expected=','[',G22.15,',',G22.15,']',
+ $ '; Received=','[',G22.15,',',G22.15,']')
+ 5000 FORMAT(' Complementory triangle overwrite at A(',I4,',',I4,
+ $ '):',/,' Expected=','[',G22.15,',',G22.15,']',
+ $ '; Received=','[',G22.15,',',G22.15,']')
+ 6000 FORMAT(' Invalid element at A(',I4,',',I4,'):',/,
+ $ ' Expected=','[',G22.15,',',G22.15,']',
+ $ '; Received=','[',G22.15,',',G22.15,']')
+ 7000 FORMAT(' Buffer overwrite ',I4,' elements before the start of ',
+ $ A1,'A:',/,' Expected=',I12,'; Received=',I12)
+ 8000 FORMAT(' Buffer overwrite ',I4,' elements after the end of ',
+ $ A1,'A:',/,' Expected=',I12,'; Received=',I12)
+*
+ 9000 FORMAT(' LD',A1,'A-M gap overwrite at postion (',I4,',',I4,'):'
+ $ ,/,' Expected=',I12,'; Received=',I12)
+*
+10000 FORMAT(' Invalid element at ',A1,'A(',I4,',',I4,'):',/,
+ $ ' Expected=',I12,'; Received=',I12)
+11000 FORMAT(' Overwrite at position (',I4,',',I4,') of non-existent '
+ $ ,A1,'A array.',/,' Expected=',I12,'; Received=',I12)
+12000 FORMAT('PROCESS {',I4,',',I4,'} DONE ERROR REPORT FOR TEST#',
+ $ I6,'.')
+13000 FORMAT('WARNING: There were more errors than could be recorded.',
+ $ /,'Increase MEMELTS to get complete listing.')
+ RETURN
+*
+* End ZPRINTERRS
+*
+ END
+*
+*
+ SUBROUTINE ISUMTEST( OUTNUM, VERB, TOPSREPEAT, TOPSCOHRNT, NSCOPE,
+ $ SCOPE0, NTOP, TOP0, NMAT, M0, N0, LDAS0,
+ $ LDAD0, NDEST, RDEST0, CDEST0, NGRID,
+ $ CONTEXT0, P0, Q0, ISEED, MEM, MEMLEN )
+*
+* -- BLACS tester (version 1.0) --
+* University of Tennessee
+* December 15, 1994
+*
+*
+* .. Scalar Arguments ..
+ INTEGER MEMLEN, NDEST, NGRID, NMAT, NSCOPE, NTOP, OUTNUM,
+ $ TOPSCOHRNT, TOPSREPEAT, VERB
+* ..
+* .. Array Arguments ..
+ CHARACTER*1 SCOPE0(NSCOPE), TOP0(NTOP)
+ INTEGER M0(NMAT), N0(NMAT), LDAS0(NMAT), LDAD0(NMAT)
+ INTEGER RDEST0(NDEST), CDEST0(NDEST), CONTEXT0(NGRID)
+ INTEGER P0(NGRID), Q0(NGRID), ISEED(*)
+ INTEGER MEM(MEMLEN)
+* ..
+*
+* Purpose
+* =======
+* ITESTSUM: Test integer SUM COMBINE
+*
+* Arguments
+* =========
+* OUTNUM (input) INTEGER
+* The device number to write output to.
+*
+* VERB (input) INTEGER
+* The level of verbosity (how much printing to do).
+*
+* NSCOPE (input) INTEGER
+* The number of scopes to be tested.
+*
+* SCOPE0 (input) CHARACTER*1 array of dimension (NSCOPE)
+* Values of the scopes to be tested.
+*
+* NTOP (input) INTEGER
+* The number of topologies to be tested.
+*
+* TOP0 (input) CHARACTER*1 array of dimension (NTOP)
+* Values of the topologies to be tested.
+*
+* NMAT (input) INTEGER
+* The number of matrices to be tested.
+*
+* M0 (input) INTEGER array of dimension (NMAT)
+* Values of M to be tested.
+*
+* M0 (input) INTEGER array of dimension (NMAT)
+* Values of M to be tested.
+*
+* N0 (input) INTEGER array of dimension (NMAT)
+* Values of N to be tested.
+*
+* LDAS0 (input) INTEGER array of dimension (NMAT)
+* Values of LDAS (leading dimension of A on source process)
+* to be tested.
+*
+* LDAD0 (input) INTEGER array of dimension (NMAT)
+* Values of LDAD (leading dimension of A on destination
+* process) to be tested.
+* NDEST (input) INTEGER
+* The number of destinations to be tested.
+*
+* RDEST0 (input) INTEGER array of dimension (NNDEST)
+* Values of RDEST (row coordinate of destination) to be
+* tested.
+*
+* CDEST0 (input) INTEGER array of dimension (NNDEST)
+* Values of CDEST (column coordinate of destination) to be
+* tested.
+*
+* NGRID (input) INTEGER
+* The number of process grids to be tested.
+*
+* CONTEXT0 (input) INTEGER array of dimension (NGRID)
+* The BLACS context handles corresponding to the grids.
+*
+* P0 (input) INTEGER array of dimension (NGRID)
+* Values of P (number of process rows, NPROW).
+*
+* Q0 (input) INTEGER array of dimension (NGRID)
+* Values of Q (number of process columns, NPCOL).
+*
+* ISEED (workspace) INTEGER array of dimension ( MAX(NPROCS, NTESTS) )
+* Workspace used to hold each process's random number SEED.
+* This requires NPROCS (number of processor) elements.
+* If VERB < 2, this workspace also serves to indicate which
+* tests fail. This requires workspace of NTESTS
+* (number of tests performed).
+*
+* MEM (workspace) INTEGER array of dimension (MEMLEN)
+* Used for all other workspaces, including the matrix A,
+* and its pre and post padding.
+*
+* MEMLEN (input) INTEGER
+* The length, in elements, of MEM.
+*
+* =====================================================================
+*
+* .. External Functions ..
+ LOGICAL ALLPASS, LSAME
+ INTEGER IBTMYPROC, IBTNPROCS, IBTSIZEOF
+ EXTERNAL ALLPASS, LSAME, IBTMYPROC, IBTNPROCS, IBTSIZEOF
+* ..
+* .. External Subroutines ..
+ EXTERNAL BLACS_GRIDINFO, IGSUM2D
+ EXTERNAL IINITMAT, ICHKPAD, IBTCHECKIN
+* ..
+* .. Local Scalars ..
+ CHARACTER*1 SCOPE, TOP
+ LOGICAL INGRID, TESTOK, ALLRCV
+ INTEGER APTR, CDEST, CDEST2, CONTEXT, ERRDPTR, ERRIPTR, I, IAM,
+ $ IDE, IGR, IMA, IPAD, IPOST, IPRE, ISC, ISIZE, ISTART,
+ $ ISTOP, ITC, ITC1, ITC2, ITO, ITR, ITR1, ITR2, J, K, LDA,
+ $ LDADST, LDASRC, M, MAXERR, MYCOL, MYROW, N, NERR, NFAIL,
+ $ NPCOL, NPROW, NSKIP, PREAPTR, RDEST, RDEST2, SETWHAT,
+ $ TESTNUM
+ INTEGER CHECKVAL
+* ..
+* .. Executable Statements ..
+*
+* Choose padding value, and make it unique
+*
+ CHECKVAL = -911
+ IAM = IBTMYPROC()
+ CHECKVAL = IAM * CHECKVAL
+ ISIZE = IBTSIZEOF('I')
+*
+* Verify file parameters
+*
+ IF( IAM .EQ. 0 ) THEN
+ WRITE(OUTNUM, *) ' '
+ WRITE(OUTNUM, *) ' '
+ WRITE(OUTNUM, 1000 )
+ IF( VERB .GT. 0 ) THEN
+ WRITE(OUTNUM,*) ' '
+ WRITE(OUTNUM, 2000) 'NSCOPE:', NSCOPE
+ WRITE(OUTNUM, 3000) ' SCOPE:', ( SCOPE0(I), I = 1, NSCOPE )
+ WRITE(OUTNUM, 2000) 'TReps :', TOPSREPEAT
+ WRITE(OUTNUM, 2000) 'TCohr :', TOPSCOHRNT
+ WRITE(OUTNUM, 2000) 'NTOP :', NTOP
+ WRITE(OUTNUM, 3000) ' TOP :', ( TOP0(I), I = 1, NTOP )
+ WRITE(OUTNUM, 2000) 'NMAT :', NMAT
+ WRITE(OUTNUM, 2000) ' M :', ( M0(I), I = 1, NMAT )
+ WRITE(OUTNUM, 2000) ' N :', ( N0(I), I = 1, NMAT )
+ WRITE(OUTNUM, 2000) ' LDAS :', ( LDAS0(I), I = 1, NMAT )
+ WRITE(OUTNUM, 2000) ' LDAD :', ( LDAD0(I), I = 1, NMAT )
+ WRITE(OUTNUM, 2000) 'NDEST :', NDEST
+ WRITE(OUTNUM, 2000) ' RDEST:',( RDEST0(I), I = 1, NDEST )
+ WRITE(OUTNUM, 2000) ' CDEST:',( CDEST0(I), I = 1, NDEST )
+ WRITE(OUTNUM, 2000) 'NGRIDS:', NGRID
+ WRITE(OUTNUM, 2000) ' P :', ( P0(I), I = 1, NGRID )
+ WRITE(OUTNUM, 2000) ' Q :', ( Q0(I), I = 1, NGRID )
+ WRITE(OUTNUM, 2000) 'VERB :', VERB
+ WRITE(OUTNUM,*) ' '
+ END IF
+ IF( VERB .GT. 1 ) THEN
+ WRITE(OUTNUM,4000)
+ WRITE(OUTNUM,5000)
+ END IF
+ END IF
+ IF (TOPSREPEAT.EQ.0) THEN
+ ITR1 = 0
+ ITR2 = 0
+ ELSE IF (TOPSREPEAT.EQ.1) THEN
+ ITR1 = 1
+ ITR2 = 1
+ ELSE
+ ITR1 = 0
+ ITR2 = 1
+ END IF
+*
+* Find biggest matrix, so we know where to stick error info
+*
+ I = 0
+ DO 10 IMA = 1, NMAT
+ IPAD = 4 * M0(IMA)
+ K = N0(IMA) * MAX0( LDAS0(IMA), LDAD0(IMA) ) + IPAD
+ IF( K .GT. I ) I = K
+ 10 CONTINUE
+ MAXERR = ( ISIZE * (MEMLEN-I) ) / ( ISIZE*2 + ISIZE*6 )
+ IF( MAXERR .LT. 1 ) THEN
+ WRITE(OUTNUM,*) 'ERROR: Not enough memory to run SUM tests.'
+ CALL BLACS_ABORT(-1, 1)
+ END IF
+ ERRDPTR = I + 1
+ ERRIPTR = ERRDPTR + MAXERR
+ NERR = 0
+ TESTNUM = 0
+ NFAIL = 0
+ NSKIP = 0
+*
+* Loop over grids of matrix
+*
+ DO 90 IGR = 1, NGRID
+*
+* allocate process grid for the next batch of tests
+*
+ CONTEXT = CONTEXT0(IGR)
+ CALL BLACS_GRIDINFO( CONTEXT, NPROW, NPCOL, MYROW, MYCOL )
+ INGRID = ( (MYROW.LT.NPROW) .AND. (MYCOL.LT.NPCOL) )
+*
+ DO 80 ISC = 1, NSCOPE
+ SCOPE = SCOPE0(ISC)
+ DO 70 ITO = 1, NTOP
+ TOP = TOP0(ITO)
+*
+* If testing multiring ('M') or general tree ('T'), need to
+* loop over calls to BLACS_SET to do full test
+*
+ IF( LSAME(TOP, 'M') ) THEN
+ SETWHAT = 13
+ IF( SCOPE .EQ. 'R' ) THEN
+ ISTART = -(NPCOL - 1)
+ ISTOP = -ISTART
+ ELSE IF (SCOPE .EQ. 'C') THEN
+ ISTART = -(NPROW - 1)
+ ISTOP = -ISTART
+ ELSE
+ ISTART = -(NPROW*NPCOL - 1)
+ ISTOP = -ISTART
+ ENDIF
+ ELSE IF( LSAME(TOP, 'T') ) THEN
+ SETWHAT = 14
+ ISTART = 1
+ IF( SCOPE .EQ. 'R' ) THEN
+ ISTOP = NPCOL - 1
+ ELSE IF (SCOPE .EQ. 'C') THEN
+ ISTOP = NPROW - 1
+ ELSE
+ ISTOP = NPROW*NPCOL - 1
+ ENDIF
+ ELSE
+ SETWHAT = 0
+ ISTART = 1
+ ISTOP = 1
+ ENDIF
+ DO 60 IMA = 1, NMAT
+ M = M0(IMA)
+ N = N0(IMA)
+ LDASRC = LDAS0(IMA)
+ LDADST = LDAD0(IMA)
+ IPRE = 2 * M
+ IPOST = IPRE
+ PREAPTR = 1
+ APTR = PREAPTR + IPRE
+*
+ DO 50 IDE = 1, NDEST
+ TESTNUM = TESTNUM + 1
+ RDEST2 = RDEST0(IDE)
+ CDEST2 = CDEST0(IDE)
+*
+* If everyone gets the answer, create some bogus rdest/cdest
+* so IF's are easier
+*
+ ALLRCV = ( (RDEST2.EQ.-1) .OR. (CDEST2.EQ.-1) )
+ IF( ALLRCV ) THEN
+ RDEST = NPROW - 1
+ CDEST = NPCOL - 1
+ IF (TOPSCOHRNT.EQ.0) THEN
+ ITR1 = 0
+ ITR2 = 0
+ ELSE IF (TOPSCOHRNT.EQ.1) THEN
+ ITR1 = 1
+ ITR2 = 1
+ ELSE
+ ITR1 = 0
+ ITR2 = 1
+ END IF
+ ELSE
+ RDEST = RDEST2
+ CDEST = CDEST2
+ ITC1 = 0
+ ITC2 = 0
+ END IF
+ IF( RDEST.GE.P0(IGR) .OR. CDEST.GE.Q0(IGR) ) THEN
+ NSKIP = NSKIP + 1
+ GOTO 50
+ END IF
+*
+ IF( MYROW.EQ.RDEST .AND. MYCOL.EQ.CDEST ) THEN
+ LDA = LDADST
+ ELSE
+ LDA = LDASRC
+ END IF
+ IF( VERB .GT. 1 ) THEN
+ IF( IAM .EQ. 0 ) THEN
+ WRITE(OUTNUM, 6000)
+ $ TESTNUM, 'RUNNING', SCOPE, TOP, M, N,
+ $ LDASRC, LDADST, RDEST2, CDEST2,
+ $ NPROW, NPCOL
+ END IF
+ END IF
+*
+* If I am in scope
+*
+ TESTOK = .TRUE.
+ IF( INGRID ) THEN
+ IF( (MYROW.EQ.RDEST .AND. SCOPE.EQ.'R') .OR.
+ $ (MYCOL.EQ.CDEST .AND. SCOPE.EQ.'C') .OR.
+ $ (SCOPE .EQ. 'A') ) THEN
+*
+ K = NERR
+ DO 40 ITR = ITR1, ITR2
+ CALL BLACS_SET(CONTEXT, 15, ITR)
+ DO 35 ITC = ITC1, ITC2
+ CALL BLACS_SET(CONTEXT, 16, ITC)
+ DO 30 J = ISTART, ISTOP
+ IF( J.EQ.0) GOTO 30
+ IF( SETWHAT.NE.0 )
+ $ CALL BLACS_SET(CONTEXT, SETWHAT, J)
+*
+*
+* generate and pad matrix A
+*
+ CALL IINITMAT('G','-', M, N, MEM(PREAPTR),
+ $ LDA, IPRE, IPOST,
+ $ CHECKVAL, TESTNUM,
+ $ MYROW, MYCOL )
+*
+ CALL IGSUM2D(CONTEXT, SCOPE, TOP, M, N,
+ $ MEM(APTR), LDA, RDEST2,
+ $ CDEST2)
+*
+* If I've got the answer, check for errors in
+* matrix or padding
+*
+ IF( (MYROW.EQ.RDEST .AND. MYCOL.EQ.CDEST)
+ $ .OR. ALLRCV ) THEN
+ CALL ICHKPAD('G','-', M, N,
+ $ MEM(PREAPTR), LDA, RDEST,
+ $ CDEST, MYROW, MYCOL,
+ $ IPRE, IPOST, CHECKVAL,
+ $ TESTNUM, MAXERR, NERR,
+ $ MEM(ERRIPTR),MEM(ERRDPTR))
+ CALL ICHKSUM(SCOPE, CONTEXT, M, N,
+ $ MEM(APTR), LDA,
+ $ TESTNUM, MAXERR, NERR,
+ $ MEM(ERRIPTR),MEM(ERRDPTR),
+ $ ISEED)
+ END IF
+ 30 CONTINUE
+ CALL BLACS_SET(CONTEXT, 16, 0)
+ 35 CONTINUE
+ CALL BLACS_SET(CONTEXT, 15, 0)
+ 40 CONTINUE
+ TESTOK = ( K .EQ. NERR )
+ END IF
+ END IF
+*
+ IF( VERB .GT. 1 ) THEN
+ I = NERR
+ CALL IBTCHECKIN(0, OUTNUM, MAXERR, NERR,
+ $ MEM(ERRIPTR), MEM(ERRDPTR), ISEED)
+ IF( IAM .EQ. 0 ) THEN
+ IF( TESTOK .AND. NERR.EQ.I ) THEN
+ WRITE(OUTNUM,6000)TESTNUM,'PASSED ',
+ $ SCOPE, TOP, M, N, LDASRC,
+ $ LDADST, RDEST2, CDEST2,
+ $ NPROW, NPCOL
+ ELSE
+ NFAIL = NFAIL + 1
+ WRITE(OUTNUM,6000)TESTNUM,'FAILED ',
+ $ SCOPE, TOP, M, N, LDASRC,
+ $ LDADST, RDEST2, CDEST2,
+ $ NPROW, NPCOL
+ END IF
+ END IF
+*
+* Once we've printed out errors, can re-use buf space
+*
+ NERR = 0
+ END IF
+ 50 CONTINUE
+ 60 CONTINUE
+ 70 CONTINUE
+ 80 CONTINUE
+ 90 CONTINUE
+*
+ IF( VERB .LT. 2 ) THEN
+ NFAIL = TESTNUM
+ CALL IBTCHECKIN( NFAIL, OUTNUM, MAXERR, NERR, MEM(ERRIPTR),
+ $ MEM(ERRDPTR), ISEED )
+ END IF
+ IF( IAM .EQ. 0 ) THEN
+ IF( VERB .GT. 1 ) WRITE(OUTNUM,*) ' '
+ IF( NFAIL+NSKIP .EQ. 0 ) THEN
+ WRITE(OUTNUM, 7000 ) TESTNUM
+ ELSE
+ WRITE(OUTNUM, 8000 ) TESTNUM, TESTNUM-NSKIP-NFAIL,
+ $ NSKIP, NFAIL
+ END IF
+ END IF
+*
+* Log whether their were any failures
+*
+ TESTOK = ALLPASS( (NFAIL.EQ.0) )
+*
+ 1000 FORMAT('INTEGER SUM TESTS: BEGIN.' )
+ 2000 FORMAT(1X,A7,3X,10I6)
+ 3000 FORMAT(1X,A7,3X,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1,
+ $ 5X,A1,5X,A1)
+ 4000 FORMAT(' TEST# STATUS SCOPE TOP M N LDAS LDAD ',
+ $ 'RDEST CDEST P Q')
+ 5000 FORMAT(' ----- ------- ----- --- ----- ----- ----- ----- ',
+ $ '----- ----- ---- ----')
+ 6000 FORMAT(I6,1X,A7,5X,A1,3X,A1,6I6,2I5)
+ 7000 FORMAT('INTEGER SUM TESTS: PASSED ALL',
+ $ I5, ' TESTS.')
+ 8000 FORMAT('INTEGER SUM TESTS:',I5,' TESTS;',I5,' PASSED,',
+ $ I5,' SKIPPED,',I5,' FAILED.')
+*
+ RETURN
+*
+* End of ITESTSUM.
+*
+ END
+*
+ INTEGER FUNCTION IBTABS(VAL)
+ INTEGER VAL
+ IBTABS = ABS(VAL)
+ RETURN
+ END
+*
+ SUBROUTINE ICHKSUM( SCOPE, ICTXT, M, N, A, LDA, TESTNUM, MAXERR,
+ $ NERR, ERRIBUF, ERRDBUF, ISEED )
+*
+* .. Scalar Arguments ..
+ CHARACTER*1 SCOPE
+ INTEGER ICTXT, M, N, LDA, TESTNUM, MAXERR, NERR
+* ..
+* .. Array Arguments ..
+ INTEGER ERRIBUF(6, MAXERR), ISEED(*)
+ INTEGER A(LDA,*), ERRDBUF(2, MAXERR)
+* ..
+* .. External Functions ..
+ INTEGER IBTMYPROC, IBTNPROCS
+ INTEGER IBTRAN
+ EXTERNAL IBTMYPROC, IBTNPROCS, IBTRAN
+* ..
+* .. Local Scalars ..
+ INTEGER NPROCS, NPROW, NPCOL, MYROW, MYCOL, NODE, NNODES, DEST
+ INTEGER I, J, K
+ INTEGER ANS
+* ..
+* .. Executable Statements ..
+*
+ NPROCS = IBTNPROCS()
+ CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL )
+ DEST = MYROW*NPROCS + MYCOL
+*
+* Set up seeds to match those used by each proc's genmat call
+*
+ IF( SCOPE .EQ. 'R' ) THEN
+ NNODES = NPCOL
+ DO 10 I = 0, NNODES-1
+ NODE = MYROW * NPROCS + I
+ ISEED(I*4+1) = MOD( 1002 + TESTNUM*5 + NODE*3, 4096 )
+ ISEED(I*4+2) = MOD( 2027 + TESTNUM*7 + NODE, 4096 )
+ ISEED(I*4+3) = MOD( 1234 + TESTNUM + NODE*3, 4096 )
+ ISEED(I*4+4) = MOD( 4311 + TESTNUM*10 + NODE*2, 4096 )
+ 10 CONTINUE
+ ELSE IF( SCOPE .EQ. 'C' ) THEN
+ NNODES = NPROW
+ DO 20 I = 0, NNODES-1
+ NODE = I * NPROCS + MYCOL
+ ISEED(I*4+1) = MOD( 1002 + TESTNUM*5 + NODE*3, 4096 )
+ ISEED(I*4+2) = MOD( 2027 + TESTNUM*7 + NODE, 4096 )
+ ISEED(I*4+3) = MOD( 1234 + TESTNUM + NODE*3, 4096 )
+ ISEED(I*4+4) = MOD( 4311 + TESTNUM*10 + NODE*2, 4096 )
+ 20 CONTINUE
+ ELSE
+ NNODES = NPROW * NPCOL
+ DO 30 I = 0, NNODES-1
+ NODE = (I / NPCOL) * NPROCS + MOD(I, NPCOL)
+ ISEED(I*4+1) = MOD( 1002 + TESTNUM*5 + NODE*3, 4096 )
+ ISEED(I*4+2) = MOD( 2027 + TESTNUM*7 + NODE, 4096 )
+ ISEED(I*4+3) = MOD( 1234 + TESTNUM + NODE*3, 4096 )
+ ISEED(I*4+4) = MOD( 4311 + TESTNUM*10 + NODE*2, 4096 )
+ 30 CONTINUE
+ END IF
+*
+ DO 100 J = 1, N
+ DO 90 I = 1, M
+ ANS = 0
+ DO 40 K = 0, NNODES-1
+ ANS = ANS + IBTRAN( ISEED(K*4+1) )
+ 40 CONTINUE
+*
+* The error bound is figured by
+* 2 * eps * (nnodes-1) * max(|max element|, |ans|).
+* The 2 allows for errors in the distributed _AND_ local result.
+* The eps is machine epsilon. The number of floating point adds
+* is (nnodes - 1). We use the fact that 0.5 is the maximum element
+* in order to save ourselves some computation.
+*
+ IF( ANS .NE. A(I,J) ) THEN
+ NERR = NERR + 1
+ IF( NERR .LE. MAXERR ) THEN
+ ERRIBUF(1, NERR) = TESTNUM
+ ERRIBUF(2, NERR) = NNODES
+ ERRIBUF(3, NERR) = DEST
+ ERRIBUF(4, NERR) = I
+ ERRIBUF(5, NERR) = J
+ ERRIBUF(6, NERR) = 5
+ ERRDBUF(1, NERR) = A(I,J)
+ ERRDBUF(2, NERR) = ANS
+ END IF
+ END IF
+ 90 CONTINUE
+ 100 CONTINUE
+*
+ RETURN
+*
+* End of ICHKSUM
+*
+ END
+*
+*
+ SUBROUTINE SSUMTEST( OUTNUM, VERB, TOPSREPEAT, TOPSCOHRNT, NSCOPE,
+ $ SCOPE0, NTOP, TOP0, NMAT, M0, N0, LDAS0,
+ $ LDAD0, NDEST, RDEST0, CDEST0, NGRID,
+ $ CONTEXT0, P0, Q0, ISEED, MEM, MEMLEN )
+*
+* -- BLACS tester (version 1.0) --
+* University of Tennessee
+* December 15, 1994
+*
+*
+* .. Scalar Arguments ..
+ INTEGER MEMLEN, NDEST, NGRID, NMAT, NSCOPE, NTOP, OUTNUM,
+ $ TOPSCOHRNT, TOPSREPEAT, VERB
+* ..
+* .. Array Arguments ..
+ CHARACTER*1 SCOPE0(NSCOPE), TOP0(NTOP)
+ INTEGER M0(NMAT), N0(NMAT), LDAS0(NMAT), LDAD0(NMAT)
+ INTEGER RDEST0(NDEST), CDEST0(NDEST), CONTEXT0(NGRID)
+ INTEGER P0(NGRID), Q0(NGRID), ISEED(*)
+ REAL MEM(MEMLEN)
+* ..
+*
+* Purpose
+* =======
+* STESTSUM: Test real SUM COMBINE
+*
+* Arguments
+* =========
+* OUTNUM (input) INTEGER
+* The device number to write output to.
+*
+* VERB (input) INTEGER
+* The level of verbosity (how much printing to do).
+*
+* NSCOPE (input) INTEGER
+* The number of scopes to be tested.
+*
+* SCOPE0 (input) CHARACTER*1 array of dimension (NSCOPE)
+* Values of the scopes to be tested.
+*
+* NTOP (input) INTEGER
+* The number of topologies to be tested.
+*
+* TOP0 (input) CHARACTER*1 array of dimension (NTOP)
+* Values of the topologies to be tested.
+*
+* NMAT (input) INTEGER
+* The number of matrices to be tested.
+*
+* M0 (input) INTEGER array of dimension (NMAT)
+* Values of M to be tested.
+*
+* M0 (input) INTEGER array of dimension (NMAT)
+* Values of M to be tested.
+*
+* N0 (input) INTEGER array of dimension (NMAT)
+* Values of N to be tested.
+*
+* LDAS0 (input) INTEGER array of dimension (NMAT)
+* Values of LDAS (leading dimension of A on source process)
+* to be tested.
+*
+* LDAD0 (input) INTEGER array of dimension (NMAT)
+* Values of LDAD (leading dimension of A on destination
+* process) to be tested.
+* NDEST (input) INTEGER
+* The number of destinations to be tested.
+*
+* RDEST0 (input) INTEGER array of dimension (NNDEST)
+* Values of RDEST (row coordinate of destination) to be
+* tested.
+*
+* CDEST0 (input) INTEGER array of dimension (NNDEST)
+* Values of CDEST (column coordinate of destination) to be
+* tested.
+*
+* NGRID (input) INTEGER
+* The number of process grids to be tested.
+*
+* CONTEXT0 (input) INTEGER array of dimension (NGRID)
+* The BLACS context handles corresponding to the grids.
+*
+* P0 (input) INTEGER array of dimension (NGRID)
+* Values of P (number of process rows, NPROW).
+*
+* Q0 (input) INTEGER array of dimension (NGRID)
+* Values of Q (number of process columns, NPCOL).
+*
+* ISEED (workspace) INTEGER array of dimension ( MAX(NPROCS, NTESTS) )
+* Workspace used to hold each process's random number SEED.
+* This requires NPROCS (number of processor) elements.
+* If VERB < 2, this workspace also serves to indicate which
+* tests fail. This requires workspace of NTESTS
+* (number of tests performed).
+*
+* MEM (workspace) REAL array of dimension (MEMLEN)
+* Used for all other workspaces, including the matrix A,
+* and its pre and post padding.
+*
+* MEMLEN (input) INTEGER
+* The length, in elements, of MEM.
+*
+* =====================================================================
+*
+* .. External Functions ..
+ LOGICAL ALLPASS, LSAME
+ INTEGER IBTMYPROC, IBTNPROCS, IBTSIZEOF
+ EXTERNAL ALLPASS, LSAME, IBTMYPROC, IBTNPROCS, IBTSIZEOF
+* ..
+* .. External Subroutines ..
+ EXTERNAL BLACS_GRIDINFO, SGSUM2D
+ EXTERNAL SINITMAT, SCHKPAD, SBTCHECKIN
+* ..
+* .. Local Scalars ..
+ CHARACTER*1 SCOPE, TOP
+ LOGICAL INGRID, TESTOK, ALLRCV
+ INTEGER APTR, CDEST, CDEST2, CONTEXT, ERRDPTR, ERRIPTR, I, IAM,
+ $ IDE, IGR, IMA, IPAD, IPOST, IPRE, ISC, ISIZE, ISTART,
+ $ ISTOP, ITC, ITC1, ITC2, ITO, ITR, ITR1, ITR2, J, K, LDA,
+ $ LDADST, LDASRC, M, MAXERR, MYCOL, MYROW, N, NERR, NFAIL,
+ $ NPCOL, NPROW, NSKIP, PREAPTR, RDEST, RDEST2, SETWHAT,
+ $ SSIZE, TESTNUM
+ REAL CHECKVAL
+* ..
+* .. Executable Statements ..
+*
+* Choose padding value, and make it unique
+*
+ CHECKVAL = -0.61E0
+ IAM = IBTMYPROC()
+ CHECKVAL = IAM * CHECKVAL
+ ISIZE = IBTSIZEOF('I')
+ SSIZE = IBTSIZEOF('S')
+*
+* Verify file parameters
+*
+ IF( IAM .EQ. 0 ) THEN
+ WRITE(OUTNUM, *) ' '
+ WRITE(OUTNUM, *) ' '
+ WRITE(OUTNUM, 1000 )
+ IF( VERB .GT. 0 ) THEN
+ WRITE(OUTNUM,*) ' '
+ WRITE(OUTNUM, 2000) 'NSCOPE:', NSCOPE
+ WRITE(OUTNUM, 3000) ' SCOPE:', ( SCOPE0(I), I = 1, NSCOPE )
+ WRITE(OUTNUM, 2000) 'TReps :', TOPSREPEAT
+ WRITE(OUTNUM, 2000) 'TCohr :', TOPSCOHRNT
+ WRITE(OUTNUM, 2000) 'NTOP :', NTOP
+ WRITE(OUTNUM, 3000) ' TOP :', ( TOP0(I), I = 1, NTOP )
+ WRITE(OUTNUM, 2000) 'NMAT :', NMAT
+ WRITE(OUTNUM, 2000) ' M :', ( M0(I), I = 1, NMAT )
+ WRITE(OUTNUM, 2000) ' N :', ( N0(I), I = 1, NMAT )
+ WRITE(OUTNUM, 2000) ' LDAS :', ( LDAS0(I), I = 1, NMAT )
+ WRITE(OUTNUM, 2000) ' LDAD :', ( LDAD0(I), I = 1, NMAT )
+ WRITE(OUTNUM, 2000) 'NDEST :', NDEST
+ WRITE(OUTNUM, 2000) ' RDEST:',( RDEST0(I), I = 1, NDEST )
+ WRITE(OUTNUM, 2000) ' CDEST:',( CDEST0(I), I = 1, NDEST )
+ WRITE(OUTNUM, 2000) 'NGRIDS:', NGRID
+ WRITE(OUTNUM, 2000) ' P :', ( P0(I), I = 1, NGRID )
+ WRITE(OUTNUM, 2000) ' Q :', ( Q0(I), I = 1, NGRID )
+ WRITE(OUTNUM, 2000) 'VERB :', VERB
+ WRITE(OUTNUM,*) ' '
+ END IF
+ IF( VERB .GT. 1 ) THEN
+ WRITE(OUTNUM,4000)
+ WRITE(OUTNUM,5000)
+ END IF
+ END IF
+ IF (TOPSREPEAT.EQ.0) THEN
+ ITR1 = 0
+ ITR2 = 0
+ ELSE IF (TOPSREPEAT.EQ.1) THEN
+ ITR1 = 1
+ ITR2 = 1
+ ELSE
+ ITR1 = 0
+ ITR2 = 1
+ END IF
+*
+* Find biggest matrix, so we know where to stick error info
+*
+ I = 0
+ DO 10 IMA = 1, NMAT
+ IPAD = 4 * M0(IMA)
+ K = N0(IMA) * MAX0( LDAS0(IMA), LDAD0(IMA) ) + IPAD
+ IF( K .GT. I ) I = K
+ 10 CONTINUE
+ MAXERR = ( SSIZE * (MEMLEN-I) ) / ( SSIZE*2 + ISIZE*6 )
+ IF( MAXERR .LT. 1 ) THEN
+ WRITE(OUTNUM,*) 'ERROR: Not enough memory to run SUM tests.'
+ CALL BLACS_ABORT(-1, 1)
+ END IF
+ ERRDPTR = I + 1
+ ERRIPTR = ERRDPTR + MAXERR
+ NERR = 0
+ TESTNUM = 0
+ NFAIL = 0
+ NSKIP = 0
+*
+* Loop over grids of matrix
+*
+ DO 90 IGR = 1, NGRID
+*
+* allocate process grid for the next batch of tests
+*
+ CONTEXT = CONTEXT0(IGR)
+ CALL BLACS_GRIDINFO( CONTEXT, NPROW, NPCOL, MYROW, MYCOL )
+ INGRID = ( (MYROW.LT.NPROW) .AND. (MYCOL.LT.NPCOL) )
+*
+ DO 80 ISC = 1, NSCOPE
+ SCOPE = SCOPE0(ISC)
+ DO 70 ITO = 1, NTOP
+ TOP = TOP0(ITO)
+*
+* If testing multiring ('M') or general tree ('T'), need to
+* loop over calls to BLACS_SET to do full test
+*
+ IF( LSAME(TOP, 'M') ) THEN
+ SETWHAT = 13
+ IF( SCOPE .EQ. 'R' ) THEN
+ ISTART = -(NPCOL - 1)
+ ISTOP = -ISTART
+ ELSE IF (SCOPE .EQ. 'C') THEN
+ ISTART = -(NPROW - 1)
+ ISTOP = -ISTART
+ ELSE
+ ISTART = -(NPROW*NPCOL - 1)
+ ISTOP = -ISTART
+ ENDIF
+ ELSE IF( LSAME(TOP, 'T') ) THEN
+ SETWHAT = 14
+ ISTART = 1
+ IF( SCOPE .EQ. 'R' ) THEN
+ ISTOP = NPCOL - 1
+ ELSE IF (SCOPE .EQ. 'C') THEN
+ ISTOP = NPROW - 1
+ ELSE
+ ISTOP = NPROW*NPCOL - 1
+ ENDIF
+ ELSE
+ SETWHAT = 0
+ ISTART = 1
+ ISTOP = 1
+ ENDIF
+ DO 60 IMA = 1, NMAT
+ M = M0(IMA)
+ N = N0(IMA)
+ LDASRC = LDAS0(IMA)
+ LDADST = LDAD0(IMA)
+ IPRE = 2 * M
+ IPOST = IPRE
+ PREAPTR = 1
+ APTR = PREAPTR + IPRE
+*
+ DO 50 IDE = 1, NDEST
+ TESTNUM = TESTNUM + 1
+ RDEST2 = RDEST0(IDE)
+ CDEST2 = CDEST0(IDE)
+*
+* If everyone gets the answer, create some bogus rdest/cdest
+* so IF's are easier
+*
+ ALLRCV = ( (RDEST2.EQ.-1) .OR. (CDEST2.EQ.-1) )
+ IF( ALLRCV ) THEN
+ RDEST = NPROW - 1
+ CDEST = NPCOL - 1
+ IF (TOPSCOHRNT.EQ.0) THEN
+ ITR1 = 0
+ ITR2 = 0
+ ELSE IF (TOPSCOHRNT.EQ.1) THEN
+ ITR1 = 1
+ ITR2 = 1
+ ELSE
+ ITR1 = 0
+ ITR2 = 1
+ END IF
+ ELSE
+ RDEST = RDEST2
+ CDEST = CDEST2
+ ITC1 = 0
+ ITC2 = 0
+ END IF
+ IF( RDEST.GE.P0(IGR) .OR. CDEST.GE.Q0(IGR) ) THEN
+ NSKIP = NSKIP + 1
+ GOTO 50
+ END IF
+*
+ IF( MYROW.EQ.RDEST .AND. MYCOL.EQ.CDEST ) THEN
+ LDA = LDADST
+ ELSE
+ LDA = LDASRC
+ END IF
+ IF( VERB .GT. 1 ) THEN
+ IF( IAM .EQ. 0 ) THEN
+ WRITE(OUTNUM, 6000)
+ $ TESTNUM, 'RUNNING', SCOPE, TOP, M, N,
+ $ LDASRC, LDADST, RDEST2, CDEST2,
+ $ NPROW, NPCOL
+ END IF
+ END IF
+*
+* If I am in scope
+*
+ TESTOK = .TRUE.
+ IF( INGRID ) THEN
+ IF( (MYROW.EQ.RDEST .AND. SCOPE.EQ.'R') .OR.
+ $ (MYCOL.EQ.CDEST .AND. SCOPE.EQ.'C') .OR.
+ $ (SCOPE .EQ. 'A') ) THEN
+*
+ K = NERR
+ DO 40 ITR = ITR1, ITR2
+ CALL BLACS_SET(CONTEXT, 15, ITR)
+ DO 35 ITC = ITC1, ITC2
+ CALL BLACS_SET(CONTEXT, 16, ITC)
+ DO 30 J = ISTART, ISTOP
+ IF( J.EQ.0) GOTO 30
+ IF( SETWHAT.NE.0 )
+ $ CALL BLACS_SET(CONTEXT, SETWHAT, J)
+*
+*
+* generate and pad matrix A
+*
+ CALL SINITMAT('G','-', M, N, MEM(PREAPTR),
+ $ LDA, IPRE, IPOST,
+ $ CHECKVAL, TESTNUM,
+ $ MYROW, MYCOL )
+*
+ CALL SGSUM2D(CONTEXT, SCOPE, TOP, M, N,
+ $ MEM(APTR), LDA, RDEST2,
+ $ CDEST2)
+*
+* If I've got the answer, check for errors in
+* matrix or padding
+*
+ IF( (MYROW.EQ.RDEST .AND. MYCOL.EQ.CDEST)
+ $ .OR. ALLRCV ) THEN
+ CALL SCHKPAD('G','-', M, N,
+ $ MEM(PREAPTR), LDA, RDEST,
+ $ CDEST, MYROW, MYCOL,
+ $ IPRE, IPOST, CHECKVAL,
+ $ TESTNUM, MAXERR, NERR,
+ $ MEM(ERRIPTR),MEM(ERRDPTR))
+ CALL SCHKSUM(SCOPE, CONTEXT, M, N,
+ $ MEM(APTR), LDA,
+ $ TESTNUM, MAXERR, NERR,
+ $ MEM(ERRIPTR),MEM(ERRDPTR),
+ $ ISEED)
+ END IF
+ 30 CONTINUE
+ CALL BLACS_SET(CONTEXT, 16, 0)
+ 35 CONTINUE
+ CALL BLACS_SET(CONTEXT, 15, 0)
+ 40 CONTINUE
+ TESTOK = ( K .EQ. NERR )
+ END IF
+ END IF
+*
+ IF( VERB .GT. 1 ) THEN
+ I = NERR
+ CALL SBTCHECKIN(0, OUTNUM, MAXERR, NERR,
+ $ MEM(ERRIPTR), MEM(ERRDPTR), ISEED)
+ IF( IAM .EQ. 0 ) THEN
+ IF( TESTOK .AND. NERR.EQ.I ) THEN
+ WRITE(OUTNUM,6000)TESTNUM,'PASSED ',
+ $ SCOPE, TOP, M, N, LDASRC,
+ $ LDADST, RDEST2, CDEST2,
+ $ NPROW, NPCOL
+ ELSE
+ NFAIL = NFAIL + 1
+ WRITE(OUTNUM,6000)TESTNUM,'FAILED ',
+ $ SCOPE, TOP, M, N, LDASRC,
+ $ LDADST, RDEST2, CDEST2,
+ $ NPROW, NPCOL
+ END IF
+ END IF
+*
+* Once we've printed out errors, can re-use buf space
+*
+ NERR = 0
+ END IF
+ 50 CONTINUE
+ 60 CONTINUE
+ 70 CONTINUE
+ 80 CONTINUE
+ 90 CONTINUE
+*
+ IF( VERB .LT. 2 ) THEN
+ NFAIL = TESTNUM
+ CALL SBTCHECKIN( NFAIL, OUTNUM, MAXERR, NERR, MEM(ERRIPTR),
+ $ MEM(ERRDPTR), ISEED )
+ END IF
+ IF( IAM .EQ. 0 ) THEN
+ IF( VERB .GT. 1 ) WRITE(OUTNUM,*) ' '
+ IF( NFAIL+NSKIP .EQ. 0 ) THEN
+ WRITE(OUTNUM, 7000 ) TESTNUM
+ ELSE
+ WRITE(OUTNUM, 8000 ) TESTNUM, TESTNUM-NSKIP-NFAIL,
+ $ NSKIP, NFAIL
+ END IF
+ END IF
+*
+* Log whether their were any failures
+*
+ TESTOK = ALLPASS( (NFAIL.EQ.0) )
+*
+ 1000 FORMAT('REAL SUM TESTS: BEGIN.' )
+ 2000 FORMAT(1X,A7,3X,10I6)
+ 3000 FORMAT(1X,A7,3X,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1,
+ $ 5X,A1,5X,A1)
+ 4000 FORMAT(' TEST# STATUS SCOPE TOP M N LDAS LDAD ',
+ $ 'RDEST CDEST P Q')
+ 5000 FORMAT(' ----- ------- ----- --- ----- ----- ----- ----- ',
+ $ '----- ----- ---- ----')
+ 6000 FORMAT(I6,1X,A7,5X,A1,3X,A1,6I6,2I5)
+ 7000 FORMAT('REAL SUM TESTS: PASSED ALL',
+ $ I5, ' TESTS.')
+ 8000 FORMAT('REAL SUM TESTS:',I5,' TESTS;',I5,' PASSED,',
+ $ I5,' SKIPPED,',I5,' FAILED.')
+*
+ RETURN
+*
+* End of STESTSUM.
+*
+ END
+*
+ REAL FUNCTION SBTABS(VAL)
+ REAL VAL
+ SBTABS = ABS(VAL)
+ RETURN
+ END
+*
+ REAL FUNCTION SBTEPS()
+*
+* .. External Functions ..
+ INTEGER IBTMYPROC, IBTNPROCS, IBTMSGID
+ REAL SLAMCH
+ EXTERNAL IBTMYPROC, IBTNPROCS, IBTMSGID, SLAMCH
+* ..
+* .. Local Scalars ..
+ INTEGER I, IAM, NNODES
+ REAL EPS, EPS2
+ SAVE EPS
+ DATA EPS /-22.0E0/
+* ..
+* .. Executable Statements ..
+*
+* First time called, must get max epsilon possessed by any
+* participating process
+*
+ IF( EPS .EQ. -22.0E0 ) THEN
+ IAM = IBTMYPROC()
+ NNODES = IBTNPROCS()
+ EPS = SLAMCH('epsilon')
+ IF( IAM .EQ. 0 ) THEN
+ IF( NNODES .GT. 1 ) THEN
+ DO 10 I = 1, NNODES-1
+ CALL BTRECV( 4, 1, EPS2, I, IBTMSGID()+20 )
+ IF( EPS .LT. EPS2 ) EPS = EPS2
+ 10 CONTINUE
+ END IF
+ CALL BTSEND( 4, 1, EPS, -1, IBTMSGID()+20 )
+ ELSE
+ CALL BTSEND( 4, 1, EPS, 0, IBTMSGID()+20 )
+ CALL BTRECV( 4, 1, EPS, 0, IBTMSGID()+20 )
+ ENDIF
+ END IF
+ SBTEPS = EPS
+ RETURN
+*
+* End SBTEPS
+*
+ END
+*
+ SUBROUTINE SCHKSUM( SCOPE, ICTXT, M, N, A, LDA, TESTNUM, MAXERR,
+ $ NERR, ERRIBUF, ERRDBUF, ISEED )
+*
+* .. Scalar Arguments ..
+ CHARACTER*1 SCOPE
+ INTEGER ICTXT, M, N, LDA, TESTNUM, MAXERR, NERR
+* ..
+* .. Array Arguments ..
+ INTEGER ERRIBUF(6, MAXERR), ISEED(*)
+ REAL A(LDA,*), ERRDBUF(2, MAXERR)
+* ..
+* .. External Functions ..
+ INTEGER IBTMYPROC, IBTNPROCS
+ REAL SBTEPS
+ REAL SBTRAN
+ EXTERNAL IBTMYPROC, IBTNPROCS, SBTEPS, SBTRAN
+* ..
+* .. Local Scalars ..
+ INTEGER NPROCS, NPROW, NPCOL, MYROW, MYCOL, NODE, NNODES, DEST
+ INTEGER I, J, K
+ REAL ANS, EPS, ERRBND, POSNUM, NEGNUM, TMP
+* ..
+* .. Executable Statements ..
+*
+ NPROCS = IBTNPROCS()
+ EPS = SBTEPS()
+ CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL )
+ DEST = MYROW*NPROCS + MYCOL
+*
+* Set up seeds to match those used by each proc's genmat call
+*
+ IF( SCOPE .EQ. 'R' ) THEN
+ NNODES = NPCOL
+ DO 10 I = 0, NNODES-1
+ NODE = MYROW * NPROCS + I
+ ISEED(I*4+1) = MOD( 1002 + TESTNUM*5 + NODE*3, 4096 )
+ ISEED(I*4+2) = MOD( 2027 + TESTNUM*7 + NODE, 4096 )
+ ISEED(I*4+3) = MOD( 1234 + TESTNUM + NODE*3, 4096 )
+ ISEED(I*4+4) = MOD( 4311 + TESTNUM*10 + NODE*2, 4096 )
+ 10 CONTINUE
+ ELSE IF( SCOPE .EQ. 'C' ) THEN
+ NNODES = NPROW
+ DO 20 I = 0, NNODES-1
+ NODE = I * NPROCS + MYCOL
+ ISEED(I*4+1) = MOD( 1002 + TESTNUM*5 + NODE*3, 4096 )
+ ISEED(I*4+2) = MOD( 2027 + TESTNUM*7 + NODE, 4096 )
+ ISEED(I*4+3) = MOD( 1234 + TESTNUM + NODE*3, 4096 )
+ ISEED(I*4+4) = MOD( 4311 + TESTNUM*10 + NODE*2, 4096 )
+ 20 CONTINUE
+ ELSE
+ NNODES = NPROW * NPCOL
+ DO 30 I = 0, NNODES-1
+ NODE = (I / NPCOL) * NPROCS + MOD(I, NPCOL)
+ ISEED(I*4+1) = MOD( 1002 + TESTNUM*5 + NODE*3, 4096 )
+ ISEED(I*4+2) = MOD( 2027 + TESTNUM*7 + NODE, 4096 )
+ ISEED(I*4+3) = MOD( 1234 + TESTNUM + NODE*3, 4096 )
+ ISEED(I*4+4) = MOD( 4311 + TESTNUM*10 + NODE*2, 4096 )
+ 30 CONTINUE
+ END IF
+*
+ DO 100 J = 1, N
+ DO 90 I = 1, M
+ ANS = 0
+ POSNUM = 0
+ NEGNUM = 0
+ DO 40 K = 0, NNODES-1
+ TMP = SBTRAN( ISEED(K*4+1) )
+ IF( TMP .LT. 0 ) THEN
+ NEGNUM = NEGNUM + TMP
+ ELSE
+ POSNUM = POSNUM + TMP
+ END IF
+ ANS = ANS + TMP
+ 40 CONTINUE
+*
+* The error bound is figured by
+* 2 * eps * (nnodes-1) * max(|max element|, |ans|).
+* The 2 allows for errors in the distributed _AND_ local result.
+* The eps is machine epsilon. The number of floating point adds
+* is (nnodes - 1). We use the fact that 0.5 is the maximum element
+* in order to save ourselves some computation.
+*
+ ERRBND = 2 * EPS * NNODES * MAX( POSNUM, -NEGNUM )
+ IF( ABS( ANS - A(I,J) ) .GT. ERRBND ) THEN
+ NERR = NERR + 1
+ IF( NERR .LE. MAXERR ) THEN
+ ERRIBUF(1, NERR) = TESTNUM
+ ERRIBUF(2, NERR) = NNODES
+ ERRIBUF(3, NERR) = DEST
+ ERRIBUF(4, NERR) = I
+ ERRIBUF(5, NERR) = J
+ ERRIBUF(6, NERR) = 5
+ ERRDBUF(1, NERR) = A(I,J)
+ ERRDBUF(2, NERR) = ANS
+ END IF
+ END IF
+ 90 CONTINUE
+ 100 CONTINUE
+*
+ RETURN
+*
+* End of SCHKSUM
+*
+ END
+*
+*
+ SUBROUTINE DSUMTEST( OUTNUM, VERB, TOPSREPEAT, TOPSCOHRNT, NSCOPE,
+ $ SCOPE0, NTOP, TOP0, NMAT, M0, N0, LDAS0,
+ $ LDAD0, NDEST, RDEST0, CDEST0, NGRID,
+ $ CONTEXT0, P0, Q0, ISEED, MEM, MEMLEN )
+*
+* -- BLACS tester (version 1.0) --
+* University of Tennessee
+* December 15, 1994
+*
+*
+* .. Scalar Arguments ..
+ INTEGER MEMLEN, NDEST, NGRID, NMAT, NSCOPE, NTOP, OUTNUM,
+ $ TOPSCOHRNT, TOPSREPEAT, VERB
+* ..
+* .. Array Arguments ..
+ CHARACTER*1 SCOPE0(NSCOPE), TOP0(NTOP)
+ INTEGER M0(NMAT), N0(NMAT), LDAS0(NMAT), LDAD0(NMAT)
+ INTEGER RDEST0(NDEST), CDEST0(NDEST), CONTEXT0(NGRID)
+ INTEGER P0(NGRID), Q0(NGRID), ISEED(*)
+ DOUBLE PRECISION MEM(MEMLEN)
+* ..
+*
+* Purpose
+* =======
+* DTESTSUM: Test double precision SUM COMBINE
+*
+* Arguments
+* =========
+* OUTNUM (input) INTEGER
+* The device number to write output to.
+*
+* VERB (input) INTEGER
+* The level of verbosity (how much printing to do).
+*
+* NSCOPE (input) INTEGER
+* The number of scopes to be tested.
+*
+* SCOPE0 (input) CHARACTER*1 array of dimension (NSCOPE)
+* Values of the scopes to be tested.
+*
+* NTOP (input) INTEGER
+* The number of topologies to be tested.
+*
+* TOP0 (input) CHARACTER*1 array of dimension (NTOP)
+* Values of the topologies to be tested.
+*
+* NMAT (input) INTEGER
+* The number of matrices to be tested.
+*
+* M0 (input) INTEGER array of dimension (NMAT)
+* Values of M to be tested.
+*
+* M0 (input) INTEGER array of dimension (NMAT)
+* Values of M to be tested.
+*
+* N0 (input) INTEGER array of dimension (NMAT)
+* Values of N to be tested.
+*
+* LDAS0 (input) INTEGER array of dimension (NMAT)
+* Values of LDAS (leading dimension of A on source process)
+* to be tested.
+*
+* LDAD0 (input) INTEGER array of dimension (NMAT)
+* Values of LDAD (leading dimension of A on destination
+* process) to be tested.
+* NDEST (input) INTEGER
+* The number of destinations to be tested.
+*
+* RDEST0 (input) INTEGER array of dimension (NNDEST)
+* Values of RDEST (row coordinate of destination) to be
+* tested.
+*
+* CDEST0 (input) INTEGER array of dimension (NNDEST)
+* Values of CDEST (column coordinate of destination) to be
+* tested.
+*
+* NGRID (input) INTEGER
+* The number of process grids to be tested.
+*
+* CONTEXT0 (input) INTEGER array of dimension (NGRID)
+* The BLACS context handles corresponding to the grids.
+*
+* P0 (input) INTEGER array of dimension (NGRID)
+* Values of P (number of process rows, NPROW).
+*
+* Q0 (input) INTEGER array of dimension (NGRID)
+* Values of Q (number of process columns, NPCOL).
+*
+* ISEED (workspace) INTEGER array of dimension ( MAX(NPROCS, NTESTS) )
+* Workspace used to hold each process's random number SEED.
+* This requires NPROCS (number of processor) elements.
+* If VERB < 2, this workspace also serves to indicate which
+* tests fail. This requires workspace of NTESTS
+* (number of tests performed).
+*
+* MEM (workspace) DOUBLE PRECISION array of dimension (MEMLEN)
+* Used for all other workspaces, including the matrix A,
+* and its pre and post padding.
+*
+* MEMLEN (input) INTEGER
+* The length, in elements, of MEM.
+*
+* =====================================================================
+*
+* .. External Functions ..
+ LOGICAL ALLPASS, LSAME
+ INTEGER IBTMYPROC, IBTNPROCS, IBTSIZEOF
+ EXTERNAL ALLPASS, LSAME, IBTMYPROC, IBTNPROCS, IBTSIZEOF
+* ..
+* .. External Subroutines ..
+ EXTERNAL BLACS_GRIDINFO, DGSUM2D
+ EXTERNAL DINITMAT, DCHKPAD, DBTCHECKIN
+* ..
+* .. Local Scalars ..
+ CHARACTER*1 SCOPE, TOP
+ LOGICAL INGRID, TESTOK, ALLRCV
+ INTEGER APTR, CDEST, CDEST2, CONTEXT, DSIZE, ERRDPTR, ERRIPTR, I,
+ $ IAM, IDE, IGR, IMA, IPAD, IPOST, IPRE, ISC, ISIZE, ISTART,
+ $ ISTOP, ITC, ITC1, ITC2, ITO, ITR, ITR1, ITR2, J, K, LDA,
+ $ LDADST, LDASRC, M, MAXERR, MYCOL, MYROW, N, NERR, NFAIL,
+ $ NPCOL, NPROW, NSKIP, PREAPTR, RDEST, RDEST2, SETWHAT,
+ $ TESTNUM
+ DOUBLE PRECISION CHECKVAL
+* ..
+* .. Executable Statements ..
+*
+* Choose padding value, and make it unique
+*
+ CHECKVAL = -0.81D0
+ IAM = IBTMYPROC()
+ CHECKVAL = IAM * CHECKVAL
+ ISIZE = IBTSIZEOF('I')
+ DSIZE = IBTSIZEOF('D')
+*
+* Verify file parameters
+*
+ IF( IAM .EQ. 0 ) THEN
+ WRITE(OUTNUM, *) ' '
+ WRITE(OUTNUM, *) ' '
+ WRITE(OUTNUM, 1000 )
+ IF( VERB .GT. 0 ) THEN
+ WRITE(OUTNUM,*) ' '
+ WRITE(OUTNUM, 2000) 'NSCOPE:', NSCOPE
+ WRITE(OUTNUM, 3000) ' SCOPE:', ( SCOPE0(I), I = 1, NSCOPE )
+ WRITE(OUTNUM, 2000) 'TReps :', TOPSREPEAT
+ WRITE(OUTNUM, 2000) 'TCohr :', TOPSCOHRNT
+ WRITE(OUTNUM, 2000) 'NTOP :', NTOP
+ WRITE(OUTNUM, 3000) ' TOP :', ( TOP0(I), I = 1, NTOP )
+ WRITE(OUTNUM, 2000) 'NMAT :', NMAT
+ WRITE(OUTNUM, 2000) ' M :', ( M0(I), I = 1, NMAT )
+ WRITE(OUTNUM, 2000) ' N :', ( N0(I), I = 1, NMAT )
+ WRITE(OUTNUM, 2000) ' LDAS :', ( LDAS0(I), I = 1, NMAT )
+ WRITE(OUTNUM, 2000) ' LDAD :', ( LDAD0(I), I = 1, NMAT )
+ WRITE(OUTNUM, 2000) 'NDEST :', NDEST
+ WRITE(OUTNUM, 2000) ' RDEST:',( RDEST0(I), I = 1, NDEST )
+ WRITE(OUTNUM, 2000) ' CDEST:',( CDEST0(I), I = 1, NDEST )
+ WRITE(OUTNUM, 2000) 'NGRIDS:', NGRID
+ WRITE(OUTNUM, 2000) ' P :', ( P0(I), I = 1, NGRID )
+ WRITE(OUTNUM, 2000) ' Q :', ( Q0(I), I = 1, NGRID )
+ WRITE(OUTNUM, 2000) 'VERB :', VERB
+ WRITE(OUTNUM,*) ' '
+ END IF
+ IF( VERB .GT. 1 ) THEN
+ WRITE(OUTNUM,4000)
+ WRITE(OUTNUM,5000)
+ END IF
+ END IF
+ IF (TOPSREPEAT.EQ.0) THEN
+ ITR1 = 0
+ ITR2 = 0
+ ELSE IF (TOPSREPEAT.EQ.1) THEN
+ ITR1 = 1
+ ITR2 = 1
+ ELSE
+ ITR1 = 0
+ ITR2 = 1
+ END IF
+*
+* Find biggest matrix, so we know where to stick error info
+*
+ I = 0
+ DO 10 IMA = 1, NMAT
+ IPAD = 4 * M0(IMA)
+ K = N0(IMA) * MAX0( LDAS0(IMA), LDAD0(IMA) ) + IPAD
+ IF( K .GT. I ) I = K
+ 10 CONTINUE
+ MAXERR = ( DSIZE * (MEMLEN-I) ) / ( DSIZE*2 + ISIZE*6 )
+ IF( MAXERR .LT. 1 ) THEN
+ WRITE(OUTNUM,*) 'ERROR: Not enough memory to run SUM tests.'
+ CALL BLACS_ABORT(-1, 1)
+ END IF
+ ERRDPTR = I + 1
+ ERRIPTR = ERRDPTR + MAXERR
+ NERR = 0
+ TESTNUM = 0
+ NFAIL = 0
+ NSKIP = 0
+*
+* Loop over grids of matrix
+*
+ DO 90 IGR = 1, NGRID
+*
+* allocate process grid for the next batch of tests
+*
+ CONTEXT = CONTEXT0(IGR)
+ CALL BLACS_GRIDINFO( CONTEXT, NPROW, NPCOL, MYROW, MYCOL )
+ INGRID = ( (MYROW.LT.NPROW) .AND. (MYCOL.LT.NPCOL) )
+*
+ DO 80 ISC = 1, NSCOPE
+ SCOPE = SCOPE0(ISC)
+ DO 70 ITO = 1, NTOP
+ TOP = TOP0(ITO)
+*
+* If testing multiring ('M') or general tree ('T'), need to
+* loop over calls to BLACS_SET to do full test
+*
+ IF( LSAME(TOP, 'M') ) THEN
+ SETWHAT = 13
+ IF( SCOPE .EQ. 'R' ) THEN
+ ISTART = -(NPCOL - 1)
+ ISTOP = -ISTART
+ ELSE IF (SCOPE .EQ. 'C') THEN
+ ISTART = -(NPROW - 1)
+ ISTOP = -ISTART
+ ELSE
+ ISTART = -(NPROW*NPCOL - 1)
+ ISTOP = -ISTART
+ ENDIF
+ ELSE IF( LSAME(TOP, 'T') ) THEN
+ SETWHAT = 14
+ ISTART = 1
+ IF( SCOPE .EQ. 'R' ) THEN
+ ISTOP = NPCOL - 1
+ ELSE IF (SCOPE .EQ. 'C') THEN
+ ISTOP = NPROW - 1
+ ELSE
+ ISTOP = NPROW*NPCOL - 1
+ ENDIF
+ ELSE
+ SETWHAT = 0
+ ISTART = 1
+ ISTOP = 1
+ ENDIF
+ DO 60 IMA = 1, NMAT
+ M = M0(IMA)
+ N = N0(IMA)
+ LDASRC = LDAS0(IMA)
+ LDADST = LDAD0(IMA)
+ IPRE = 2 * M
+ IPOST = IPRE
+ PREAPTR = 1
+ APTR = PREAPTR + IPRE
+*
+ DO 50 IDE = 1, NDEST
+ TESTNUM = TESTNUM + 1
+ RDEST2 = RDEST0(IDE)
+ CDEST2 = CDEST0(IDE)
+*
+* If everyone gets the answer, create some bogus rdest/cdest
+* so IF's are easier
+*
+ ALLRCV = ( (RDEST2.EQ.-1) .OR. (CDEST2.EQ.-1) )
+ IF( ALLRCV ) THEN
+ RDEST = NPROW - 1
+ CDEST = NPCOL - 1
+ IF (TOPSCOHRNT.EQ.0) THEN
+ ITR1 = 0
+ ITR2 = 0
+ ELSE IF (TOPSCOHRNT.EQ.1) THEN
+ ITR1 = 1
+ ITR2 = 1
+ ELSE
+ ITR1 = 0
+ ITR2 = 1
+ END IF
+ ELSE
+ RDEST = RDEST2
+ CDEST = CDEST2
+ ITC1 = 0
+ ITC2 = 0
+ END IF
+ IF( RDEST.GE.P0(IGR) .OR. CDEST.GE.Q0(IGR) ) THEN
+ NSKIP = NSKIP + 1
+ GOTO 50
+ END IF
+*
+ IF( MYROW.EQ.RDEST .AND. MYCOL.EQ.CDEST ) THEN
+ LDA = LDADST
+ ELSE
+ LDA = LDASRC
+ END IF
+ IF( VERB .GT. 1 ) THEN
+ IF( IAM .EQ. 0 ) THEN
+ WRITE(OUTNUM, 6000)
+ $ TESTNUM, 'RUNNING', SCOPE, TOP, M, N,
+ $ LDASRC, LDADST, RDEST2, CDEST2,
+ $ NPROW, NPCOL
+ END IF
+ END IF
+*
+* If I am in scope
+*
+ TESTOK = .TRUE.
+ IF( INGRID ) THEN
+ IF( (MYROW.EQ.RDEST .AND. SCOPE.EQ.'R') .OR.
+ $ (MYCOL.EQ.CDEST .AND. SCOPE.EQ.'C') .OR.
+ $ (SCOPE .EQ. 'A') ) THEN
+*
+ K = NERR
+ DO 40 ITR = ITR1, ITR2
+ CALL BLACS_SET(CONTEXT, 15, ITR)
+ DO 35 ITC = ITC1, ITC2
+ CALL BLACS_SET(CONTEXT, 16, ITC)
+ DO 30 J = ISTART, ISTOP
+ IF( J.EQ.0) GOTO 30
+ IF( SETWHAT.NE.0 )
+ $ CALL BLACS_SET(CONTEXT, SETWHAT, J)
+*
+*
+* generate and pad matrix A
+*
+ CALL DINITMAT('G','-', M, N, MEM(PREAPTR),
+ $ LDA, IPRE, IPOST,
+ $ CHECKVAL, TESTNUM,
+ $ MYROW, MYCOL )
+*
+ CALL DGSUM2D(CONTEXT, SCOPE, TOP, M, N,
+ $ MEM(APTR), LDA, RDEST2,
+ $ CDEST2)
+*
+* If I've got the answer, check for errors in
+* matrix or padding
+*
+ IF( (MYROW.EQ.RDEST .AND. MYCOL.EQ.CDEST)
+ $ .OR. ALLRCV ) THEN
+ CALL DCHKPAD('G','-', M, N,
+ $ MEM(PREAPTR), LDA, RDEST,
+ $ CDEST, MYROW, MYCOL,
+ $ IPRE, IPOST, CHECKVAL,
+ $ TESTNUM, MAXERR, NERR,
+ $ MEM(ERRIPTR),MEM(ERRDPTR))
+ CALL DCHKSUM(SCOPE, CONTEXT, M, N,
+ $ MEM(APTR), LDA,
+ $ TESTNUM, MAXERR, NERR,
+ $ MEM(ERRIPTR),MEM(ERRDPTR),
+ $ ISEED)
+ END IF
+ 30 CONTINUE
+ CALL BLACS_SET(CONTEXT, 16, 0)
+ 35 CONTINUE
+ CALL BLACS_SET(CONTEXT, 15, 0)
+ 40 CONTINUE
+ TESTOK = ( K .EQ. NERR )
+ END IF
+ END IF
+*
+ IF( VERB .GT. 1 ) THEN
+ I = NERR
+ CALL DBTCHECKIN(0, OUTNUM, MAXERR, NERR,
+ $ MEM(ERRIPTR), MEM(ERRDPTR), ISEED)
+ IF( IAM .EQ. 0 ) THEN
+ IF( TESTOK .AND. NERR.EQ.I ) THEN
+ WRITE(OUTNUM,6000)TESTNUM,'PASSED ',
+ $ SCOPE, TOP, M, N, LDASRC,
+ $ LDADST, RDEST2, CDEST2,
+ $ NPROW, NPCOL
+ ELSE
+ NFAIL = NFAIL + 1
+ WRITE(OUTNUM,6000)TESTNUM,'FAILED ',
+ $ SCOPE, TOP, M, N, LDASRC,
+ $ LDADST, RDEST2, CDEST2,
+ $ NPROW, NPCOL
+ END IF
+ END IF
+*
+* Once we've printed out errors, can re-use buf space
+*
+ NERR = 0
+ END IF
+ 50 CONTINUE
+ 60 CONTINUE
+ 70 CONTINUE
+ 80 CONTINUE
+ 90 CONTINUE
+*
+ IF( VERB .LT. 2 ) THEN
+ NFAIL = TESTNUM
+ CALL DBTCHECKIN( NFAIL, OUTNUM, MAXERR, NERR, MEM(ERRIPTR),
+ $ MEM(ERRDPTR), ISEED )
+ END IF
+ IF( IAM .EQ. 0 ) THEN
+ IF( VERB .GT. 1 ) WRITE(OUTNUM,*) ' '
+ IF( NFAIL+NSKIP .EQ. 0 ) THEN
+ WRITE(OUTNUM, 7000 ) TESTNUM
+ ELSE
+ WRITE(OUTNUM, 8000 ) TESTNUM, TESTNUM-NSKIP-NFAIL,
+ $ NSKIP, NFAIL
+ END IF
+ END IF
+*
+* Log whether their were any failures
+*
+ TESTOK = ALLPASS( (NFAIL.EQ.0) )
+*
+ 1000 FORMAT('DOUBLE PRECISION SUM TESTS: BEGIN.' )
+ 2000 FORMAT(1X,A7,3X,10I6)
+ 3000 FORMAT(1X,A7,3X,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1,
+ $ 5X,A1,5X,A1)
+ 4000 FORMAT(' TEST# STATUS SCOPE TOP M N LDAS LDAD ',
+ $ 'RDEST CDEST P Q')
+ 5000 FORMAT(' ----- ------- ----- --- ----- ----- ----- ----- ',
+ $ '----- ----- ---- ----')
+ 6000 FORMAT(I6,1X,A7,5X,A1,3X,A1,6I6,2I5)
+ 7000 FORMAT('DOUBLE PRECISION SUM TESTS: PASSED ALL',
+ $ I5, ' TESTS.')
+ 8000 FORMAT('DOUBLE PRECISION SUM TESTS:',I5,' TESTS;',I5,' PASSED,',
+ $ I5,' SKIPPED,',I5,' FAILED.')
+*
+ RETURN
+*
+* End of DTESTSUM.
+*
+ END
+*
+ DOUBLE PRECISION FUNCTION DBTABS(VAL)
+ DOUBLE PRECISION VAL
+ DBTABS = ABS(VAL)
+ RETURN
+ END
+*
+ DOUBLE PRECISION FUNCTION DBTEPS()
+*
+* .. External Functions ..
+ INTEGER IBTMYPROC, IBTNPROCS, IBTMSGID
+ DOUBLE PRECISION DLAMCH
+ EXTERNAL IBTMYPROC, IBTNPROCS, IBTMSGID, DLAMCH
+* ..
+* .. Local Scalars ..
+ INTEGER I, IAM, NNODES
+ DOUBLE PRECISION EPS, EPS2
+ SAVE EPS
+ DATA EPS /-22.0D0/
+* ..
+* .. Executable Statements ..
+*
+* First time called, must get max epsilon possessed by any
+* participating process
+*
+ IF( EPS .EQ. -22.0D0 ) THEN
+ IAM = IBTMYPROC()
+ NNODES = IBTNPROCS()
+ EPS = DLAMCH('epsilon')
+ IF( IAM .EQ. 0 ) THEN
+ IF( NNODES .GT. 1 ) THEN
+ DO 10 I = 1, NNODES-1
+ CALL BTRECV( 6, 1, EPS2, I, IBTMSGID()+20 )
+ IF( EPS .LT. EPS2 ) EPS = EPS2
+ 10 CONTINUE
+ END IF
+ CALL BTSEND( 6, 1, EPS, -1, IBTMSGID()+20 )
+ ELSE
+ CALL BTSEND( 6, 1, EPS, 0, IBTMSGID()+20 )
+ CALL BTRECV( 6, 1, EPS, 0, IBTMSGID()+20 )
+ ENDIF
+ END IF
+ DBTEPS = EPS
+ RETURN
+*
+* End DBTEPS
+*
+ END
+*
+ SUBROUTINE DCHKSUM( SCOPE, ICTXT, M, N, A, LDA, TESTNUM, MAXERR,
+ $ NERR, ERRIBUF, ERRDBUF, ISEED )
+*
+* .. Scalar Arguments ..
+ CHARACTER*1 SCOPE
+ INTEGER ICTXT, M, N, LDA, TESTNUM, MAXERR, NERR
+* ..
+* .. Array Arguments ..
+ INTEGER ERRIBUF(6, MAXERR), ISEED(*)
+ DOUBLE PRECISION A(LDA,*), ERRDBUF(2, MAXERR)
+* ..
+* .. External Functions ..
+ INTEGER IBTMYPROC, IBTNPROCS
+ DOUBLE PRECISION DBTEPS
+ DOUBLE PRECISION DBTRAN
+ EXTERNAL IBTMYPROC, IBTNPROCS, DBTEPS, DBTRAN
+* ..
+* .. Local Scalars ..
+ INTEGER NPROCS, NPROW, NPCOL, MYROW, MYCOL, NODE, NNODES, DEST
+ INTEGER I, J, K
+ DOUBLE PRECISION ANS, EPS, ERRBND, POSNUM, NEGNUM, TMP
+* ..
+* .. Executable Statements ..
+*
+ NPROCS = IBTNPROCS()
+ EPS = DBTEPS()
+ CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL )
+ DEST = MYROW*NPROCS + MYCOL
+*
+* Set up seeds to match those used by each proc's genmat call
+*
+ IF( SCOPE .EQ. 'R' ) THEN
+ NNODES = NPCOL
+ DO 10 I = 0, NNODES-1
+ NODE = MYROW * NPROCS + I
+ ISEED(I*4+1) = MOD( 1002 + TESTNUM*5 + NODE*3, 4096 )
+ ISEED(I*4+2) = MOD( 2027 + TESTNUM*7 + NODE, 4096 )
+ ISEED(I*4+3) = MOD( 1234 + TESTNUM + NODE*3, 4096 )
+ ISEED(I*4+4) = MOD( 4311 + TESTNUM*10 + NODE*2, 4096 )
+ 10 CONTINUE
+ ELSE IF( SCOPE .EQ. 'C' ) THEN
+ NNODES = NPROW
+ DO 20 I = 0, NNODES-1
+ NODE = I * NPROCS + MYCOL
+ ISEED(I*4+1) = MOD( 1002 + TESTNUM*5 + NODE*3, 4096 )
+ ISEED(I*4+2) = MOD( 2027 + TESTNUM*7 + NODE, 4096 )
+ ISEED(I*4+3) = MOD( 1234 + TESTNUM + NODE*3, 4096 )
+ ISEED(I*4+4) = MOD( 4311 + TESTNUM*10 + NODE*2, 4096 )
+ 20 CONTINUE
+ ELSE
+ NNODES = NPROW * NPCOL
+ DO 30 I = 0, NNODES-1
+ NODE = (I / NPCOL) * NPROCS + MOD(I, NPCOL)
+ ISEED(I*4+1) = MOD( 1002 + TESTNUM*5 + NODE*3, 4096 )
+ ISEED(I*4+2) = MOD( 2027 + TESTNUM*7 + NODE, 4096 )
+ ISEED(I*4+3) = MOD( 1234 + TESTNUM + NODE*3, 4096 )
+ ISEED(I*4+4) = MOD( 4311 + TESTNUM*10 + NODE*2, 4096 )
+ 30 CONTINUE
+ END IF
+*
+ DO 100 J = 1, N
+ DO 90 I = 1, M
+ ANS = 0
+ POSNUM = 0
+ NEGNUM = 0
+ DO 40 K = 0, NNODES-1
+ TMP = DBTRAN( ISEED(K*4+1) )
+ IF( TMP .LT. 0 ) THEN
+ NEGNUM = NEGNUM + TMP
+ ELSE
+ POSNUM = POSNUM + TMP
+ END IF
+ ANS = ANS + TMP
+ 40 CONTINUE
+*
+* The error bound is figured by
+* 2 * eps * (nnodes-1) * max(|max element|, |ans|).
+* The 2 allows for errors in the distributed _AND_ local result.
+* The eps is machine epsilon. The number of floating point adds
+* is (nnodes - 1). We use the fact that 0.5 is the maximum element
+* in order to save ourselves some computation.
+*
+ ERRBND = 2 * EPS * NNODES * MAX( POSNUM, -NEGNUM )
+ IF( ABS( ANS - A(I,J) ) .GT. ERRBND ) THEN
+ NERR = NERR + 1
+ IF( NERR .LE. MAXERR ) THEN
+ ERRIBUF(1, NERR) = TESTNUM
+ ERRIBUF(2, NERR) = NNODES
+ ERRIBUF(3, NERR) = DEST
+ ERRIBUF(4, NERR) = I
+ ERRIBUF(5, NERR) = J
+ ERRIBUF(6, NERR) = 5
+ ERRDBUF(1, NERR) = A(I,J)
+ ERRDBUF(2, NERR) = ANS
+ END IF
+ END IF
+ 90 CONTINUE
+ 100 CONTINUE
+*
+ RETURN
+*
+* End of DCHKSUM
+*
+ END
+*
+*
+ SUBROUTINE CSUMTEST( OUTNUM, VERB, TOPSREPEAT, TOPSCOHRNT, NSCOPE,
+ $ SCOPE0, NTOP, TOP0, NMAT, M0, N0, LDAS0,
+ $ LDAD0, NDEST, RDEST0, CDEST0, NGRID,
+ $ CONTEXT0, P0, Q0, ISEED, MEM, MEMLEN )
+*
+* -- BLACS tester (version 1.0) --
+* University of Tennessee
+* December 15, 1994
+*
+*
+* .. Scalar Arguments ..
+ INTEGER MEMLEN, NDEST, NGRID, NMAT, NSCOPE, NTOP, OUTNUM,
+ $ TOPSCOHRNT, TOPSREPEAT, VERB
+* ..
+* .. Array Arguments ..
+ CHARACTER*1 SCOPE0(NSCOPE), TOP0(NTOP)
+ INTEGER M0(NMAT), N0(NMAT), LDAS0(NMAT), LDAD0(NMAT)
+ INTEGER RDEST0(NDEST), CDEST0(NDEST), CONTEXT0(NGRID)
+ INTEGER P0(NGRID), Q0(NGRID), ISEED(*)
+ COMPLEX MEM(MEMLEN)
+* ..
+*
+* Purpose
+* =======
+* CTESTSUM: Test complex SUM COMBINE
+*
+* Arguments
+* =========
+* OUTNUM (input) INTEGER
+* The device number to write output to.
+*
+* VERB (input) INTEGER
+* The level of verbosity (how much printing to do).
+*
+* NSCOPE (input) INTEGER
+* The number of scopes to be tested.
+*
+* SCOPE0 (input) CHARACTER*1 array of dimension (NSCOPE)
+* Values of the scopes to be tested.
+*
+* NTOP (input) INTEGER
+* The number of topologies to be tested.
+*
+* TOP0 (input) CHARACTER*1 array of dimension (NTOP)
+* Values of the topologies to be tested.
+*
+* NMAT (input) INTEGER
+* The number of matrices to be tested.
+*
+* M0 (input) INTEGER array of dimension (NMAT)
+* Values of M to be tested.
+*
+* M0 (input) INTEGER array of dimension (NMAT)
+* Values of M to be tested.
+*
+* N0 (input) INTEGER array of dimension (NMAT)
+* Values of N to be tested.
+*
+* LDAS0 (input) INTEGER array of dimension (NMAT)
+* Values of LDAS (leading dimension of A on source process)
+* to be tested.
+*
+* LDAD0 (input) INTEGER array of dimension (NMAT)
+* Values of LDAD (leading dimension of A on destination
+* process) to be tested.
+* NDEST (input) INTEGER
+* The number of destinations to be tested.
+*
+* RDEST0 (input) INTEGER array of dimension (NNDEST)
+* Values of RDEST (row coordinate of destination) to be
+* tested.
+*
+* CDEST0 (input) INTEGER array of dimension (NNDEST)
+* Values of CDEST (column coordinate of destination) to be
+* tested.
+*
+* NGRID (input) INTEGER
+* The number of process grids to be tested.
+*
+* CONTEXT0 (input) INTEGER array of dimension (NGRID)
+* The BLACS context handles corresponding to the grids.
+*
+* P0 (input) INTEGER array of dimension (NGRID)
+* Values of P (number of process rows, NPROW).
+*
+* Q0 (input) INTEGER array of dimension (NGRID)
+* Values of Q (number of process columns, NPCOL).
+*
+* ISEED (workspace) INTEGER array of dimension ( MAX(NPROCS, NTESTS) )
+* Workspace used to hold each process's random number SEED.
+* This requires NPROCS (number of processor) elements.
+* If VERB < 2, this workspace also serves to indicate which
+* tests fail. This requires workspace of NTESTS
+* (number of tests performed).
+*
+* MEM (workspace) COMPLEX array of dimension (MEMLEN)
+* Used for all other workspaces, including the matrix A,
+* and its pre and post padding.
+*
+* MEMLEN (input) INTEGER
+* The length, in elements, of MEM.
+*
+* =====================================================================
+*
+* .. External Functions ..
+ LOGICAL ALLPASS, LSAME
+ INTEGER IBTMYPROC, IBTNPROCS, IBTSIZEOF
+ EXTERNAL ALLPASS, LSAME, IBTMYPROC, IBTNPROCS, IBTSIZEOF
+* ..
+* .. External Subroutines ..
+ EXTERNAL BLACS_GRIDINFO, CGSUM2D
+ EXTERNAL CINITMAT, CCHKPAD, CBTCHECKIN
+* ..
+* .. Local Scalars ..
+ CHARACTER*1 SCOPE, TOP
+ LOGICAL INGRID, TESTOK, ALLRCV
+ INTEGER APTR, CDEST, CDEST2, CONTEXT, CSIZE, ERRDPTR, ERRIPTR, I,
+ $ IAM, IDE, IGR, IMA, IPAD, IPOST, IPRE, ISC, ISIZE, ISTART,
+ $ ISTOP, ITC, ITC1, ITC2, ITO, ITR, ITR1, ITR2, J, K, LDA,
+ $ LDADST, LDASRC, M, MAXERR, MYCOL, MYROW, N, NERR, NFAIL,
+ $ NPCOL, NPROW, NSKIP, PREAPTR, RDEST, RDEST2, SETWHAT,
+ $ TESTNUM
+ COMPLEX CHECKVAL
+* ..
+* .. Executable Statements ..
+*
+* Choose padding value, and make it unique
+*
+ CHECKVAL = CMPLX( -0.91E0, -0.71E0 )
+ IAM = IBTMYPROC()
+ CHECKVAL = IAM * CHECKVAL
+ ISIZE = IBTSIZEOF('I')
+ CSIZE = IBTSIZEOF('C')
+*
+* Verify file parameters
+*
+ IF( IAM .EQ. 0 ) THEN
+ WRITE(OUTNUM, *) ' '
+ WRITE(OUTNUM, *) ' '
+ WRITE(OUTNUM, 1000 )
+ IF( VERB .GT. 0 ) THEN
+ WRITE(OUTNUM,*) ' '
+ WRITE(OUTNUM, 2000) 'NSCOPE:', NSCOPE
+ WRITE(OUTNUM, 3000) ' SCOPE:', ( SCOPE0(I), I = 1, NSCOPE )
+ WRITE(OUTNUM, 2000) 'TReps :', TOPSREPEAT
+ WRITE(OUTNUM, 2000) 'TCohr :', TOPSCOHRNT
+ WRITE(OUTNUM, 2000) 'NTOP :', NTOP
+ WRITE(OUTNUM, 3000) ' TOP :', ( TOP0(I), I = 1, NTOP )
+ WRITE(OUTNUM, 2000) 'NMAT :', NMAT
+ WRITE(OUTNUM, 2000) ' M :', ( M0(I), I = 1, NMAT )
+ WRITE(OUTNUM, 2000) ' N :', ( N0(I), I = 1, NMAT )
+ WRITE(OUTNUM, 2000) ' LDAS :', ( LDAS0(I), I = 1, NMAT )
+ WRITE(OUTNUM, 2000) ' LDAD :', ( LDAD0(I), I = 1, NMAT )
+ WRITE(OUTNUM, 2000) 'NDEST :', NDEST
+ WRITE(OUTNUM, 2000) ' RDEST:',( RDEST0(I), I = 1, NDEST )
+ WRITE(OUTNUM, 2000) ' CDEST:',( CDEST0(I), I = 1, NDEST )
+ WRITE(OUTNUM, 2000) 'NGRIDS:', NGRID
+ WRITE(OUTNUM, 2000) ' P :', ( P0(I), I = 1, NGRID )
+ WRITE(OUTNUM, 2000) ' Q :', ( Q0(I), I = 1, NGRID )
+ WRITE(OUTNUM, 2000) 'VERB :', VERB
+ WRITE(OUTNUM,*) ' '
+ END IF
+ IF( VERB .GT. 1 ) THEN
+ WRITE(OUTNUM,4000)
+ WRITE(OUTNUM,5000)
+ END IF
+ END IF
+ IF (TOPSREPEAT.EQ.0) THEN
+ ITR1 = 0
+ ITR2 = 0
+ ELSE IF (TOPSREPEAT.EQ.1) THEN
+ ITR1 = 1
+ ITR2 = 1
+ ELSE
+ ITR1 = 0
+ ITR2 = 1
+ END IF
+*
+* Find biggest matrix, so we know where to stick error info
+*
+ I = 0
+ DO 10 IMA = 1, NMAT
+ IPAD = 4 * M0(IMA)
+ K = N0(IMA) * MAX0( LDAS0(IMA), LDAD0(IMA) ) + IPAD
+ IF( K .GT. I ) I = K
+ 10 CONTINUE
+ MAXERR = ( CSIZE * (MEMLEN-I) ) / ( CSIZE*2 + ISIZE*6 )
+ IF( MAXERR .LT. 1 ) THEN
+ WRITE(OUTNUM,*) 'ERROR: Not enough memory to run SUM tests.'
+ CALL BLACS_ABORT(-1, 1)
+ END IF
+ ERRDPTR = I + 1
+ ERRIPTR = ERRDPTR + MAXERR
+ NERR = 0
+ TESTNUM = 0
+ NFAIL = 0
+ NSKIP = 0
+*
+* Loop over grids of matrix
+*
+ DO 90 IGR = 1, NGRID
+*
+* allocate process grid for the next batch of tests
+*
+ CONTEXT = CONTEXT0(IGR)
+ CALL BLACS_GRIDINFO( CONTEXT, NPROW, NPCOL, MYROW, MYCOL )
+ INGRID = ( (MYROW.LT.NPROW) .AND. (MYCOL.LT.NPCOL) )
+*
+ DO 80 ISC = 1, NSCOPE
+ SCOPE = SCOPE0(ISC)
+ DO 70 ITO = 1, NTOP
+ TOP = TOP0(ITO)
+*
+* If testing multiring ('M') or general tree ('T'), need to
+* loop over calls to BLACS_SET to do full test
+*
+ IF( LSAME(TOP, 'M') ) THEN
+ SETWHAT = 13
+ IF( SCOPE .EQ. 'R' ) THEN
+ ISTART = -(NPCOL - 1)
+ ISTOP = -ISTART
+ ELSE IF (SCOPE .EQ. 'C') THEN
+ ISTART = -(NPROW - 1)
+ ISTOP = -ISTART
+ ELSE
+ ISTART = -(NPROW*NPCOL - 1)
+ ISTOP = -ISTART
+ ENDIF
+ ELSE IF( LSAME(TOP, 'T') ) THEN
+ SETWHAT = 14
+ ISTART = 1
+ IF( SCOPE .EQ. 'R' ) THEN
+ ISTOP = NPCOL - 1
+ ELSE IF (SCOPE .EQ. 'C') THEN
+ ISTOP = NPROW - 1
+ ELSE
+ ISTOP = NPROW*NPCOL - 1
+ ENDIF
+ ELSE
+ SETWHAT = 0
+ ISTART = 1
+ ISTOP = 1
+ ENDIF
+ DO 60 IMA = 1, NMAT
+ M = M0(IMA)
+ N = N0(IMA)
+ LDASRC = LDAS0(IMA)
+ LDADST = LDAD0(IMA)
+ IPRE = 2 * M
+ IPOST = IPRE
+ PREAPTR = 1
+ APTR = PREAPTR + IPRE
+*
+ DO 50 IDE = 1, NDEST
+ TESTNUM = TESTNUM + 1
+ RDEST2 = RDEST0(IDE)
+ CDEST2 = CDEST0(IDE)
+*
+* If everyone gets the answer, create some bogus rdest/cdest
+* so IF's are easier
+*
+ ALLRCV = ( (RDEST2.EQ.-1) .OR. (CDEST2.EQ.-1) )
+ IF( ALLRCV ) THEN
+ RDEST = NPROW - 1
+ CDEST = NPCOL - 1
+ IF (TOPSCOHRNT.EQ.0) THEN
+ ITR1 = 0
+ ITR2 = 0
+ ELSE IF (TOPSCOHRNT.EQ.1) THEN
+ ITR1 = 1
+ ITR2 = 1
+ ELSE
+ ITR1 = 0
+ ITR2 = 1
+ END IF
+ ELSE
+ RDEST = RDEST2
+ CDEST = CDEST2
+ ITC1 = 0
+ ITC2 = 0
+ END IF
+ IF( RDEST.GE.P0(IGR) .OR. CDEST.GE.Q0(IGR) ) THEN
+ NSKIP = NSKIP + 1
+ GOTO 50
+ END IF
+*
+ IF( MYROW.EQ.RDEST .AND. MYCOL.EQ.CDEST ) THEN
+ LDA = LDADST
+ ELSE
+ LDA = LDASRC
+ END IF
+ IF( VERB .GT. 1 ) THEN
+ IF( IAM .EQ. 0 ) THEN
+ WRITE(OUTNUM, 6000)
+ $ TESTNUM, 'RUNNING', SCOPE, TOP, M, N,
+ $ LDASRC, LDADST, RDEST2, CDEST2,
+ $ NPROW, NPCOL
+ END IF
+ END IF
+*
+* If I am in scope
+*
+ TESTOK = .TRUE.
+ IF( INGRID ) THEN
+ IF( (MYROW.EQ.RDEST .AND. SCOPE.EQ.'R') .OR.
+ $ (MYCOL.EQ.CDEST .AND. SCOPE.EQ.'C') .OR.
+ $ (SCOPE .EQ. 'A') ) THEN
+*
+ K = NERR
+ DO 40 ITR = ITR1, ITR2
+ CALL BLACS_SET(CONTEXT, 15, ITR)
+ DO 35 ITC = ITC1, ITC2
+ CALL BLACS_SET(CONTEXT, 16, ITC)
+ DO 30 J = ISTART, ISTOP
+ IF( J.EQ.0) GOTO 30
+ IF( SETWHAT.NE.0 )
+ $ CALL BLACS_SET(CONTEXT, SETWHAT, J)
+*
+*
+* generate and pad matrix A
+*
+ CALL CINITMAT('G','-', M, N, MEM(PREAPTR),
+ $ LDA, IPRE, IPOST,
+ $ CHECKVAL, TESTNUM,
+ $ MYROW, MYCOL )
+*
+ CALL CGSUM2D(CONTEXT, SCOPE, TOP, M, N,
+ $ MEM(APTR), LDA, RDEST2,
+ $ CDEST2)
+*
+* If I've got the answer, check for errors in
+* matrix or padding
+*
+ IF( (MYROW.EQ.RDEST .AND. MYCOL.EQ.CDEST)
+ $ .OR. ALLRCV ) THEN
+ CALL CCHKPAD('G','-', M, N,
+ $ MEM(PREAPTR), LDA, RDEST,
+ $ CDEST, MYROW, MYCOL,
+ $ IPRE, IPOST, CHECKVAL,
+ $ TESTNUM, MAXERR, NERR,
+ $ MEM(ERRIPTR),MEM(ERRDPTR))
+ CALL CCHKSUM(SCOPE, CONTEXT, M, N,
+ $ MEM(APTR), LDA,
+ $ TESTNUM, MAXERR, NERR,
+ $ MEM(ERRIPTR),MEM(ERRDPTR),
+ $ ISEED)
+ END IF
+ 30 CONTINUE
+ CALL BLACS_SET(CONTEXT, 16, 0)
+ 35 CONTINUE
+ CALL BLACS_SET(CONTEXT, 15, 0)
+ 40 CONTINUE
+ TESTOK = ( K .EQ. NERR )
+ END IF
+ END IF
+*
+ IF( VERB .GT. 1 ) THEN
+ I = NERR
+ CALL CBTCHECKIN(0, OUTNUM, MAXERR, NERR,
+ $ MEM(ERRIPTR), MEM(ERRDPTR), ISEED)
+ IF( IAM .EQ. 0 ) THEN
+ IF( TESTOK .AND. NERR.EQ.I ) THEN
+ WRITE(OUTNUM,6000)TESTNUM,'PASSED ',
+ $ SCOPE, TOP, M, N, LDASRC,
+ $ LDADST, RDEST2, CDEST2,
+ $ NPROW, NPCOL
+ ELSE
+ NFAIL = NFAIL + 1
+ WRITE(OUTNUM,6000)TESTNUM,'FAILED ',
+ $ SCOPE, TOP, M, N, LDASRC,
+ $ LDADST, RDEST2, CDEST2,
+ $ NPROW, NPCOL
+ END IF
+ END IF
+*
+* Once we've printed out errors, can re-use buf space
+*
+ NERR = 0
+ END IF
+ 50 CONTINUE
+ 60 CONTINUE
+ 70 CONTINUE
+ 80 CONTINUE
+ 90 CONTINUE
+*
+ IF( VERB .LT. 2 ) THEN
+ NFAIL = TESTNUM
+ CALL CBTCHECKIN( NFAIL, OUTNUM, MAXERR, NERR, MEM(ERRIPTR),
+ $ MEM(ERRDPTR), ISEED )
+ END IF
+ IF( IAM .EQ. 0 ) THEN
+ IF( VERB .GT. 1 ) WRITE(OUTNUM,*) ' '
+ IF( NFAIL+NSKIP .EQ. 0 ) THEN
+ WRITE(OUTNUM, 7000 ) TESTNUM
+ ELSE
+ WRITE(OUTNUM, 8000 ) TESTNUM, TESTNUM-NSKIP-NFAIL,
+ $ NSKIP, NFAIL
+ END IF
+ END IF
+*
+* Log whether their were any failures
+*
+ TESTOK = ALLPASS( (NFAIL.EQ.0) )
+*
+ 1000 FORMAT('COMPLEX SUM TESTS: BEGIN.' )
+ 2000 FORMAT(1X,A7,3X,10I6)
+ 3000 FORMAT(1X,A7,3X,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1,
+ $ 5X,A1,5X,A1)
+ 4000 FORMAT(' TEST# STATUS SCOPE TOP M N LDAS LDAD ',
+ $ 'RDEST CDEST P Q')
+ 5000 FORMAT(' ----- ------- ----- --- ----- ----- ----- ----- ',
+ $ '----- ----- ---- ----')
+ 6000 FORMAT(I6,1X,A7,5X,A1,3X,A1,6I6,2I5)
+ 7000 FORMAT('COMPLEX SUM TESTS: PASSED ALL',
+ $ I5, ' TESTS.')
+ 8000 FORMAT('COMPLEX SUM TESTS:',I5,' TESTS;',I5,' PASSED,',
+ $ I5,' SKIPPED,',I5,' FAILED.')
+*
+ RETURN
+*
+* End of CTESTSUM.
+*
+ END
+*
+ REAL FUNCTION CBTABS(VAL)
+ COMPLEX VAL
+ CBTABS = ABS( REAL(VAL) ) + ABS( AIMAG(VAL) )
+ RETURN
+ END
+*
+ SUBROUTINE CCHKSUM( SCOPE, ICTXT, M, N, A, LDA, TESTNUM, MAXERR,
+ $ NERR, ERRIBUF, ERRDBUF, ISEED )
+*
+* .. Scalar Arguments ..
+ CHARACTER*1 SCOPE
+ INTEGER ICTXT, M, N, LDA, TESTNUM, MAXERR, NERR
+* ..
+* .. Array Arguments ..
+ INTEGER ERRIBUF(6, MAXERR), ISEED(*)
+ COMPLEX A(LDA,*), ERRDBUF(2, MAXERR)
+* ..
+* .. External Functions ..
+ INTEGER IBTMYPROC, IBTNPROCS
+ REAL SBTEPS
+ COMPLEX CBTRAN
+ EXTERNAL IBTMYPROC, IBTNPROCS, SBTEPS, CBTRAN
+* ..
+* .. Local Scalars ..
+ LOGICAL NUMOK
+ INTEGER NPROCS, NPROW, NPCOL, MYROW, MYCOL, NODE, NNODES, DEST
+ INTEGER I, J, K
+ COMPLEX ANS, TMP
+ REAL EPS, ERRBND, RPOSNUM, RNEGNUM, IPOSNUM, INEGNUM
+* ..
+* .. Executable Statements ..
+*
+ NPROCS = IBTNPROCS()
+ EPS = SBTEPS()
+ CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL )
+ DEST = MYROW*NPROCS + MYCOL
+*
+* Set up seeds to match those used by each proc's genmat call
+*
+ IF( SCOPE .EQ. 'R' ) THEN
+ NNODES = NPCOL
+ DO 10 I = 0, NNODES-1
+ NODE = MYROW * NPROCS + I
+ ISEED(I*4+1) = MOD( 1002 + TESTNUM*5 + NODE*3, 4096 )
+ ISEED(I*4+2) = MOD( 2027 + TESTNUM*7 + NODE, 4096 )
+ ISEED(I*4+3) = MOD( 1234 + TESTNUM + NODE*3, 4096 )
+ ISEED(I*4+4) = MOD( 4311 + TESTNUM*10 + NODE*2, 4096 )
+ 10 CONTINUE
+ ELSE IF( SCOPE .EQ. 'C' ) THEN
+ NNODES = NPROW
+ DO 20 I = 0, NNODES-1
+ NODE = I * NPROCS + MYCOL
+ ISEED(I*4+1) = MOD( 1002 + TESTNUM*5 + NODE*3, 4096 )
+ ISEED(I*4+2) = MOD( 2027 + TESTNUM*7 + NODE, 4096 )
+ ISEED(I*4+3) = MOD( 1234 + TESTNUM + NODE*3, 4096 )
+ ISEED(I*4+4) = MOD( 4311 + TESTNUM*10 + NODE*2, 4096 )
+ 20 CONTINUE
+ ELSE
+ NNODES = NPROW * NPCOL
+ DO 30 I = 0, NNODES-1
+ NODE = (I / NPCOL) * NPROCS + MOD(I, NPCOL)
+ ISEED(I*4+1) = MOD( 1002 + TESTNUM*5 + NODE*3, 4096 )
+ ISEED(I*4+2) = MOD( 2027 + TESTNUM*7 + NODE, 4096 )
+ ISEED(I*4+3) = MOD( 1234 + TESTNUM + NODE*3, 4096 )
+ ISEED(I*4+4) = MOD( 4311 + TESTNUM*10 + NODE*2, 4096 )
+ 30 CONTINUE
+ END IF
+*
+ DO 100 J = 1, N
+ DO 90 I = 1, M
+ ANS = 0
+ RPOSNUM = 0
+ RNEGNUM = 0
+ IPOSNUM = 0
+ INEGNUM = 0
+ DO 40 K = 0, NNODES-1
+ TMP = CBTRAN( ISEED(K*4+1) )
+ IF( REAL( TMP ) .LT. 0 ) THEN
+ RNEGNUM = RNEGNUM + REAL( TMP )
+ ELSE
+ RPOSNUM = RPOSNUM + REAL( TMP )
+ END IF
+ IF( AIMAG( TMP ) .LT. 0 ) THEN
+ INEGNUM = INEGNUM + AIMAG( TMP )
+ ELSE
+ IPOSNUM = IPOSNUM + AIMAG( TMP )
+ END IF
+ ANS = ANS + TMP
+ 40 CONTINUE
+*
+* The error bound is figured by
+* 2 * eps * (nnodes-1) * max(|max element|, |ans|).
+* The 2 allows for errors in the distributed _AND_ local result.
+* The eps is machine epsilon. The number of floating point adds
+* is (nnodes - 1). We use the fact that 0.5 is the maximum element
+* in order to save ourselves some computation.
+*
+ TMP = ANS - A(I,J)
+ ERRBND = 2 * EPS * NNODES * MAX( RPOSNUM, -RNEGNUM )
+ NUMOK = ( REAL(TMP) .LE. ERRBND )
+ ERRBND = 2 * EPS * NNODES * MAX( IPOSNUM, -INEGNUM )
+ NUMOK = NUMOK .AND. ( AIMAG(TMP) .LE. ERRBND )
+ IF( .NOT.NUMOK ) THEN
+ NERR = NERR + 1
+ IF( NERR .LE. MAXERR ) THEN
+ ERRIBUF(1, NERR) = TESTNUM
+ ERRIBUF(2, NERR) = NNODES
+ ERRIBUF(3, NERR) = DEST
+ ERRIBUF(4, NERR) = I
+ ERRIBUF(5, NERR) = J
+ ERRIBUF(6, NERR) = 5
+ ERRDBUF(1, NERR) = A(I,J)
+ ERRDBUF(2, NERR) = ANS
+ END IF
+ END IF
+ 90 CONTINUE
+ 100 CONTINUE
+*
+ RETURN
+*
+* End of CCHKSUM
+*
+ END
+*
+*
+ SUBROUTINE ZSUMTEST( OUTNUM, VERB, TOPSREPEAT, TOPSCOHRNT, NSCOPE,
+ $ SCOPE0, NTOP, TOP0, NMAT, M0, N0, LDAS0,
+ $ LDAD0, NDEST, RDEST0, CDEST0, NGRID,
+ $ CONTEXT0, P0, Q0, ISEED, MEM, MEMLEN )
+*
+* -- BLACS tester (version 1.0) --
+* University of Tennessee
+* December 15, 1994
+*
+*
+* .. Scalar Arguments ..
+ INTEGER MEMLEN, NDEST, NGRID, NMAT, NSCOPE, NTOP, OUTNUM,
+ $ TOPSCOHRNT, TOPSREPEAT, VERB
+* ..
+* .. Array Arguments ..
+ CHARACTER*1 SCOPE0(NSCOPE), TOP0(NTOP)
+ INTEGER M0(NMAT), N0(NMAT), LDAS0(NMAT), LDAD0(NMAT)
+ INTEGER RDEST0(NDEST), CDEST0(NDEST), CONTEXT0(NGRID)
+ INTEGER P0(NGRID), Q0(NGRID), ISEED(*)
+ DOUBLE COMPLEX MEM(MEMLEN)
+* ..
+*
+* Purpose
+* =======
+* ZTESTSUM: Test double complex SUM COMBINE
+*
+* Arguments
+* =========
+* OUTNUM (input) INTEGER
+* The device number to write output to.
+*
+* VERB (input) INTEGER
+* The level of verbosity (how much printing to do).
+*
+* NSCOPE (input) INTEGER
+* The number of scopes to be tested.
+*
+* SCOPE0 (input) CHARACTER*1 array of dimension (NSCOPE)
+* Values of the scopes to be tested.
+*
+* NTOP (input) INTEGER
+* The number of topologies to be tested.
+*
+* TOP0 (input) CHARACTER*1 array of dimension (NTOP)
+* Values of the topologies to be tested.
+*
+* NMAT (input) INTEGER
+* The number of matrices to be tested.
+*
+* M0 (input) INTEGER array of dimension (NMAT)
+* Values of M to be tested.
+*
+* M0 (input) INTEGER array of dimension (NMAT)
+* Values of M to be tested.
+*
+* N0 (input) INTEGER array of dimension (NMAT)
+* Values of N to be tested.
+*
+* LDAS0 (input) INTEGER array of dimension (NMAT)
+* Values of LDAS (leading dimension of A on source process)
+* to be tested.
+*
+* LDAD0 (input) INTEGER array of dimension (NMAT)
+* Values of LDAD (leading dimension of A on destination
+* process) to be tested.
+* NDEST (input) INTEGER
+* The number of destinations to be tested.
+*
+* RDEST0 (input) INTEGER array of dimension (NNDEST)
+* Values of RDEST (row coordinate of destination) to be
+* tested.
+*
+* CDEST0 (input) INTEGER array of dimension (NNDEST)
+* Values of CDEST (column coordinate of destination) to be
+* tested.
+*
+* NGRID (input) INTEGER
+* The number of process grids to be tested.
+*
+* CONTEXT0 (input) INTEGER array of dimension (NGRID)
+* The BLACS context handles corresponding to the grids.
+*
+* P0 (input) INTEGER array of dimension (NGRID)
+* Values of P (number of process rows, NPROW).
+*
+* Q0 (input) INTEGER array of dimension (NGRID)
+* Values of Q (number of process columns, NPCOL).
+*
+* ISEED (workspace) INTEGER array of dimension ( MAX(NPROCS, NTESTS) )
+* Workspace used to hold each process's random number SEED.
+* This requires NPROCS (number of processor) elements.
+* If VERB < 2, this workspace also serves to indicate which
+* tests fail. This requires workspace of NTESTS
+* (number of tests performed).
+*
+* MEM (workspace) DOUBLE COMPLEX array of dimension (MEMLEN)
+* Used for all other workspaces, including the matrix A,
+* and its pre and post padding.
+*
+* MEMLEN (input) INTEGER
+* The length, in elements, of MEM.
+*
+* =====================================================================
+*
+* .. External Functions ..
+ LOGICAL ALLPASS, LSAME
+ INTEGER IBTMYPROC, IBTNPROCS, IBTSIZEOF
+ EXTERNAL ALLPASS, LSAME, IBTMYPROC, IBTNPROCS, IBTSIZEOF
+* ..
+* .. External Subroutines ..
+ EXTERNAL BLACS_GRIDINFO, ZGSUM2D
+ EXTERNAL ZINITMAT, ZCHKPAD, ZBTCHECKIN
+* ..
+* .. Local Scalars ..
+ CHARACTER*1 SCOPE, TOP
+ LOGICAL INGRID, TESTOK, ALLRCV
+ INTEGER APTR, CDEST, CDEST2, CONTEXT, ERRDPTR, ERRIPTR, I, IAM,
+ $ IDE, IGR, IMA, IPAD, IPOST, IPRE, ISC, ISIZE, ISTART,
+ $ ISTOP, ITC, ITC1, ITC2, ITO, ITR, ITR1, ITR2, J, K, LDA,
+ $ LDADST, LDASRC, M, MAXERR, MYCOL, MYROW, N, NERR, NFAIL,
+ $ NPCOL, NPROW, NSKIP, PREAPTR, RDEST, RDEST2, SETWHAT,
+ $ TESTNUM, ZSIZE
+ DOUBLE COMPLEX CHECKVAL
+* ..
+* .. Executable Statements ..
+*
+* Choose padding value, and make it unique
+*
+ CHECKVAL = DCMPLX( -9.11D0, -9.21D0 )
+ IAM = IBTMYPROC()
+ CHECKVAL = IAM * CHECKVAL
+ ISIZE = IBTSIZEOF('I')
+ ZSIZE = IBTSIZEOF('Z')
+*
+* Verify file parameters
+*
+ IF( IAM .EQ. 0 ) THEN
+ WRITE(OUTNUM, *) ' '
+ WRITE(OUTNUM, *) ' '
+ WRITE(OUTNUM, 1000 )
+ IF( VERB .GT. 0 ) THEN
+ WRITE(OUTNUM,*) ' '
+ WRITE(OUTNUM, 2000) 'NSCOPE:', NSCOPE
+ WRITE(OUTNUM, 3000) ' SCOPE:', ( SCOPE0(I), I = 1, NSCOPE )
+ WRITE(OUTNUM, 2000) 'TReps :', TOPSREPEAT
+ WRITE(OUTNUM, 2000) 'TCohr :', TOPSCOHRNT
+ WRITE(OUTNUM, 2000) 'NTOP :', NTOP
+ WRITE(OUTNUM, 3000) ' TOP :', ( TOP0(I), I = 1, NTOP )
+ WRITE(OUTNUM, 2000) 'NMAT :', NMAT
+ WRITE(OUTNUM, 2000) ' M :', ( M0(I), I = 1, NMAT )
+ WRITE(OUTNUM, 2000) ' N :', ( N0(I), I = 1, NMAT )
+ WRITE(OUTNUM, 2000) ' LDAS :', ( LDAS0(I), I = 1, NMAT )
+ WRITE(OUTNUM, 2000) ' LDAD :', ( LDAD0(I), I = 1, NMAT )
+ WRITE(OUTNUM, 2000) 'NDEST :', NDEST
+ WRITE(OUTNUM, 2000) ' RDEST:',( RDEST0(I), I = 1, NDEST )
+ WRITE(OUTNUM, 2000) ' CDEST:',( CDEST0(I), I = 1, NDEST )
+ WRITE(OUTNUM, 2000) 'NGRIDS:', NGRID
+ WRITE(OUTNUM, 2000) ' P :', ( P0(I), I = 1, NGRID )
+ WRITE(OUTNUM, 2000) ' Q :', ( Q0(I), I = 1, NGRID )
+ WRITE(OUTNUM, 2000) 'VERB :', VERB
+ WRITE(OUTNUM,*) ' '
+ END IF
+ IF( VERB .GT. 1 ) THEN
+ WRITE(OUTNUM,4000)
+ WRITE(OUTNUM,5000)
+ END IF
+ END IF
+ IF (TOPSREPEAT.EQ.0) THEN
+ ITR1 = 0
+ ITR2 = 0
+ ELSE IF (TOPSREPEAT.EQ.1) THEN
+ ITR1 = 1
+ ITR2 = 1
+ ELSE
+ ITR1 = 0
+ ITR2 = 1
+ END IF
+*
+* Find biggest matrix, so we know where to stick error info
+*
+ I = 0
+ DO 10 IMA = 1, NMAT
+ IPAD = 4 * M0(IMA)
+ K = N0(IMA) * MAX0( LDAS0(IMA), LDAD0(IMA) ) + IPAD
+ IF( K .GT. I ) I = K
+ 10 CONTINUE
+ MAXERR = ( ZSIZE * (MEMLEN-I) ) / ( ZSIZE*2 + ISIZE*6 )
+ IF( MAXERR .LT. 1 ) THEN
+ WRITE(OUTNUM,*) 'ERROR: Not enough memory to run SUM tests.'
+ CALL BLACS_ABORT(-1, 1)
+ END IF
+ ERRDPTR = I + 1
+ ERRIPTR = ERRDPTR + MAXERR
+ NERR = 0
+ TESTNUM = 0
+ NFAIL = 0
+ NSKIP = 0
+*
+* Loop over grids of matrix
+*
+ DO 90 IGR = 1, NGRID
+*
+* allocate process grid for the next batch of tests
+*
+ CONTEXT = CONTEXT0(IGR)
+ CALL BLACS_GRIDINFO( CONTEXT, NPROW, NPCOL, MYROW, MYCOL )
+ INGRID = ( (MYROW.LT.NPROW) .AND. (MYCOL.LT.NPCOL) )
+*
+ DO 80 ISC = 1, NSCOPE
+ SCOPE = SCOPE0(ISC)
+ DO 70 ITO = 1, NTOP
+ TOP = TOP0(ITO)
+*
+* If testing multiring ('M') or general tree ('T'), need to
+* loop over calls to BLACS_SET to do full test
+*
+ IF( LSAME(TOP, 'M') ) THEN
+ SETWHAT = 13
+ IF( SCOPE .EQ. 'R' ) THEN
+ ISTART = -(NPCOL - 1)
+ ISTOP = -ISTART
+ ELSE IF (SCOPE .EQ. 'C') THEN
+ ISTART = -(NPROW - 1)
+ ISTOP = -ISTART
+ ELSE
+ ISTART = -(NPROW*NPCOL - 1)
+ ISTOP = -ISTART
+ ENDIF
+ ELSE IF( LSAME(TOP, 'T') ) THEN
+ SETWHAT = 14
+ ISTART = 1
+ IF( SCOPE .EQ. 'R' ) THEN
+ ISTOP = NPCOL - 1
+ ELSE IF (SCOPE .EQ. 'C') THEN
+ ISTOP = NPROW - 1
+ ELSE
+ ISTOP = NPROW*NPCOL - 1
+ ENDIF
+ ELSE
+ SETWHAT = 0
+ ISTART = 1
+ ISTOP = 1
+ ENDIF
+ DO 60 IMA = 1, NMAT
+ M = M0(IMA)
+ N = N0(IMA)
+ LDASRC = LDAS0(IMA)
+ LDADST = LDAD0(IMA)
+ IPRE = 2 * M
+ IPOST = IPRE
+ PREAPTR = 1
+ APTR = PREAPTR + IPRE
+*
+ DO 50 IDE = 1, NDEST
+ TESTNUM = TESTNUM + 1
+ RDEST2 = RDEST0(IDE)
+ CDEST2 = CDEST0(IDE)
+*
+* If everyone gets the answer, create some bogus rdest/cdest
+* so IF's are easier
+*
+ ALLRCV = ( (RDEST2.EQ.-1) .OR. (CDEST2.EQ.-1) )
+ IF( ALLRCV ) THEN
+ RDEST = NPROW - 1
+ CDEST = NPCOL - 1
+ IF (TOPSCOHRNT.EQ.0) THEN
+ ITR1 = 0
+ ITR2 = 0
+ ELSE IF (TOPSCOHRNT.EQ.1) THEN
+ ITR1 = 1
+ ITR2 = 1
+ ELSE
+ ITR1 = 0
+ ITR2 = 1
+ END IF
+ ELSE
+ RDEST = RDEST2
+ CDEST = CDEST2
+ ITC1 = 0
+ ITC2 = 0
+ END IF
+ IF( RDEST.GE.P0(IGR) .OR. CDEST.GE.Q0(IGR) ) THEN
+ NSKIP = NSKIP + 1
+ GOTO 50
+ END IF
+*
+ IF( MYROW.EQ.RDEST .AND. MYCOL.EQ.CDEST ) THEN
+ LDA = LDADST
+ ELSE
+ LDA = LDASRC
+ END IF
+ IF( VERB .GT. 1 ) THEN
+ IF( IAM .EQ. 0 ) THEN
+ WRITE(OUTNUM, 6000)
+ $ TESTNUM, 'RUNNING', SCOPE, TOP, M, N,
+ $ LDASRC, LDADST, RDEST2, CDEST2,
+ $ NPROW, NPCOL
+ END IF
+ END IF
+*
+* If I am in scope
+*
+ TESTOK = .TRUE.
+ IF( INGRID ) THEN
+ IF( (MYROW.EQ.RDEST .AND. SCOPE.EQ.'R') .OR.
+ $ (MYCOL.EQ.CDEST .AND. SCOPE.EQ.'C') .OR.
+ $ (SCOPE .EQ. 'A') ) THEN
+*
+ K = NERR
+ DO 40 ITR = ITR1, ITR2
+ CALL BLACS_SET(CONTEXT, 15, ITR)
+ DO 35 ITC = ITC1, ITC2
+ CALL BLACS_SET(CONTEXT, 16, ITC)
+ DO 30 J = ISTART, ISTOP
+ IF( J.EQ.0) GOTO 30
+ IF( SETWHAT.NE.0 )
+ $ CALL BLACS_SET(CONTEXT, SETWHAT, J)
+*
+*
+* generate and pad matrix A
+*
+ CALL ZINITMAT('G','-', M, N, MEM(PREAPTR),
+ $ LDA, IPRE, IPOST,
+ $ CHECKVAL, TESTNUM,
+ $ MYROW, MYCOL )
+*
+ CALL ZGSUM2D(CONTEXT, SCOPE, TOP, M, N,
+ $ MEM(APTR), LDA, RDEST2,
+ $ CDEST2)
+*
+* If I've got the answer, check for errors in
+* matrix or padding
+*
+ IF( (MYROW.EQ.RDEST .AND. MYCOL.EQ.CDEST)
+ $ .OR. ALLRCV ) THEN
+ CALL ZCHKPAD('G','-', M, N,
+ $ MEM(PREAPTR), LDA, RDEST,
+ $ CDEST, MYROW, MYCOL,
+ $ IPRE, IPOST, CHECKVAL,
+ $ TESTNUM, MAXERR, NERR,
+ $ MEM(ERRIPTR),MEM(ERRDPTR))
+ CALL ZCHKSUM(SCOPE, CONTEXT, M, N,
+ $ MEM(APTR), LDA,
+ $ TESTNUM, MAXERR, NERR,
+ $ MEM(ERRIPTR),MEM(ERRDPTR),
+ $ ISEED)
+ END IF
+ 30 CONTINUE
+ CALL BLACS_SET(CONTEXT, 16, 0)
+ 35 CONTINUE
+ CALL BLACS_SET(CONTEXT, 15, 0)
+ 40 CONTINUE
+ TESTOK = ( K .EQ. NERR )
+ END IF
+ END IF
+*
+ IF( VERB .GT. 1 ) THEN
+ I = NERR
+ CALL ZBTCHECKIN(0, OUTNUM, MAXERR, NERR,
+ $ MEM(ERRIPTR), MEM(ERRDPTR), ISEED)
+ IF( IAM .EQ. 0 ) THEN
+ IF( TESTOK .AND. NERR.EQ.I ) THEN
+ WRITE(OUTNUM,6000)TESTNUM,'PASSED ',
+ $ SCOPE, TOP, M, N, LDASRC,
+ $ LDADST, RDEST2, CDEST2,
+ $ NPROW, NPCOL
+ ELSE
+ NFAIL = NFAIL + 1
+ WRITE(OUTNUM,6000)TESTNUM,'FAILED ',
+ $ SCOPE, TOP, M, N, LDASRC,
+ $ LDADST, RDEST2, CDEST2,
+ $ NPROW, NPCOL
+ END IF
+ END IF
+*
+* Once we've printed out errors, can re-use buf space
+*
+ NERR = 0
+ END IF
+ 50 CONTINUE
+ 60 CONTINUE
+ 70 CONTINUE
+ 80 CONTINUE
+ 90 CONTINUE
+*
+ IF( VERB .LT. 2 ) THEN
+ NFAIL = TESTNUM
+ CALL ZBTCHECKIN( NFAIL, OUTNUM, MAXERR, NERR, MEM(ERRIPTR),
+ $ MEM(ERRDPTR), ISEED )
+ END IF
+ IF( IAM .EQ. 0 ) THEN
+ IF( VERB .GT. 1 ) WRITE(OUTNUM,*) ' '
+ IF( NFAIL+NSKIP .EQ. 0 ) THEN
+ WRITE(OUTNUM, 7000 ) TESTNUM
+ ELSE
+ WRITE(OUTNUM, 8000 ) TESTNUM, TESTNUM-NSKIP-NFAIL,
+ $ NSKIP, NFAIL
+ END IF
+ END IF
+*
+* Log whether their were any failures
+*
+ TESTOK = ALLPASS( (NFAIL.EQ.0) )
+*
+ 1000 FORMAT('DOUBLE COMPLEX SUM TESTS: BEGIN.' )
+ 2000 FORMAT(1X,A7,3X,10I6)
+ 3000 FORMAT(1X,A7,3X,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1,
+ $ 5X,A1,5X,A1)
+ 4000 FORMAT(' TEST# STATUS SCOPE TOP M N LDAS LDAD ',
+ $ 'RDEST CDEST P Q')
+ 5000 FORMAT(' ----- ------- ----- --- ----- ----- ----- ----- ',
+ $ '----- ----- ---- ----')
+ 6000 FORMAT(I6,1X,A7,5X,A1,3X,A1,6I6,2I5)
+ 7000 FORMAT('DOUBLE COMPLEX SUM TESTS: PASSED ALL',
+ $ I5, ' TESTS.')
+ 8000 FORMAT('DOUBLE COMPLEX SUM TESTS:',I5,' TESTS;',I5,' PASSED,',
+ $ I5,' SKIPPED,',I5,' FAILED.')
+*
+ RETURN
+*
+* End of ZTESTSUM.
+*
+ END
+*
+ DOUBLE PRECISION FUNCTION ZBTABS(VAL)
+ DOUBLE COMPLEX VAL
+ ZBTABS = ABS( DBLE(VAL) ) + ABS( DIMAG(VAL) )
+ RETURN
+ END
+*
+ SUBROUTINE ZCHKSUM( SCOPE, ICTXT, M, N, A, LDA, TESTNUM, MAXERR,
+ $ NERR, ERRIBUF, ERRDBUF, ISEED )
+*
+* .. Scalar Arguments ..
+ CHARACTER*1 SCOPE
+ INTEGER ICTXT, M, N, LDA, TESTNUM, MAXERR, NERR
+* ..
+* .. Array Arguments ..
+ INTEGER ERRIBUF(6, MAXERR), ISEED(*)
+ DOUBLE COMPLEX A(LDA,*), ERRDBUF(2, MAXERR)
+* ..
+* .. External Functions ..
+ INTEGER IBTMYPROC, IBTNPROCS
+ DOUBLE PRECISION DBTEPS
+ DOUBLE COMPLEX ZBTRAN
+ EXTERNAL IBTMYPROC, IBTNPROCS, DBTEPS, ZBTRAN
+* ..
+* .. Local Scalars ..
+ LOGICAL NUMOK
+ INTEGER NPROCS, NPROW, NPCOL, MYROW, MYCOL, NODE, NNODES, DEST
+ INTEGER I, J, K
+ DOUBLE COMPLEX ANS, TMP
+ DOUBLE PRECISION EPS, ERRBND, RPOSNUM, RNEGNUM, IPOSNUM, INEGNUM
+* ..
+* .. Executable Statements ..
+*
+ NPROCS = IBTNPROCS()
+ EPS = DBTEPS()
+ CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL )
+ DEST = MYROW*NPROCS + MYCOL
+*
+* Set up seeds to match those used by each proc's genmat call
+*
+ IF( SCOPE .EQ. 'R' ) THEN
+ NNODES = NPCOL
+ DO 10 I = 0, NNODES-1
+ NODE = MYROW * NPROCS + I
+ ISEED(I*4+1) = MOD( 1002 + TESTNUM*5 + NODE*3, 4096 )
+ ISEED(I*4+2) = MOD( 2027 + TESTNUM*7 + NODE, 4096 )
+ ISEED(I*4+3) = MOD( 1234 + TESTNUM + NODE*3, 4096 )
+ ISEED(I*4+4) = MOD( 4311 + TESTNUM*10 + NODE*2, 4096 )
+ 10 CONTINUE
+ ELSE IF( SCOPE .EQ. 'C' ) THEN
+ NNODES = NPROW
+ DO 20 I = 0, NNODES-1
+ NODE = I * NPROCS + MYCOL
+ ISEED(I*4+1) = MOD( 1002 + TESTNUM*5 + NODE*3, 4096 )
+ ISEED(I*4+2) = MOD( 2027 + TESTNUM*7 + NODE, 4096 )
+ ISEED(I*4+3) = MOD( 1234 + TESTNUM + NODE*3, 4096 )
+ ISEED(I*4+4) = MOD( 4311 + TESTNUM*10 + NODE*2, 4096 )
+ 20 CONTINUE
+ ELSE
+ NNODES = NPROW * NPCOL
+ DO 30 I = 0, NNODES-1
+ NODE = (I / NPCOL) * NPROCS + MOD(I, NPCOL)
+ ISEED(I*4+1) = MOD( 1002 + TESTNUM*5 + NODE*3, 4096 )
+ ISEED(I*4+2) = MOD( 2027 + TESTNUM*7 + NODE, 4096 )
+ ISEED(I*4+3) = MOD( 1234 + TESTNUM + NODE*3, 4096 )
+ ISEED(I*4+4) = MOD( 4311 + TESTNUM*10 + NODE*2, 4096 )
+ 30 CONTINUE
+ END IF
+*
+ DO 100 J = 1, N
+ DO 90 I = 1, M
+ ANS = 0
+ RPOSNUM = 0
+ RNEGNUM = 0
+ IPOSNUM = 0
+ INEGNUM = 0
+ DO 40 K = 0, NNODES-1
+ TMP = ZBTRAN( ISEED(K*4+1) )
+ IF( DBLE( TMP ) .LT. 0 ) THEN
+ RNEGNUM = RNEGNUM + DBLE( TMP )
+ ELSE
+ RPOSNUM = RPOSNUM + DBLE( TMP )
+ END IF
+ IF( DIMAG( TMP ) .LT. 0 ) THEN
+ INEGNUM = INEGNUM + DIMAG( TMP )
+ ELSE
+ IPOSNUM = IPOSNUM + DIMAG( TMP )
+ END IF
+ ANS = ANS + TMP
+ 40 CONTINUE
+*
+* The error bound is figured by
+* 2 * eps * (nnodes-1) * max(|max element|, |ans|).
+* The 2 allows for errors in the distributed _AND_ local result.
+* The eps is machine epsilon. The number of floating point adds
+* is (nnodes - 1). We use the fact that 0.5 is the maximum element
+* in order to save ourselves some computation.
+*
+ TMP = ANS - A(I,J)
+ ERRBND = 2 * EPS * NNODES * MAX( RPOSNUM, -RNEGNUM )
+ NUMOK = ( DBLE(TMP) .LE. ERRBND )
+ ERRBND = 2 * EPS * NNODES * MAX( IPOSNUM, -INEGNUM )
+ NUMOK = NUMOK .AND. ( DIMAG(TMP) .LE. ERRBND )
+ IF( .NOT.NUMOK ) THEN
+ NERR = NERR + 1
+ IF( NERR .LE. MAXERR ) THEN
+ ERRIBUF(1, NERR) = TESTNUM
+ ERRIBUF(2, NERR) = NNODES
+ ERRIBUF(3, NERR) = DEST
+ ERRIBUF(4, NERR) = I
+ ERRIBUF(5, NERR) = J
+ ERRIBUF(6, NERR) = 5
+ ERRDBUF(1, NERR) = A(I,J)
+ ERRDBUF(2, NERR) = ANS
+ END IF
+ END IF
+ 90 CONTINUE
+ 100 CONTINUE
+*
+ RETURN
+*
+* End of ZCHKSUM
+*
+ END
+*
+*
+ SUBROUTINE IAMXTEST( OUTNUM, VERB, TOPSREPEAT, TOPSCOHRNT, NSCOPE,
+ $ SCOPE0, NTOP, TOP0, NMAT, M0, N0, LDAS0,
+ $ LDAD0, LDI0, NDEST, RDEST0, CDEST0, NGRID,
+ $ CONTEXT0, P0, Q0, ISEED, RMEM, CMEM, RCLEN,
+ $ MEM, MEMLEN )
+*
+* -- BLACS tester (version 1.0) --
+* University of Tennessee
+* December 15, 1994
+*
+*
+* .. Scalar Arguments ..
+ INTEGER MEMLEN, NDEST, NGRID, NMAT, NSCOPE, NTOP, OUTNUM, RCLEN,
+ $ TOPSCOHRNT, TOPSREPEAT, VERB
+* ..
+* .. Array Arguments ..
+ CHARACTER*1 SCOPE0(NSCOPE), TOP0(NTOP)
+ INTEGER M0(NMAT), N0(NMAT), LDAS0(NMAT), LDAD0(NMAT), LDI0(NMAT)
+ INTEGER RDEST0(NDEST), CDEST0(NDEST), CONTEXT0(NGRID)
+ INTEGER P0(NGRID), Q0(NGRID), ISEED(*), RMEM(RCLEN), CMEM(RCLEN)
+ INTEGER MEM(MEMLEN)
+* ..
+*
+* Purpose
+* =======
+* ITESTAMX: Test integer AMX COMBINE
+*
+* Arguments
+* =========
+* OUTNUM (input) INTEGER
+* The device number to write output to.
+*
+* VERB (input) INTEGER
+* The level of verbosity (how much printing to do).
+*
+* NSCOPE (input) INTEGER
+* The number of scopes to be tested.
+*
+* SCOPE0 (input) CHARACTER*1 array of dimension (NSCOPE)
+* Values of the scopes to be tested.
+*
+* NTOP (input) INTEGER
+* The number of topologies to be tested.
+*
+* TOP0 (input) CHARACTER*1 array of dimension (NTOP)
+* Values of the topologies to be tested.
+*
+* NMAT (input) INTEGER
+* The number of matrices to be tested.
+*
+* M0 (input) INTEGER array of dimension (NMAT)
+* Values of M to be tested.
+*
+* M0 (input) INTEGER array of dimension (NMAT)
+* Values of M to be tested.
+*
+* N0 (input) INTEGER array of dimension (NMAT)
+* Values of N to be tested.
+*
+* LDAS0 (input) INTEGER array of dimension (NMAT)
+* Values of LDAS (leading dimension of A on source process)
+* to be tested.
+*
+* LDAD0 (input) INTEGER array of dimension (NMAT)
+* Values of LDAD (leading dimension of A on destination
+* process) to be tested.
+* LDI0 (input) INTEGER array of dimension (NMAT)
+* Values of LDI (leading dimension of RA/CA) to be tested.
+* If LDI == -1, these RA/CA should not be accessed.
+*
+* NDEST (input) INTEGER
+* The number of destinations to be tested.
+*
+* RDEST0 (input) INTEGER array of dimension (NNDEST)
+* Values of RDEST (row coordinate of destination) to be
+* tested.
+*
+* CDEST0 (input) INTEGER array of dimension (NNDEST)
+* Values of CDEST (column coordinate of destination) to be
+* tested.
+*
+* NGRID (input) INTEGER
+* The number of process grids to be tested.
+*
+* CONTEXT0 (input) INTEGER array of dimension (NGRID)
+* The BLACS context handles corresponding to the grids.
+*
+* P0 (input) INTEGER array of dimension (NGRID)
+* Values of P (number of process rows, NPROW).
+*
+* Q0 (input) INTEGER array of dimension (NGRID)
+* Values of Q (number of process columns, NPCOL).
+*
+* ISEED (workspace) INTEGER array of dimension ( MAX(NPROCS, NTESTS) )
+* Workspace used to hold each process's random number SEED.
+* This requires NPROCS (number of processor) elements.
+* If VERB < 2, this workspace also serves to indicate which
+* tests fail. This requires workspace of NTESTS
+* (number of tests performed).
+*
+* RMEM (workspace) INTEGER array of dimension (RCLEN)
+* Used for all RA arrays, and their pre and post padding.
+*
+* CMEM (workspace) INTEGER array of dimension (RCLEN)
+* Used for all CA arrays, and their pre and post padding.
+*
+* RCLEN (input) INTEGER
+* The length, in elements, of RMEM and CMEM.
+*
+* MEM (workspace) INTEGER array of dimension (MEMLEN)
+* Used for all other workspaces, including the matrix A,
+* and its pre and post padding.
+*
+* MEMLEN (input) INTEGER
+* The length, in elements, of MEM.
+*
+* =====================================================================
+*
+* .. External Functions ..
+ LOGICAL ALLPASS, LSAME
+ INTEGER IBTMYPROC, IBTNPROCS, IBTSIZEOF
+ EXTERNAL ALLPASS, LSAME, IBTMYPROC, IBTNPROCS, IBTSIZEOF
+* ..
+* .. External Subroutines ..
+ EXTERNAL BLACS_GRIDINFO, IGAMX2D
+ EXTERNAL IINITMAT, ICHKPAD, IBTCHECKIN
+* ..
+* .. Local Scalars ..
+ CHARACTER*1 SCOPE, TOP
+ LOGICAL INGRID, TESTOK, ALLRCV
+ INTEGER APTR, CAPTR, CDEST, CDEST2, CONTEXT, ERRDPTR, ERRIPTR, I,
+ $ IAM, ICHECKVAL, IDE, IGR, IMA, IPAD, IPOST, IPRE, ISC,
+ $ ISIZE, ISTART, ISTOP, ITC, ITC1, ITC2, ITO, ITR, ITR1,
+ $ ITR2, J, K, LDA, LDADST, LDASRC, LDI, M, MAXERR, MYCOL,
+ $ MYROW, N, NERR, NFAIL, NPCOL, NPROW, NSKIP, PREAPTR,
+ $ RAPTR, RDEST, RDEST2, SETWHAT, TESTNUM, VALPTR
+ INTEGER CHECKVAL
+* ..
+* .. Executable Statements ..
+*
+* Choose padding value, and make it unique
+*
+ CHECKVAL = -911
+ IAM = IBTMYPROC()
+ CHECKVAL = IAM * CHECKVAL
+ ISIZE = IBTSIZEOF('I')
+ ICHECKVAL = -IAM
+*
+* Verify file parameters
+*
+ IF( IAM .EQ. 0 ) THEN
+ WRITE(OUTNUM, *) ' '
+ WRITE(OUTNUM, *) ' '
+ WRITE(OUTNUM, 1000 )
+ IF( VERB .GT. 0 ) THEN
+ WRITE(OUTNUM,*) ' '
+ WRITE(OUTNUM, 2000) 'NSCOPE:', NSCOPE
+ WRITE(OUTNUM, 3000) ' SCOPE:', ( SCOPE0(I), I = 1, NSCOPE )
+ WRITE(OUTNUM, 2000) 'TReps :', TOPSREPEAT
+ WRITE(OUTNUM, 2000) 'TCohr :', TOPSCOHRNT
+ WRITE(OUTNUM, 2000) 'NTOP :', NTOP
+ WRITE(OUTNUM, 3000) ' TOP :', ( TOP0(I), I = 1, NTOP )
+ WRITE(OUTNUM, 2000) 'NMAT :', NMAT
+ WRITE(OUTNUM, 2000) ' M :', ( M0(I), I = 1, NMAT )
+ WRITE(OUTNUM, 2000) ' N :', ( N0(I), I = 1, NMAT )
+ WRITE(OUTNUM, 2000) ' LDAS :', ( LDAS0(I), I = 1, NMAT )
+ WRITE(OUTNUM, 2000) ' LDAD :', ( LDAD0(I), I = 1, NMAT )
+ WRITE(OUTNUM, 2000) ' LDI :', ( LDI0(I), I = 1, NMAT )
+ WRITE(OUTNUM, 2000) 'NDEST :', NDEST
+ WRITE(OUTNUM, 2000) ' RDEST:',( RDEST0(I), I = 1, NDEST )
+ WRITE(OUTNUM, 2000) ' CDEST:',( CDEST0(I), I = 1, NDEST )
+ WRITE(OUTNUM, 2000) 'NGRIDS:', NGRID
+ WRITE(OUTNUM, 2000) ' P :', ( P0(I), I = 1, NGRID )
+ WRITE(OUTNUM, 2000) ' Q :', ( Q0(I), I = 1, NGRID )
+ WRITE(OUTNUM, 2000) 'VERB :', VERB
+ WRITE(OUTNUM,*) ' '
+ END IF
+ IF( VERB .GT. 1 ) THEN
+ WRITE(OUTNUM,4000)
+ WRITE(OUTNUM,5000)
+ END IF
+ END IF
+ IF (TOPSREPEAT.EQ.0) THEN
+ ITR1 = 0
+ ITR2 = 0
+ ELSE IF (TOPSREPEAT.EQ.1) THEN
+ ITR1 = 1
+ ITR2 = 1
+ ELSE
+ ITR1 = 0
+ ITR2 = 1
+ END IF
+*
+* Find biggest matrix, so we know where to stick error info
+*
+ I = 0
+ DO 10 IMA = 1, NMAT
+ IPAD = 4 * M0(IMA)
+ K = N0(IMA) * MAX0( LDAS0(IMA), LDAD0(IMA) ) + IPAD
+ IF( K .GT. I ) I = K
+ 10 CONTINUE
+ I = I + IBTNPROCS()
+ MAXERR = ( ISIZE * (MEMLEN-I) ) / ( ISIZE*2 + ISIZE*6 )
+ IF( MAXERR .LT. 1 ) THEN
+ WRITE(OUTNUM,*) 'ERROR: Not enough memory to run MAX tests.'
+ CALL BLACS_ABORT(-1, 1)
+ END IF
+ ERRDPTR = I + 1
+ ERRIPTR = ERRDPTR + MAXERR
+ NERR = 0
+ TESTNUM = 0
+ NFAIL = 0
+ NSKIP = 0
+*
+* Loop over grids of matrix
+*
+ DO 90 IGR = 1, NGRID
+*
+* allocate process grid for the next batch of tests
+*
+ CONTEXT = CONTEXT0(IGR)
+ CALL BLACS_GRIDINFO( CONTEXT, NPROW, NPCOL, MYROW, MYCOL )
+ INGRID = ( (MYROW.LT.NPROW) .AND. (MYCOL.LT.NPCOL) )
+*
+ DO 80 ISC = 1, NSCOPE
+ SCOPE = SCOPE0(ISC)
+ DO 70 ITO = 1, NTOP
+ TOP = TOP0(ITO)
+*
+* If testing multiring ('M') or general tree ('T'), need to
+* loop over calls to BLACS_SET to do full test
+*
+ IF( LSAME(TOP, 'M') ) THEN
+ SETWHAT = 13
+ IF( SCOPE .EQ. 'R' ) THEN
+ ISTART = -(NPCOL - 1)
+ ISTOP = -ISTART
+ ELSE IF (SCOPE .EQ. 'C') THEN
+ ISTART = -(NPROW - 1)
+ ISTOP = -ISTART
+ ELSE
+ ISTART = -(NPROW*NPCOL - 1)
+ ISTOP = -ISTART
+ ENDIF
+ ELSE IF( LSAME(TOP, 'T') ) THEN
+ SETWHAT = 14
+ ISTART = 1
+ IF( SCOPE .EQ. 'R' ) THEN
+ ISTOP = NPCOL - 1
+ ELSE IF (SCOPE .EQ. 'C') THEN
+ ISTOP = NPROW - 1
+ ELSE
+ ISTOP = NPROW*NPCOL - 1
+ ENDIF
+ ELSE
+ SETWHAT = 0
+ ISTART = 1
+ ISTOP = 1
+ ENDIF
+ DO 60 IMA = 1, NMAT
+ M = M0(IMA)
+ N = N0(IMA)
+ LDASRC = LDAS0(IMA)
+ LDADST = LDAD0(IMA)
+ LDI = LDI0(IMA)
+ IPRE = 2 * M
+ IPOST = IPRE
+ PREAPTR = 1
+ APTR = PREAPTR + IPRE
+*
+ DO 50 IDE = 1, NDEST
+ TESTNUM = TESTNUM + 1
+ RDEST2 = RDEST0(IDE)
+ CDEST2 = CDEST0(IDE)
+*
+* If everyone gets the answer, create some bogus rdest/cdest
+* so IF's are easier
+*
+ ALLRCV = ( (RDEST2.EQ.-1) .OR. (CDEST2.EQ.-1) )
+ IF( ALLRCV ) THEN
+ RDEST = NPROW - 1
+ CDEST = NPCOL - 1
+ IF (TOPSCOHRNT.EQ.0) THEN
+ ITR1 = 0
+ ITR2 = 0
+ ELSE IF (TOPSCOHRNT.EQ.1) THEN
+ ITR1 = 1
+ ITR2 = 1
+ ELSE
+ ITR1 = 0
+ ITR2 = 1
+ END IF
+ ELSE
+ RDEST = RDEST2
+ CDEST = CDEST2
+ ITC1 = 0
+ ITC2 = 0
+ END IF
+ IF( RDEST.GE.P0(IGR) .OR. CDEST.GE.Q0(IGR) ) THEN
+ NSKIP = NSKIP + 1
+ GOTO 50
+ END IF
+*
+ IF( MYROW.EQ.RDEST .AND. MYCOL.EQ.CDEST ) THEN
+ LDA = LDADST
+ ELSE
+ LDA = LDASRC
+ END IF
+ VALPTR = APTR + IPOST + N * LDA
+ IF( VERB .GT. 1 ) THEN
+ IF( IAM .EQ. 0 ) THEN
+ WRITE(OUTNUM, 6000)
+ $ TESTNUM, 'RUNNING', SCOPE, TOP, M, N,
+ $ LDASRC, LDADST, LDI, RDEST2, CDEST2,
+ $ NPROW, NPCOL
+ END IF
+ END IF
+*
+* If I am in scope
+*
+ TESTOK = .TRUE.
+ IF( INGRID ) THEN
+ IF( (MYROW.EQ.RDEST .AND. SCOPE.EQ.'R') .OR.
+ $ (MYCOL.EQ.CDEST .AND. SCOPE.EQ.'C') .OR.
+ $ (SCOPE .EQ. 'A') ) THEN
+*
+ K = NERR
+ DO 40 ITR = ITR1, ITR2
+ CALL BLACS_SET(CONTEXT, 15, ITR)
+ DO 35 ITC = ITC1, ITC2
+ CALL BLACS_SET(CONTEXT, 16, ITC)
+ DO 30 J = ISTART, ISTOP
+ IF( J.EQ.0) GOTO 30
+ IF( SETWHAT.NE.0 )
+ $ CALL BLACS_SET(CONTEXT, SETWHAT, J)
+*
+*
+* generate and pad matrix A
+*
+ CALL IINITMAT('G','-', M, N, MEM(PREAPTR),
+ $ LDA, IPRE, IPOST,
+ $ CHECKVAL, TESTNUM,
+ $ MYROW, MYCOL )
+*
+* If they exist, pad RA and CA arrays
+*
+ IF( LDI .NE. -1 ) THEN
+ DO 15 I = 1, N*LDI + IPRE + IPOST
+ RMEM(I) = ICHECKVAL
+ CMEM(I) = ICHECKVAL
+ 15 CONTINUE
+ RAPTR = 1 + IPRE
+ CAPTR = 1 + IPRE
+ ELSE
+ DO 20 I = 1, IPRE+IPOST
+ RMEM(I) = ICHECKVAL
+ CMEM(I) = ICHECKVAL
+ 20 CONTINUE
+ RAPTR = 1
+ CAPTR = 1
+ END IF
+*
+ CALL IGAMX2D(CONTEXT, SCOPE, TOP, M, N,
+ $ MEM(APTR), LDA, RMEM(RAPTR),
+ $ CMEM(CAPTR), LDI,
+ $ RDEST2, CDEST2)
+*
+* If I've got the answer, check for errors in
+* matrix or padding
+*
+ IF( (MYROW.EQ.RDEST .AND. MYCOL.EQ.CDEST)
+ $ .OR. ALLRCV ) THEN
+ CALL ICHKPAD('G','-', M, N,
+ $ MEM(PREAPTR), LDA, RDEST,
+ $ CDEST, MYROW, MYCOL,
+ $ IPRE, IPOST, CHECKVAL,
+ $ TESTNUM, MAXERR, NERR,
+ $ MEM(ERRIPTR),MEM(ERRDPTR))
+ CALL ICHKAMX(SCOPE, CONTEXT, M, N,
+ $ MEM(APTR), LDA,
+ $ RMEM(RAPTR), CMEM(CAPTR),
+ $ LDI, TESTNUM, MAXERR,NERR,
+ $ MEM(ERRIPTR),MEM(ERRDPTR),
+ $ ISEED, MEM(VALPTR))
+ CALL IRCCHK(IPRE, IPOST, ICHECKVAL,
+ $ M, N, RMEM, CMEM, LDI,
+ $ MYROW, MYCOL, TESTNUM,
+ $ MAXERR, NERR,
+ $ MEM(ERRIPTR), MEM(ERRDPTR))
+ END IF
+ 30 CONTINUE
+ CALL BLACS_SET(CONTEXT, 16, 0)
+ 35 CONTINUE
+ CALL BLACS_SET(CONTEXT, 15, 0)
+ 40 CONTINUE
+ TESTOK = ( K .EQ. NERR )
+ END IF
+ END IF
+*
+ IF( VERB .GT. 1 ) THEN
+ I = NERR
+ CALL IBTCHECKIN(0, OUTNUM, MAXERR, NERR,
+ $ MEM(ERRIPTR), MEM(ERRDPTR), ISEED)
+ IF( IAM .EQ. 0 ) THEN
+ IF( TESTOK .AND. NERR.EQ.I ) THEN
+ WRITE(OUTNUM,6000)TESTNUM,'PASSED ',
+ $ SCOPE, TOP, M, N, LDASRC,
+ $ LDADST, LDI, RDEST2, CDEST2,
+ $ NPROW, NPCOL
+ ELSE
+ NFAIL = NFAIL + 1
+ WRITE(OUTNUM,6000)TESTNUM,'FAILED ',
+ $ SCOPE, TOP, M, N, LDASRC,
+ $ LDADST, LDI, RDEST2, CDEST2,
+ $ NPROW, NPCOL
+ END IF
+ END IF
+*
+* Once we've printed out errors, can re-use buf space
+*
+ NERR = 0
+ END IF
+ 50 CONTINUE
+ 60 CONTINUE
+ 70 CONTINUE
+ 80 CONTINUE
+ 90 CONTINUE
+*
+ IF( VERB .LT. 2 ) THEN
+ NFAIL = TESTNUM
+ CALL IBTCHECKIN( NFAIL, OUTNUM, MAXERR, NERR, MEM(ERRIPTR),
+ $ MEM(ERRDPTR), ISEED )
+ END IF
+ IF( IAM .EQ. 0 ) THEN
+ IF( VERB .GT. 1 ) WRITE(OUTNUM,*) ' '
+ IF( NFAIL+NSKIP .EQ. 0 ) THEN
+ WRITE(OUTNUM, 7000 ) TESTNUM
+ ELSE
+ WRITE(OUTNUM, 8000 ) TESTNUM, TESTNUM-NSKIP-NFAIL,
+ $ NSKIP, NFAIL
+ END IF
+ END IF
+*
+* Log whether their were any failures
+*
+ TESTOK = ALLPASS( (NFAIL.EQ.0) )
+*
+ 1000 FORMAT('INTEGER AMX TESTS: BEGIN.' )
+ 2000 FORMAT(1X,A7,3X,10I6)
+ 3000 FORMAT(1X,A7,3X,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1,
+ $ 5X,A1,5X,A1)
+ 4000 FORMAT(' TEST# STATUS SCOPE TOP M N LDAS LDAD LDI ',
+ $ 'RDEST CDEST P Q')
+ 5000 FORMAT(' ----- ------- ----- --- ----- ----- ----- ----- ----- ',
+ $ '----- ----- ---- ----')
+ 6000 FORMAT(I6,1X,A7,5X,A1,3X,A1,7I6,2I5)
+ 7000 FORMAT('INTEGER AMX TESTS: PASSED ALL',
+ $ I5, ' TESTS.')
+ 8000 FORMAT('INTEGER AMX TESTS:',I5,' TESTS;',I5,' PASSED,',
+ $ I5,' SKIPPED,',I5,' FAILED.')
+*
+ RETURN
+*
+* End of ITESTAMX.
+*
+ END
+*
+ SUBROUTINE IBTSPCOORD( SCOPE, PNUM, MYROW, MYCOL, NPCOL,
+ $ PROW, PCOL )
+ CHARACTER*1 SCOPE
+ INTEGER PNUM, MYROW, MYCOL, NPCOL, PROW, PCOL
+*
+ IF( SCOPE .EQ. 'R' ) THEN
+ PROW = MYROW
+ PCOL = PNUM
+ ELSE IF( SCOPE .EQ. 'C' ) THEN
+ PROW = PNUM
+ PCOL = MYCOL
+ ELSE
+ PROW = PNUM / NPCOL
+ PCOL = MOD( PNUM, NPCOL )
+ END IF
+ RETURN
+*
+* End of ibtspcoord
+*
+ END
+*
+ INTEGER FUNCTION IBTSPNUM( SCOPE, PROW, PCOL, NPCOL )
+ CHARACTER*1 SCOPE
+ INTEGER PROW, PCOL, NPCOL
+ IF( SCOPE .EQ. 'R' ) THEN
+ IBTSPNUM = PCOL
+ ELSE IF( SCOPE .EQ. 'C' ) THEN
+ IBTSPNUM = PROW
+ ELSE
+ IBTSPNUM = PROW*NPCOL + PCOL
+ END IF
+*
+ RETURN
+*
+* End of ibtscpnum
+*
+ END
+*
+ SUBROUTINE IRCCHK( IPRE, IPOST, PADVAL, M, N, RA, CA, LDI, MYROW,
+ $ MYCOL, TESTNUM, MAXERR, NERR,
+ $ ERRIBUF, ERRDBUF )
+*
+* .. Scalar Arguments ..
+ INTEGER IPRE, IPOST, PADVAL, M, N, LDI, MYROW, MYCOL, TESTNUM
+ INTEGER MAXERR, NERR
+* ..
+* .. Array Arguments ..
+ INTEGER RA(*), CA(*), ERRIBUF(6, MAXERR)
+ INTEGER ERRDBUF(2, MAXERR)
+* ..
+* .. Parameters ..
+ INTEGER ERR_PRE, ERR_POST, ERR_GAP, ERR_TRI, ERR_MAT
+ PARAMETER( ERR_PRE = 1, ERR_POST = 2, ERR_GAP = 3, ERR_TRI = 4 )
+ PARAMETER( ERR_MAT = 5 )
+* ..
+* .. External Functions ..
+ INTEGER IBTNPROCS
+ EXTERNAL IBTNPROCS
+* ..
+* .. Local Scalars ..
+ INTEGER I, J, K, IAM
+* ..
+* .. Executable Statements ..
+*
+ IAM = MYROW * IBTNPROCS() + MYCOL
+*
+* Check pre padding
+*
+ IF( LDI .NE. -1 ) THEN
+ IF( IPRE .GT. 0 ) THEN
+ DO 10 I = 1, IPRE
+ IF( RA(I) .NE. PADVAL ) THEN
+ NERR = NERR + 1
+ IF( NERR .LE. MAXERR ) THEN
+ ERRIBUF(1, NERR) = TESTNUM
+ ERRIBUF(2, NERR) = LDI
+ ERRIBUF(3, NERR) = IAM
+ ERRIBUF(4, NERR) = I
+ ERRIBUF(5, NERR) = IPRE - I + 1
+ ERRIBUF(6, NERR) = -ERR_PRE
+ ERRDBUF(1, NERR) = INT( RA(I) )
+ ERRDBUF(2, NERR) = INT( PADVAL )
+ END IF
+ ENDIF
+ IF( CA(I) .NE. PADVAL ) THEN
+ NERR = NERR + 1
+ IF( NERR .LE. MAXERR ) THEN
+ ERRIBUF(1, NERR) = TESTNUM
+ ERRIBUF(2, NERR) = LDI
+ ERRIBUF(3, NERR) = IAM
+ ERRIBUF(4, NERR) = I
+ ERRIBUF(5, NERR) = IPRE - I + 1
+ ERRIBUF(6, NERR) = -10 - ERR_PRE
+ ERRDBUF(1, NERR) = INT( CA(I) )
+ ERRDBUF(2, NERR) = INT( PADVAL )
+ END IF
+ ENDIF
+ 10 CONTINUE
+ END IF
+*
+* Check post padding
+*
+ IF( IPOST .GT. 0 ) THEN
+ K = IPRE + LDI*N
+ DO 20 I = K+1, K+IPOST
+ IF( RA(I) .NE. PADVAL ) THEN
+ NERR = NERR + 1
+ IF( NERR .LE. MAXERR ) THEN
+ ERRIBUF(1, NERR) = TESTNUM
+ ERRIBUF(2, NERR) = LDI
+ ERRIBUF(3, NERR) = IAM
+ ERRIBUF(4, NERR) = I - K
+ ERRIBUF(5, NERR) = I
+ ERRIBUF(6, NERR) = -ERR_POST
+ ERRDBUF(1, NERR) = INT( RA(I) )
+ ERRDBUF(2, NERR) = INT( PADVAL )
+ END IF
+ ENDIF
+ IF( CA(I) .NE. PADVAL ) THEN
+ NERR = NERR + 1
+ IF( NERR .LE. MAXERR ) THEN
+ ERRIBUF(1, NERR) = TESTNUM
+ ERRIBUF(2, NERR) = LDI
+ ERRIBUF(3, NERR) = IAM
+ ERRIBUF(4, NERR) = I - K
+ ERRIBUF(5, NERR) = I
+ ERRIBUF(6, NERR) = -10 - ERR_POST
+ ERRDBUF(1, NERR) = INT( CA(I) )
+ ERRDBUF(2, NERR) = INT( PADVAL )
+ END IF
+ ENDIF
+ 20 CONTINUE
+ END IF
+*
+* Check all (LDI-M) gaps
+*
+ IF( LDI .GT. M ) THEN
+ K = IPRE + M + 1
+ DO 40 J = 1, N
+ DO 30 I = M+1, LDI
+ K = IPRE + (J-1)*LDI + I
+ IF( RA(K) .NE. PADVAL) THEN
+ NERR = NERR + 1
+ IF( NERR .LE. MAXERR ) THEN
+ ERRIBUF(1, NERR) = TESTNUM
+ ERRIBUF(2, NERR) = LDI
+ ERRIBUF(3, NERR) = IAM
+ ERRIBUF(4, NERR) = I
+ ERRIBUF(5, NERR) = J
+ ERRIBUF(6, NERR) = -ERR_GAP
+ ERRDBUF(1, NERR) = INT( RA(K) )
+ ERRDBUF(2, NERR) = INT( PADVAL )
+ END IF
+ END IF
+ IF( CA(K) .NE. PADVAL) THEN
+ NERR = NERR + 1
+ IF( NERR .LE. MAXERR ) THEN
+ ERRIBUF(1, NERR) = TESTNUM
+ ERRIBUF(2, NERR) = LDI
+ ERRIBUF(3, NERR) = IAM
+ ERRIBUF(4, NERR) = I
+ ERRIBUF(5, NERR) = J
+ ERRIBUF(6, NERR) = -10 - ERR_GAP
+ ERRDBUF(1, NERR) = INT( CA(K) )
+ ERRDBUF(2, NERR) = INT( PADVAL )
+ END IF
+ END IF
+ 30 CONTINUE
+ 40 CONTINUE
+ END IF
+*
+* if RA and CA don't exist, buffs better be untouched
+*
+ ELSE
+ DO 50 I = 1, IPRE+IPOST
+ IF( RA(I) .NE. PADVAL) THEN
+ NERR = NERR + 1
+ IF( NERR .LE. MAXERR ) THEN
+ ERRIBUF(1, NERR) = TESTNUM
+ ERRIBUF(2, NERR) = LDI
+ ERRIBUF(3, NERR) = IAM
+ ERRIBUF(4, NERR) = I
+ ERRIBUF(5, NERR) = IPRE+IPOST
+ ERRIBUF(6, NERR) = -ERR_PRE
+ ERRDBUF(1, NERR) = INT( RA(I) )
+ ERRDBUF(2, NERR) = INT( PADVAL )
+ END IF
+ END IF
+ IF( CA(I) .NE. PADVAL) THEN
+ NERR = NERR + 1
+ IF( NERR .LE. MAXERR ) THEN
+ ERRIBUF(1, NERR) = TESTNUM
+ ERRIBUF(2, NERR) = LDI
+ ERRIBUF(3, NERR) = IAM
+ ERRIBUF(4, NERR) = I
+ ERRIBUF(5, NERR) = IPRE+IPOST
+ ERRIBUF(6, NERR) = -10 - ERR_PRE
+ ERRDBUF(1, NERR) = INT( CA(I) )
+ ERRDBUF(2, NERR) = INT( PADVAL )
+ END IF
+ END IF
+ 50 CONTINUE
+ ENDIF
+*
+ RETURN
+ END
+*
+ SUBROUTINE ICHKAMX( SCOPE, ICTXT, M, N, A, LDA, RA, CA, LDI,
+ $ TESTNUM, MAXERR, NERR, ERRIBUF, ERRDBUF,
+ $ ISEED, VALS )
+*
+* .. Scalar Arguments ..
+ CHARACTER*1 SCOPE
+ INTEGER ICTXT, M, N, LDA, LDI, TESTNUM, MAXERR, NERR
+* ..
+* .. Array Arguments ..
+ INTEGER RA(*), CA(*), ERRIBUF(6, MAXERR), ISEED(*)
+ INTEGER A(LDA,*), ERRDBUF(2, MAXERR), VALS(*)
+* ..
+* .. External Functions ..
+ INTEGER IBTMYPROC, IBTNPROCS, IBTSPNUM, IBTRAN, IBTABS
+ EXTERNAL IBTMYPROC, IBTNPROCS, IBTSPNUM, IBTRAN
+ EXTERNAL IBTABS
+* ..
+* .. External Subroutines ..
+ EXTERNAL IBTSPCOORD
+* ..
+* .. Local Scalars ..
+ LOGICAL ERROR
+ INTEGER NPROCS, NNODES, NPROW, NPCOL, MYROW, MYCOL, RAMX, CAMX
+ INTEGER IAMX, I, J, K, H, DEST, NODE
+* ..
+* .. Executable Statements ..
+*
+ NPROCS = IBTNPROCS()
+ CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL )
+ DEST = MYROW*NPROCS + MYCOL
+*
+* Set up seeds to match those used by each proc's genmat call
+*
+ IF( SCOPE .EQ. 'R' ) THEN
+ NNODES = NPCOL
+ DO 10 I = 0, NNODES-1
+ NODE = MYROW * NPROCS + I
+ ISEED(I*4+1) = MOD( 1002 + TESTNUM*5 + NODE*3, 4096 )
+ ISEED(I*4+2) = MOD( 2027 + TESTNUM*7 + NODE, 4096 )
+ ISEED(I*4+3) = MOD( 1234 + TESTNUM + NODE*3, 4096 )
+ ISEED(I*4+4) = MOD( 4311 + TESTNUM*10 + NODE*2, 4096 )
+ 10 CONTINUE
+ ELSE IF( SCOPE .EQ. 'C' ) THEN
+ NNODES = NPROW
+ DO 20 I = 0, NNODES-1
+ NODE = I * NPROCS + MYCOL
+ ISEED(I*4+1) = MOD( 1002 + TESTNUM*5 + NODE*3, 4096 )
+ ISEED(I*4+2) = MOD( 2027 + TESTNUM*7 + NODE, 4096 )
+ ISEED(I*4+3) = MOD( 1234 + TESTNUM + NODE*3, 4096 )
+ ISEED(I*4+4) = MOD( 4311 + TESTNUM*10 + NODE*2, 4096 )
+ 20 CONTINUE
+ ELSE
+ NNODES = NPROW * NPCOL
+ DO 30 I = 0, NNODES-1
+ NODE = (I / NPCOL) * NPROCS + MOD(I, NPCOL)
+ ISEED(I*4+1) = MOD( 1002 + TESTNUM*5 + NODE*3, 4096 )
+ ISEED(I*4+2) = MOD( 2027 + TESTNUM*7 + NODE, 4096 )
+ ISEED(I*4+3) = MOD( 1234 + TESTNUM + NODE*3, 4096 )
+ ISEED(I*4+4) = MOD( 4311 + TESTNUM*10 + NODE*2, 4096 )
+ 30 CONTINUE
+ END IF
+*
+ DO 100 J = 1, N
+ DO 90 I = 1, M
+ H = (J-1)*LDI + I
+ VALS(1) = IBTRAN( ISEED )
+ IAMX = 1
+ IF( NNODES .GT. 1 ) THEN
+ DO 40 K = 1, NNODES-1
+ VALS(K+1) = IBTRAN( ISEED(K*4+1) )
+ IF( IBTABS( VALS(K+1) ) .GT. IBTABS( VALS(IAMX) ) )
+ $ IAMX = K + 1
+ 40 CONTINUE
+ END IF
+*
+* If BLACS have not returned same value we've chosen
+*
+ IF( A(I,J) .NE. VALS(IAMX) ) THEN
+*
+* If we have RA and CA arrays
+*
+ IF( LDI .NE. -1 ) THEN
+*
+* Any number having the same absolute value is a valid max
+*
+ K = IBTSPNUM( SCOPE, RA(H), CA(H), NPCOL ) + 1
+ IF( K.GT.0 .AND. K.LE.NNODES ) THEN
+ ERROR = IBTABS( VALS(K) ).NE.IBTABS( VALS(IAMX) )
+ IF( .NOT.ERROR ) IAMX = K
+ ELSE
+ ERROR = .TRUE.
+ END IF
+ ELSE
+*
+* Error if BLACS answer not same absolute value, or if it
+* was not really in the numbers being compared
+*
+ ERROR = ( IBTABS( A(I,J) ) .NE. IBTABS( VALS(IAMX) ) )
+ IF( .NOT.ERROR ) THEN
+ DO 50 K = 1, NNODES
+ IF( VALS(K) .EQ. A(I,J) ) GOTO 60
+ 50 CONTINUE
+ ERROR = .TRUE.
+ 60 CONTINUE
+ ENDIF
+ END IF
+*
+* If the value is in error
+*
+ IF( ERROR ) THEN
+ NERR = NERR + 1
+ ERRIBUF(1, NERR) = TESTNUM
+ ERRIBUF(2, NERR) = NNODES
+ ERRIBUF(3, NERR) = DEST
+ ERRIBUF(4, NERR) = I
+ ERRIBUF(5, NERR) = J
+ ERRIBUF(6, NERR) = 5
+ ERRDBUF(1, NERR) = A(I,J)
+ ERRDBUF(2, NERR) = VALS(IAMX)
+ END IF
+ END IF
+*
+* If they are defined, make sure coordinate entries are OK
+*
+ IF( LDI .NE. -1 ) THEN
+ K = IBTSPNUM( SCOPE, RA(H), CA(H), NPCOL ) + 1
+ IF( K.NE.IAMX ) THEN
+*
+* Make sure more than one proc doesn't have exact same value
+* (and therefore there may be more than one valid coordinate
+* for a single value)
+*
+ IF( K.GT.NNODES .OR. K.LT.1 ) THEN
+ ERROR = .TRUE.
+ ELSE
+ ERROR = ( VALS(K) .NE. VALS(IAMX) )
+ END IF
+ IF( ERROR ) THEN
+ CALL IBTSPCOORD( SCOPE, IAMX-1, MYROW, MYCOL,
+ $ NPCOL, RAMX, CAMX )
+ IF( RAMX .NE. RA(H) ) THEN
+ NERR = NERR + 1
+ ERRIBUF(1, NERR) = TESTNUM
+ ERRIBUF(2, NERR) = NNODES
+ ERRIBUF(3, NERR) = DEST
+ ERRIBUF(4, NERR) = I
+ ERRIBUF(5, NERR) = J
+ ERRIBUF(6, NERR) = -5
+ ERRDBUF(1, NERR) = RA(H)
+ ERRDBUF(2, NERR) = RAMX
+ END IF
+ IF( CAMX .NE. CA(H) ) THEN
+ NERR = NERR + 1
+ ERRIBUF(1, NERR) = TESTNUM
+ ERRIBUF(2, NERR) = NNODES
+ ERRIBUF(3, NERR) = DEST
+ ERRIBUF(4, NERR) = I
+ ERRIBUF(5, NERR) = J
+ ERRIBUF(6, NERR) = -15
+ ERRDBUF(1, NERR) = CA(H)
+ ERRDBUF(2, NERR) = CAMX
+ END IF
+ END IF
+ END IF
+ END IF
+ 90 CONTINUE
+ 100 CONTINUE
+*
+ RETURN
+*
+* End of ICHKAMX
+*
+ END
+*
+*
+ SUBROUTINE SAMXTEST( OUTNUM, VERB, TOPSREPEAT, TOPSCOHRNT, NSCOPE,
+ $ SCOPE0, NTOP, TOP0, NMAT, M0, N0, LDAS0,
+ $ LDAD0, LDI0, NDEST, RDEST0, CDEST0, NGRID,
+ $ CONTEXT0, P0, Q0, ISEED, RMEM, CMEM, RCLEN,
+ $ MEM, MEMLEN )
+*
+* -- BLACS tester (version 1.0) --
+* University of Tennessee
+* December 15, 1994
+*
+*
+* .. Scalar Arguments ..
+ INTEGER MEMLEN, NDEST, NGRID, NMAT, NSCOPE, NTOP, OUTNUM, RCLEN,
+ $ TOPSCOHRNT, TOPSREPEAT, VERB
+* ..
+* .. Array Arguments ..
+ CHARACTER*1 SCOPE0(NSCOPE), TOP0(NTOP)
+ INTEGER M0(NMAT), N0(NMAT), LDAS0(NMAT), LDAD0(NMAT), LDI0(NMAT)
+ INTEGER RDEST0(NDEST), CDEST0(NDEST), CONTEXT0(NGRID)
+ INTEGER P0(NGRID), Q0(NGRID), ISEED(*), RMEM(RCLEN), CMEM(RCLEN)
+ REAL MEM(MEMLEN)
+* ..
+*
+* Purpose
+* =======
+* STESTAMX: Test real AMX COMBINE
+*
+* Arguments
+* =========
+* OUTNUM (input) INTEGER
+* The device number to write output to.
+*
+* VERB (input) INTEGER
+* The level of verbosity (how much printing to do).
+*
+* NSCOPE (input) INTEGER
+* The number of scopes to be tested.
+*
+* SCOPE0 (input) CHARACTER*1 array of dimension (NSCOPE)
+* Values of the scopes to be tested.
+*
+* NTOP (input) INTEGER
+* The number of topologies to be tested.
+*
+* TOP0 (input) CHARACTER*1 array of dimension (NTOP)
+* Values of the topologies to be tested.
+*
+* NMAT (input) INTEGER
+* The number of matrices to be tested.
+*
+* M0 (input) INTEGER array of dimension (NMAT)
+* Values of M to be tested.
+*
+* M0 (input) INTEGER array of dimension (NMAT)
+* Values of M to be tested.
+*
+* N0 (input) INTEGER array of dimension (NMAT)
+* Values of N to be tested.
+*
+* LDAS0 (input) INTEGER array of dimension (NMAT)
+* Values of LDAS (leading dimension of A on source process)
+* to be tested.
+*
+* LDAD0 (input) INTEGER array of dimension (NMAT)
+* Values of LDAD (leading dimension of A on destination
+* process) to be tested.
+* LDI0 (input) INTEGER array of dimension (NMAT)
+* Values of LDI (leading dimension of RA/CA) to be tested.
+* If LDI == -1, these RA/CA should not be accessed.
+*
+* NDEST (input) INTEGER
+* The number of destinations to be tested.
+*
+* RDEST0 (input) INTEGER array of dimension (NNDEST)
+* Values of RDEST (row coordinate of destination) to be
+* tested.
+*
+* CDEST0 (input) INTEGER array of dimension (NNDEST)
+* Values of CDEST (column coordinate of destination) to be
+* tested.
+*
+* NGRID (input) INTEGER
+* The number of process grids to be tested.
+*
+* CONTEXT0 (input) INTEGER array of dimension (NGRID)
+* The BLACS context handles corresponding to the grids.
+*
+* P0 (input) INTEGER array of dimension (NGRID)
+* Values of P (number of process rows, NPROW).
+*
+* Q0 (input) INTEGER array of dimension (NGRID)
+* Values of Q (number of process columns, NPCOL).
+*
+* ISEED (workspace) INTEGER array of dimension ( MAX(NPROCS, NTESTS) )
+* Workspace used to hold each process's random number SEED.
+* This requires NPROCS (number of processor) elements.
+* If VERB < 2, this workspace also serves to indicate which
+* tests fail. This requires workspace of NTESTS
+* (number of tests performed).
+*
+* RMEM (workspace) INTEGER array of dimension (RCLEN)
+* Used for all RA arrays, and their pre and post padding.
+*
+* CMEM (workspace) INTEGER array of dimension (RCLEN)
+* Used for all CA arrays, and their pre and post padding.
+*
+* RCLEN (input) INTEGER
+* The length, in elements, of RMEM and CMEM.
+*
+* MEM (workspace) REAL array of dimension (MEMLEN)
+* Used for all other workspaces, including the matrix A,
+* and its pre and post padding.
+*
+* MEMLEN (input) INTEGER
+* The length, in elements, of MEM.
+*
+* =====================================================================
+*
+* .. External Functions ..
+ LOGICAL ALLPASS, LSAME
+ INTEGER IBTMYPROC, IBTNPROCS, IBTSIZEOF
+ EXTERNAL ALLPASS, LSAME, IBTMYPROC, IBTNPROCS, IBTSIZEOF
+* ..
+* .. External Subroutines ..
+ EXTERNAL BLACS_GRIDINFO, SGAMX2D
+ EXTERNAL SINITMAT, SCHKPAD, SBTCHECKIN
+* ..
+* .. Local Scalars ..
+ CHARACTER*1 SCOPE, TOP
+ LOGICAL INGRID, TESTOK, ALLRCV
+ INTEGER APTR, CAPTR, CDEST, CDEST2, CONTEXT, ERRDPTR, ERRIPTR, I,
+ $ IAM, ICHECKVAL, IDE, IGR, IMA, IPAD, IPOST, IPRE, ISC,
+ $ ISIZE, ISTART, ISTOP, ITC, ITC1, ITC2, ITO, ITR, ITR1,
+ $ ITR2, J, K, LDA, LDADST, LDASRC, LDI, M, MAXERR, MYCOL,
+ $ MYROW, N, NERR, NFAIL, NPCOL, NPROW, NSKIP, PREAPTR,
+ $ RAPTR, RDEST, RDEST2, SETWHAT, SSIZE, TESTNUM, VALPTR
+ REAL CHECKVAL
+* ..
+* .. Executable Statements ..
+*
+* Choose padding value, and make it unique
+*
+ CHECKVAL = -0.61E0
+ IAM = IBTMYPROC()
+ CHECKVAL = IAM * CHECKVAL
+ ISIZE = IBTSIZEOF('I')
+ SSIZE = IBTSIZEOF('S')
+ ICHECKVAL = -IAM
+*
+* Verify file parameters
+*
+ IF( IAM .EQ. 0 ) THEN
+ WRITE(OUTNUM, *) ' '
+ WRITE(OUTNUM, *) ' '
+ WRITE(OUTNUM, 1000 )
+ IF( VERB .GT. 0 ) THEN
+ WRITE(OUTNUM,*) ' '
+ WRITE(OUTNUM, 2000) 'NSCOPE:', NSCOPE
+ WRITE(OUTNUM, 3000) ' SCOPE:', ( SCOPE0(I), I = 1, NSCOPE )
+ WRITE(OUTNUM, 2000) 'TReps :', TOPSREPEAT
+ WRITE(OUTNUM, 2000) 'TCohr :', TOPSCOHRNT
+ WRITE(OUTNUM, 2000) 'NTOP :', NTOP
+ WRITE(OUTNUM, 3000) ' TOP :', ( TOP0(I), I = 1, NTOP )
+ WRITE(OUTNUM, 2000) 'NMAT :', NMAT
+ WRITE(OUTNUM, 2000) ' M :', ( M0(I), I = 1, NMAT )
+ WRITE(OUTNUM, 2000) ' N :', ( N0(I), I = 1, NMAT )
+ WRITE(OUTNUM, 2000) ' LDAS :', ( LDAS0(I), I = 1, NMAT )
+ WRITE(OUTNUM, 2000) ' LDAD :', ( LDAD0(I), I = 1, NMAT )
+ WRITE(OUTNUM, 2000) ' LDI :', ( LDI0(I), I = 1, NMAT )
+ WRITE(OUTNUM, 2000) 'NDEST :', NDEST
+ WRITE(OUTNUM, 2000) ' RDEST:',( RDEST0(I), I = 1, NDEST )
+ WRITE(OUTNUM, 2000) ' CDEST:',( CDEST0(I), I = 1, NDEST )
+ WRITE(OUTNUM, 2000) 'NGRIDS:', NGRID
+ WRITE(OUTNUM, 2000) ' P :', ( P0(I), I = 1, NGRID )
+ WRITE(OUTNUM, 2000) ' Q :', ( Q0(I), I = 1, NGRID )
+ WRITE(OUTNUM, 2000) 'VERB :', VERB
+ WRITE(OUTNUM,*) ' '
+ END IF
+ IF( VERB .GT. 1 ) THEN
+ WRITE(OUTNUM,4000)
+ WRITE(OUTNUM,5000)
+ END IF
+ END IF
+ IF (TOPSREPEAT.EQ.0) THEN
+ ITR1 = 0
+ ITR2 = 0
+ ELSE IF (TOPSREPEAT.EQ.1) THEN
+ ITR1 = 1
+ ITR2 = 1
+ ELSE
+ ITR1 = 0
+ ITR2 = 1
+ END IF
+*
+* Find biggest matrix, so we know where to stick error info
+*
+ I = 0
+ DO 10 IMA = 1, NMAT
+ IPAD = 4 * M0(IMA)
+ K = N0(IMA) * MAX0( LDAS0(IMA), LDAD0(IMA) ) + IPAD
+ IF( K .GT. I ) I = K
+ 10 CONTINUE
+ I = I + IBTNPROCS()
+ MAXERR = ( SSIZE * (MEMLEN-I) ) / ( SSIZE*2 + ISIZE*6 )
+ IF( MAXERR .LT. 1 ) THEN
+ WRITE(OUTNUM,*) 'ERROR: Not enough memory to run MAX tests.'
+ CALL BLACS_ABORT(-1, 1)
+ END IF
+ ERRDPTR = I + 1
+ ERRIPTR = ERRDPTR + MAXERR
+ NERR = 0
+ TESTNUM = 0
+ NFAIL = 0
+ NSKIP = 0
+*
+* Loop over grids of matrix
+*
+ DO 90 IGR = 1, NGRID
+*
+* allocate process grid for the next batch of tests
+*
+ CONTEXT = CONTEXT0(IGR)
+ CALL BLACS_GRIDINFO( CONTEXT, NPROW, NPCOL, MYROW, MYCOL )
+ INGRID = ( (MYROW.LT.NPROW) .AND. (MYCOL.LT.NPCOL) )
+*
+ DO 80 ISC = 1, NSCOPE
+ SCOPE = SCOPE0(ISC)
+ DO 70 ITO = 1, NTOP
+ TOP = TOP0(ITO)
+*
+* If testing multiring ('M') or general tree ('T'), need to
+* loop over calls to BLACS_SET to do full test
+*
+ IF( LSAME(TOP, 'M') ) THEN
+ SETWHAT = 13
+ IF( SCOPE .EQ. 'R' ) THEN
+ ISTART = -(NPCOL - 1)
+ ISTOP = -ISTART
+ ELSE IF (SCOPE .EQ. 'C') THEN
+ ISTART = -(NPROW - 1)
+ ISTOP = -ISTART
+ ELSE
+ ISTART = -(NPROW*NPCOL - 1)
+ ISTOP = -ISTART
+ ENDIF
+ ELSE IF( LSAME(TOP, 'T') ) THEN
+ SETWHAT = 14
+ ISTART = 1
+ IF( SCOPE .EQ. 'R' ) THEN
+ ISTOP = NPCOL - 1
+ ELSE IF (SCOPE .EQ. 'C') THEN
+ ISTOP = NPROW - 1
+ ELSE
+ ISTOP = NPROW*NPCOL - 1
+ ENDIF
+ ELSE
+ SETWHAT = 0
+ ISTART = 1
+ ISTOP = 1
+ ENDIF
+ DO 60 IMA = 1, NMAT
+ M = M0(IMA)
+ N = N0(IMA)
+ LDASRC = LDAS0(IMA)
+ LDADST = LDAD0(IMA)
+ LDI = LDI0(IMA)
+ IPRE = 2 * M
+ IPOST = IPRE
+ PREAPTR = 1
+ APTR = PREAPTR + IPRE
+*
+ DO 50 IDE = 1, NDEST
+ TESTNUM = TESTNUM + 1
+ RDEST2 = RDEST0(IDE)
+ CDEST2 = CDEST0(IDE)
+*
+* If everyone gets the answer, create some bogus rdest/cdest
+* so IF's are easier
+*
+ ALLRCV = ( (RDEST2.EQ.-1) .OR. (CDEST2.EQ.-1) )
+ IF( ALLRCV ) THEN
+ RDEST = NPROW - 1
+ CDEST = NPCOL - 1
+ IF (TOPSCOHRNT.EQ.0) THEN
+ ITR1 = 0
+ ITR2 = 0
+ ELSE IF (TOPSCOHRNT.EQ.1) THEN
+ ITR1 = 1
+ ITR2 = 1
+ ELSE
+ ITR1 = 0
+ ITR2 = 1
+ END IF
+ ELSE
+ RDEST = RDEST2
+ CDEST = CDEST2
+ ITC1 = 0
+ ITC2 = 0
+ END IF
+ IF( RDEST.GE.P0(IGR) .OR. CDEST.GE.Q0(IGR) ) THEN
+ NSKIP = NSKIP + 1
+ GOTO 50
+ END IF
+*
+ IF( MYROW.EQ.RDEST .AND. MYCOL.EQ.CDEST ) THEN
+ LDA = LDADST
+ ELSE
+ LDA = LDASRC
+ END IF
+ VALPTR = APTR + IPOST + N * LDA
+ IF( VERB .GT. 1 ) THEN
+ IF( IAM .EQ. 0 ) THEN
+ WRITE(OUTNUM, 6000)
+ $ TESTNUM, 'RUNNING', SCOPE, TOP, M, N,
+ $ LDASRC, LDADST, LDI, RDEST2, CDEST2,
+ $ NPROW, NPCOL
+ END IF
+ END IF
+*
+* If I am in scope
+*
+ TESTOK = .TRUE.
+ IF( INGRID ) THEN
+ IF( (MYROW.EQ.RDEST .AND. SCOPE.EQ.'R') .OR.
+ $ (MYCOL.EQ.CDEST .AND. SCOPE.EQ.'C') .OR.
+ $ (SCOPE .EQ. 'A') ) THEN
+*
+ K = NERR
+ DO 40 ITR = ITR1, ITR2
+ CALL BLACS_SET(CONTEXT, 15, ITR)
+ DO 35 ITC = ITC1, ITC2
+ CALL BLACS_SET(CONTEXT, 16, ITC)
+ DO 30 J = ISTART, ISTOP
+ IF( J.EQ.0) GOTO 30
+ IF( SETWHAT.NE.0 )
+ $ CALL BLACS_SET(CONTEXT, SETWHAT, J)
+*
+*
+* generate and pad matrix A
+*
+ CALL SINITMAT('G','-', M, N, MEM(PREAPTR),
+ $ LDA, IPRE, IPOST,
+ $ CHECKVAL, TESTNUM,
+ $ MYROW, MYCOL )
+*
+* If they exist, pad RA and CA arrays
+*
+ IF( LDI .NE. -1 ) THEN
+ DO 15 I = 1, N*LDI + IPRE + IPOST
+ RMEM(I) = ICHECKVAL
+ CMEM(I) = ICHECKVAL
+ 15 CONTINUE
+ RAPTR = 1 + IPRE
+ CAPTR = 1 + IPRE
+ ELSE
+ DO 20 I = 1, IPRE+IPOST
+ RMEM(I) = ICHECKVAL
+ CMEM(I) = ICHECKVAL
+ 20 CONTINUE
+ RAPTR = 1
+ CAPTR = 1
+ END IF
+*
+ CALL SGAMX2D(CONTEXT, SCOPE, TOP, M, N,
+ $ MEM(APTR), LDA, RMEM(RAPTR),
+ $ CMEM(CAPTR), LDI,
+ $ RDEST2, CDEST2)
+*
+* If I've got the answer, check for errors in
+* matrix or padding
+*
+ IF( (MYROW.EQ.RDEST .AND. MYCOL.EQ.CDEST)
+ $ .OR. ALLRCV ) THEN
+ CALL SCHKPAD('G','-', M, N,
+ $ MEM(PREAPTR), LDA, RDEST,
+ $ CDEST, MYROW, MYCOL,
+ $ IPRE, IPOST, CHECKVAL,
+ $ TESTNUM, MAXERR, NERR,
+ $ MEM(ERRIPTR),MEM(ERRDPTR))
+ CALL SCHKAMX(SCOPE, CONTEXT, M, N,
+ $ MEM(APTR), LDA,
+ $ RMEM(RAPTR), CMEM(CAPTR),
+ $ LDI, TESTNUM, MAXERR,NERR,
+ $ MEM(ERRIPTR),MEM(ERRDPTR),
+ $ ISEED, MEM(VALPTR))
+ CALL SRCCHK(IPRE, IPOST, ICHECKVAL,
+ $ M, N, RMEM, CMEM, LDI,
+ $ MYROW, MYCOL, TESTNUM,
+ $ MAXERR, NERR,
+ $ MEM(ERRIPTR), MEM(ERRDPTR))
+ END IF
+ 30 CONTINUE
+ CALL BLACS_SET(CONTEXT, 16, 0)
+ 35 CONTINUE
+ CALL BLACS_SET(CONTEXT, 15, 0)
+ 40 CONTINUE
+ TESTOK = ( K .EQ. NERR )
+ END IF
+ END IF
+*
+ IF( VERB .GT. 1 ) THEN
+ I = NERR
+ CALL SBTCHECKIN(0, OUTNUM, MAXERR, NERR,
+ $ MEM(ERRIPTR), MEM(ERRDPTR), ISEED)
+ IF( IAM .EQ. 0 ) THEN
+ IF( TESTOK .AND. NERR.EQ.I ) THEN
+ WRITE(OUTNUM,6000)TESTNUM,'PASSED ',
+ $ SCOPE, TOP, M, N, LDASRC,
+ $ LDADST, LDI, RDEST2, CDEST2,
+ $ NPROW, NPCOL
+ ELSE
+ NFAIL = NFAIL + 1
+ WRITE(OUTNUM,6000)TESTNUM,'FAILED ',
+ $ SCOPE, TOP, M, N, LDASRC,
+ $ LDADST, LDI, RDEST2, CDEST2,
+ $ NPROW, NPCOL
+ END IF
+ END IF
+*
+* Once we've printed out errors, can re-use buf space
+*
+ NERR = 0
+ END IF
+ 50 CONTINUE
+ 60 CONTINUE
+ 70 CONTINUE
+ 80 CONTINUE
+ 90 CONTINUE
+*
+ IF( VERB .LT. 2 ) THEN
+ NFAIL = TESTNUM
+ CALL SBTCHECKIN( NFAIL, OUTNUM, MAXERR, NERR, MEM(ERRIPTR),
+ $ MEM(ERRDPTR), ISEED )
+ END IF
+ IF( IAM .EQ. 0 ) THEN
+ IF( VERB .GT. 1 ) WRITE(OUTNUM,*) ' '
+ IF( NFAIL+NSKIP .EQ. 0 ) THEN
+ WRITE(OUTNUM, 7000 ) TESTNUM
+ ELSE
+ WRITE(OUTNUM, 8000 ) TESTNUM, TESTNUM-NSKIP-NFAIL,
+ $ NSKIP, NFAIL
+ END IF
+ END IF
+*
+* Log whether their were any failures
+*
+ TESTOK = ALLPASS( (NFAIL.EQ.0) )
+*
+ 1000 FORMAT('REAL AMX TESTS: BEGIN.' )
+ 2000 FORMAT(1X,A7,3X,10I6)
+ 3000 FORMAT(1X,A7,3X,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1,
+ $ 5X,A1,5X,A1)
+ 4000 FORMAT(' TEST# STATUS SCOPE TOP M N LDAS LDAD LDI ',
+ $ 'RDEST CDEST P Q')
+ 5000 FORMAT(' ----- ------- ----- --- ----- ----- ----- ----- ----- ',
+ $ '----- ----- ---- ----')
+ 6000 FORMAT(I6,1X,A7,5X,A1,3X,A1,7I6,2I5)
+ 7000 FORMAT('REAL AMX TESTS: PASSED ALL',
+ $ I5, ' TESTS.')
+ 8000 FORMAT('REAL AMX TESTS:',I5,' TESTS;',I5,' PASSED,',
+ $ I5,' SKIPPED,',I5,' FAILED.')
+*
+ RETURN
+*
+* End of STESTAMX.
+*
+ END
+*
+ SUBROUTINE SRCCHK( IPRE, IPOST, PADVAL, M, N, RA, CA, LDI, MYROW,
+ $ MYCOL, TESTNUM, MAXERR, NERR,
+ $ ERRIBUF, ERRDBUF )
+*
+* .. Scalar Arguments ..
+ INTEGER IPRE, IPOST, PADVAL, M, N, LDI, MYROW, MYCOL, TESTNUM
+ INTEGER MAXERR, NERR
+* ..
+* .. Array Arguments ..
+ INTEGER RA(*), CA(*), ERRIBUF(6, MAXERR)
+ REAL ERRDBUF(2, MAXERR)
+* ..
+* .. Parameters ..
+ INTEGER ERR_PRE, ERR_POST, ERR_GAP, ERR_TRI, ERR_MAT
+ PARAMETER( ERR_PRE = 1, ERR_POST = 2, ERR_GAP = 3, ERR_TRI = 4 )
+ PARAMETER( ERR_MAT = 5 )
+* ..
+* .. External Functions ..
+ INTEGER IBTNPROCS
+ EXTERNAL IBTNPROCS
+* ..
+* .. Local Scalars ..
+ INTEGER I, J, K, IAM
+* ..
+* .. Executable Statements ..
+*
+ IAM = MYROW * IBTNPROCS() + MYCOL
+*
+* Check pre padding
+*
+ IF( LDI .NE. -1 ) THEN
+ IF( IPRE .GT. 0 ) THEN
+ DO 10 I = 1, IPRE
+ IF( RA(I) .NE. PADVAL ) THEN
+ NERR = NERR + 1
+ IF( NERR .LE. MAXERR ) THEN
+ ERRIBUF(1, NERR) = TESTNUM
+ ERRIBUF(2, NERR) = LDI
+ ERRIBUF(3, NERR) = IAM
+ ERRIBUF(4, NERR) = I
+ ERRIBUF(5, NERR) = IPRE - I + 1
+ ERRIBUF(6, NERR) = -ERR_PRE
+ ERRDBUF(1, NERR) = REAL( RA(I) )
+ ERRDBUF(2, NERR) = REAL( PADVAL )
+ END IF
+ ENDIF
+ IF( CA(I) .NE. PADVAL ) THEN
+ NERR = NERR + 1
+ IF( NERR .LE. MAXERR ) THEN
+ ERRIBUF(1, NERR) = TESTNUM
+ ERRIBUF(2, NERR) = LDI
+ ERRIBUF(3, NERR) = IAM
+ ERRIBUF(4, NERR) = I
+ ERRIBUF(5, NERR) = IPRE - I + 1
+ ERRIBUF(6, NERR) = -10 - ERR_PRE
+ ERRDBUF(1, NERR) = REAL( CA(I) )
+ ERRDBUF(2, NERR) = REAL( PADVAL )
+ END IF
+ ENDIF
+ 10 CONTINUE
+ END IF
+*
+* Check post padding
+*
+ IF( IPOST .GT. 0 ) THEN
+ K = IPRE + LDI*N
+ DO 20 I = K+1, K+IPOST
+ IF( RA(I) .NE. PADVAL ) THEN
+ NERR = NERR + 1
+ IF( NERR .LE. MAXERR ) THEN
+ ERRIBUF(1, NERR) = TESTNUM
+ ERRIBUF(2, NERR) = LDI
+ ERRIBUF(3, NERR) = IAM
+ ERRIBUF(4, NERR) = I - K
+ ERRIBUF(5, NERR) = I
+ ERRIBUF(6, NERR) = -ERR_POST
+ ERRDBUF(1, NERR) = REAL( RA(I) )
+ ERRDBUF(2, NERR) = REAL( PADVAL )
+ END IF
+ ENDIF
+ IF( CA(I) .NE. PADVAL ) THEN
+ NERR = NERR + 1
+ IF( NERR .LE. MAXERR ) THEN
+ ERRIBUF(1, NERR) = TESTNUM
+ ERRIBUF(2, NERR) = LDI
+ ERRIBUF(3, NERR) = IAM
+ ERRIBUF(4, NERR) = I - K
+ ERRIBUF(5, NERR) = I
+ ERRIBUF(6, NERR) = -10 - ERR_POST
+ ERRDBUF(1, NERR) = REAL( CA(I) )
+ ERRDBUF(2, NERR) = REAL( PADVAL )
+ END IF
+ ENDIF
+ 20 CONTINUE
+ END IF
+*
+* Check all (LDI-M) gaps
+*
+ IF( LDI .GT. M ) THEN
+ K = IPRE + M + 1
+ DO 40 J = 1, N
+ DO 30 I = M+1, LDI
+ K = IPRE + (J-1)*LDI + I
+ IF( RA(K) .NE. PADVAL) THEN
+ NERR = NERR + 1
+ IF( NERR .LE. MAXERR ) THEN
+ ERRIBUF(1, NERR) = TESTNUM
+ ERRIBUF(2, NERR) = LDI
+ ERRIBUF(3, NERR) = IAM
+ ERRIBUF(4, NERR) = I
+ ERRIBUF(5, NERR) = J
+ ERRIBUF(6, NERR) = -ERR_GAP
+ ERRDBUF(1, NERR) = REAL( RA(K) )
+ ERRDBUF(2, NERR) = REAL( PADVAL )
+ END IF
+ END IF
+ IF( CA(K) .NE. PADVAL) THEN
+ NERR = NERR + 1
+ IF( NERR .LE. MAXERR ) THEN
+ ERRIBUF(1, NERR) = TESTNUM
+ ERRIBUF(2, NERR) = LDI
+ ERRIBUF(3, NERR) = IAM
+ ERRIBUF(4, NERR) = I
+ ERRIBUF(5, NERR) = J
+ ERRIBUF(6, NERR) = -10 - ERR_GAP
+ ERRDBUF(1, NERR) = REAL( CA(K) )
+ ERRDBUF(2, NERR) = REAL( PADVAL )
+ END IF
+ END IF
+ 30 CONTINUE
+ 40 CONTINUE
+ END IF
+*
+* if RA and CA don't exist, buffs better be untouched
+*
+ ELSE
+ DO 50 I = 1, IPRE+IPOST
+ IF( RA(I) .NE. PADVAL) THEN
+ NERR = NERR + 1
+ IF( NERR .LE. MAXERR ) THEN
+ ERRIBUF(1, NERR) = TESTNUM
+ ERRIBUF(2, NERR) = LDI
+ ERRIBUF(3, NERR) = IAM
+ ERRIBUF(4, NERR) = I
+ ERRIBUF(5, NERR) = IPRE+IPOST
+ ERRIBUF(6, NERR) = -ERR_PRE
+ ERRDBUF(1, NERR) = REAL( RA(I) )
+ ERRDBUF(2, NERR) = REAL( PADVAL )
+ END IF
+ END IF
+ IF( CA(I) .NE. PADVAL) THEN
+ NERR = NERR + 1
+ IF( NERR .LE. MAXERR ) THEN
+ ERRIBUF(1, NERR) = TESTNUM
+ ERRIBUF(2, NERR) = LDI
+ ERRIBUF(3, NERR) = IAM
+ ERRIBUF(4, NERR) = I
+ ERRIBUF(5, NERR) = IPRE+IPOST
+ ERRIBUF(6, NERR) = -10 - ERR_PRE
+ ERRDBUF(1, NERR) = REAL( CA(I) )
+ ERRDBUF(2, NERR) = REAL( PADVAL )
+ END IF
+ END IF
+ 50 CONTINUE
+ ENDIF
+*
+ RETURN
+ END
+*
+ SUBROUTINE SCHKAMX( SCOPE, ICTXT, M, N, A, LDA, RA, CA, LDI,
+ $ TESTNUM, MAXERR, NERR, ERRIBUF, ERRDBUF,
+ $ ISEED, VALS )
+*
+* .. Scalar Arguments ..
+ CHARACTER*1 SCOPE
+ INTEGER ICTXT, M, N, LDA, LDI, TESTNUM, MAXERR, NERR
+* ..
+* .. Array Arguments ..
+ INTEGER RA(*), CA(*), ERRIBUF(6, MAXERR), ISEED(*)
+ REAL A(LDA,*), ERRDBUF(2, MAXERR), VALS(*)
+* ..
+* .. External Functions ..
+ INTEGER IBTMYPROC, IBTNPROCS, IBTSPNUM
+ REAL SBTEPS, SBTABS
+ REAL SBTRAN
+ EXTERNAL IBTMYPROC, IBTNPROCS, IBTSPNUM, SBTRAN, SBTEPS, SBTABS
+* ..
+* .. External Subroutines ..
+ EXTERNAL IBTSPCOORD
+* ..
+* .. Local Scalars ..
+ LOGICAL ERROR
+ INTEGER NPROCS, NNODES, NPROW, NPCOL, MYROW, MYCOL, RAMX, CAMX
+ INTEGER IAMX, I, J, K, H, DEST, NODE
+ REAL EPS
+* ..
+* .. Executable Statements ..
+*
+ NPROCS = IBTNPROCS()
+ EPS = SBTEPS()
+ CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL )
+ DEST = MYROW*NPROCS + MYCOL
+*
+* Set up seeds to match those used by each proc's genmat call
+*
+ IF( SCOPE .EQ. 'R' ) THEN
+ NNODES = NPCOL
+ DO 10 I = 0, NNODES-1
+ NODE = MYROW * NPROCS + I
+ ISEED(I*4+1) = MOD( 1002 + TESTNUM*5 + NODE*3, 4096 )
+ ISEED(I*4+2) = MOD( 2027 + TESTNUM*7 + NODE, 4096 )
+ ISEED(I*4+3) = MOD( 1234 + TESTNUM + NODE*3, 4096 )
+ ISEED(I*4+4) = MOD( 4311 + TESTNUM*10 + NODE*2, 4096 )
+ 10 CONTINUE
+ ELSE IF( SCOPE .EQ. 'C' ) THEN
+ NNODES = NPROW
+ DO 20 I = 0, NNODES-1
+ NODE = I * NPROCS + MYCOL
+ ISEED(I*4+1) = MOD( 1002 + TESTNUM*5 + NODE*3, 4096 )
+ ISEED(I*4+2) = MOD( 2027 + TESTNUM*7 + NODE, 4096 )
+ ISEED(I*4+3) = MOD( 1234 + TESTNUM + NODE*3, 4096 )
+ ISEED(I*4+4) = MOD( 4311 + TESTNUM*10 + NODE*2, 4096 )
+ 20 CONTINUE
+ ELSE
+ NNODES = NPROW * NPCOL
+ DO 30 I = 0, NNODES-1
+ NODE = (I / NPCOL) * NPROCS + MOD(I, NPCOL)
+ ISEED(I*4+1) = MOD( 1002 + TESTNUM*5 + NODE*3, 4096 )
+ ISEED(I*4+2) = MOD( 2027 + TESTNUM*7 + NODE, 4096 )
+ ISEED(I*4+3) = MOD( 1234 + TESTNUM + NODE*3, 4096 )
+ ISEED(I*4+4) = MOD( 4311 + TESTNUM*10 + NODE*2, 4096 )
+ 30 CONTINUE
+ END IF
+*
+ DO 100 J = 1, N
+ DO 90 I = 1, M
+ H = (J-1)*LDI + I
+ VALS(1) = SBTRAN( ISEED )
+ IAMX = 1
+ IF( NNODES .GT. 1 ) THEN
+ DO 40 K = 1, NNODES-1
+ VALS(K+1) = SBTRAN( ISEED(K*4+1) )
+ IF( SBTABS( VALS(K+1) ) .GT. SBTABS( VALS(IAMX) ) )
+ $ IAMX = K + 1
+ 40 CONTINUE
+ END IF
+*
+* If BLACS have not returned same value we've chosen
+*
+ IF( A(I,J) .NE. VALS(IAMX) ) THEN
+*
+* If we have RA and CA arrays
+*
+ IF( LDI .NE. -1 ) THEN
+*
+* Any number having the same absolute value is a valid max
+*
+ K = IBTSPNUM( SCOPE, RA(H), CA(H), NPCOL ) + 1
+ IF( K.GT.0 .AND. K.LE.NNODES ) THEN
+ ERROR = SBTABS( VALS(K) ).NE.SBTABS( VALS(IAMX) )
+ IF( .NOT.ERROR ) IAMX = K
+ ELSE
+ ERROR = .TRUE.
+ END IF
+ ELSE
+*
+* Error if BLACS answer not same absolute value, or if it
+* was not really in the numbers being compared
+*
+ ERROR = ( SBTABS( A(I,J) ) .NE. SBTABS( VALS(IAMX) ) )
+ IF( .NOT.ERROR ) THEN
+ DO 50 K = 1, NNODES
+ IF( VALS(K) .EQ. A(I,J) ) GOTO 60
+ 50 CONTINUE
+ ERROR = .TRUE.
+ 60 CONTINUE
+ ENDIF
+ END IF
+*
+* If the value is in error
+*
+ IF( ERROR ) THEN
+ NERR = NERR + 1
+ ERRIBUF(1, NERR) = TESTNUM
+ ERRIBUF(2, NERR) = NNODES
+ ERRIBUF(3, NERR) = DEST
+ ERRIBUF(4, NERR) = I
+ ERRIBUF(5, NERR) = J
+ ERRIBUF(6, NERR) = 5
+ ERRDBUF(1, NERR) = A(I,J)
+ ERRDBUF(2, NERR) = VALS(IAMX)
+ END IF
+ END IF
+*
+* If they are defined, make sure coordinate entries are OK
+*
+ IF( LDI .NE. -1 ) THEN
+ K = IBTSPNUM( SCOPE, RA(H), CA(H), NPCOL ) + 1
+ IF( K.NE.IAMX ) THEN
+*
+* Make sure more than one proc doesn't have exact same value
+* (and therefore there may be more than one valid coordinate
+* for a single value)
+*
+ IF( K.GT.NNODES .OR. K.LT.1 ) THEN
+ ERROR = .TRUE.
+ ELSE
+ ERROR = ( VALS(K) .NE. VALS(IAMX) )
+ END IF
+ IF( ERROR ) THEN
+ CALL IBTSPCOORD( SCOPE, IAMX-1, MYROW, MYCOL,
+ $ NPCOL, RAMX, CAMX )
+ IF( RAMX .NE. RA(H) ) THEN
+ NERR = NERR + 1
+ ERRIBUF(1, NERR) = TESTNUM
+ ERRIBUF(2, NERR) = NNODES
+ ERRIBUF(3, NERR) = DEST
+ ERRIBUF(4, NERR) = I
+ ERRIBUF(5, NERR) = J
+ ERRIBUF(6, NERR) = -5
+ ERRDBUF(1, NERR) = RA(H)
+ ERRDBUF(2, NERR) = RAMX
+ END IF
+ IF( CAMX .NE. CA(H) ) THEN
+ NERR = NERR + 1
+ ERRIBUF(1, NERR) = TESTNUM
+ ERRIBUF(2, NERR) = NNODES
+ ERRIBUF(3, NERR) = DEST
+ ERRIBUF(4, NERR) = I
+ ERRIBUF(5, NERR) = J
+ ERRIBUF(6, NERR) = -15
+ ERRDBUF(1, NERR) = CA(H)
+ ERRDBUF(2, NERR) = CAMX
+ END IF
+ END IF
+ END IF
+ END IF
+ 90 CONTINUE
+ 100 CONTINUE
+*
+ RETURN
+*
+* End of SCHKAMX
+*
+ END
+*
+*
+ SUBROUTINE DAMXTEST( OUTNUM, VERB, TOPSREPEAT, TOPSCOHRNT, NSCOPE,
+ $ SCOPE0, NTOP, TOP0, NMAT, M0, N0, LDAS0,
+ $ LDAD0, LDI0, NDEST, RDEST0, CDEST0, NGRID,
+ $ CONTEXT0, P0, Q0, ISEED, RMEM, CMEM, RCLEN,
+ $ MEM, MEMLEN )
+*
+* -- BLACS tester (version 1.0) --
+* University of Tennessee
+* December 15, 1994
+*
+*
+* .. Scalar Arguments ..
+ INTEGER MEMLEN, NDEST, NGRID, NMAT, NSCOPE, NTOP, OUTNUM, RCLEN,
+ $ TOPSCOHRNT, TOPSREPEAT, VERB
+* ..
+* .. Array Arguments ..
+ CHARACTER*1 SCOPE0(NSCOPE), TOP0(NTOP)
+ INTEGER M0(NMAT), N0(NMAT), LDAS0(NMAT), LDAD0(NMAT), LDI0(NMAT)
+ INTEGER RDEST0(NDEST), CDEST0(NDEST), CONTEXT0(NGRID)
+ INTEGER P0(NGRID), Q0(NGRID), ISEED(*), RMEM(RCLEN), CMEM(RCLEN)
+ DOUBLE PRECISION MEM(MEMLEN)
+* ..
+*
+* Purpose
+* =======
+* DTESTAMX: Test double precision AMX COMBINE
+*
+* Arguments
+* =========
+* OUTNUM (input) INTEGER
+* The device number to write output to.
+*
+* VERB (input) INTEGER
+* The level of verbosity (how much printing to do).
+*
+* NSCOPE (input) INTEGER
+* The number of scopes to be tested.
+*
+* SCOPE0 (input) CHARACTER*1 array of dimension (NSCOPE)
+* Values of the scopes to be tested.
+*
+* NTOP (input) INTEGER
+* The number of topologies to be tested.
+*
+* TOP0 (input) CHARACTER*1 array of dimension (NTOP)
+* Values of the topologies to be tested.
+*
+* NMAT (input) INTEGER
+* The number of matrices to be tested.
+*
+* M0 (input) INTEGER array of dimension (NMAT)
+* Values of M to be tested.
+*
+* M0 (input) INTEGER array of dimension (NMAT)
+* Values of M to be tested.
+*
+* N0 (input) INTEGER array of dimension (NMAT)
+* Values of N to be tested.
+*
+* LDAS0 (input) INTEGER array of dimension (NMAT)
+* Values of LDAS (leading dimension of A on source process)
+* to be tested.
+*
+* LDAD0 (input) INTEGER array of dimension (NMAT)
+* Values of LDAD (leading dimension of A on destination
+* process) to be tested.
+* LDI0 (input) INTEGER array of dimension (NMAT)
+* Values of LDI (leading dimension of RA/CA) to be tested.
+* If LDI == -1, these RA/CA should not be accessed.
+*
+* NDEST (input) INTEGER
+* The number of destinations to be tested.
+*
+* RDEST0 (input) INTEGER array of dimension (NNDEST)
+* Values of RDEST (row coordinate of destination) to be
+* tested.
+*
+* CDEST0 (input) INTEGER array of dimension (NNDEST)
+* Values of CDEST (column coordinate of destination) to be
+* tested.
+*
+* NGRID (input) INTEGER
+* The number of process grids to be tested.
+*
+* CONTEXT0 (input) INTEGER array of dimension (NGRID)
+* The BLACS context handles corresponding to the grids.
+*
+* P0 (input) INTEGER array of dimension (NGRID)
+* Values of P (number of process rows, NPROW).
+*
+* Q0 (input) INTEGER array of dimension (NGRID)
+* Values of Q (number of process columns, NPCOL).
+*
+* ISEED (workspace) INTEGER array of dimension ( MAX(NPROCS, NTESTS) )
+* Workspace used to hold each process's random number SEED.
+* This requires NPROCS (number of processor) elements.
+* If VERB < 2, this workspace also serves to indicate which
+* tests fail. This requires workspace of NTESTS
+* (number of tests performed).
+*
+* RMEM (workspace) INTEGER array of dimension (RCLEN)
+* Used for all RA arrays, and their pre and post padding.
+*
+* CMEM (workspace) INTEGER array of dimension (RCLEN)
+* Used for all CA arrays, and their pre and post padding.
+*
+* RCLEN (input) INTEGER
+* The length, in elements, of RMEM and CMEM.
+*
+* MEM (workspace) DOUBLE PRECISION array of dimension (MEMLEN)
+* Used for all other workspaces, including the matrix A,
+* and its pre and post padding.
+*
+* MEMLEN (input) INTEGER
+* The length, in elements, of MEM.
+*
+* =====================================================================
+*
+* .. External Functions ..
+ LOGICAL ALLPASS, LSAME
+ INTEGER IBTMYPROC, IBTNPROCS, IBTSIZEOF
+ EXTERNAL ALLPASS, LSAME, IBTMYPROC, IBTNPROCS, IBTSIZEOF
+* ..
+* .. External Subroutines ..
+ EXTERNAL BLACS_GRIDINFO, DGAMX2D
+ EXTERNAL DINITMAT, DCHKPAD, DBTCHECKIN
+* ..
+* .. Local Scalars ..
+ CHARACTER*1 SCOPE, TOP
+ LOGICAL INGRID, TESTOK, ALLRCV
+ INTEGER APTR, CAPTR, CDEST, CDEST2, CONTEXT, DSIZE, ERRDPTR,
+ $ ERRIPTR, I, IAM, ICHECKVAL, IDE, IGR, IMA, IPAD, IPOST,
+ $ IPRE, ISC, ISIZE, ISTART, ISTOP, ITC, ITC1, ITC2, ITO,
+ $ ITR, ITR1, ITR2, J, K, LDA, LDADST, LDASRC, LDI, M,
+ $ MAXERR, MYCOL, MYROW, N, NERR, NFAIL, NPCOL, NPROW, NSKIP,
+ $ PREAPTR, RAPTR, RDEST, RDEST2, SETWHAT, TESTNUM, VALPTR
+ DOUBLE PRECISION CHECKVAL
+* ..
+* .. Executable Statements ..
+*
+* Choose padding value, and make it unique
+*
+ CHECKVAL = -0.81D0
+ IAM = IBTMYPROC()
+ CHECKVAL = IAM * CHECKVAL
+ ISIZE = IBTSIZEOF('I')
+ DSIZE = IBTSIZEOF('D')
+ ICHECKVAL = -IAM
+*
+* Verify file parameters
+*
+ IF( IAM .EQ. 0 ) THEN
+ WRITE(OUTNUM, *) ' '
+ WRITE(OUTNUM, *) ' '
+ WRITE(OUTNUM, 1000 )
+ IF( VERB .GT. 0 ) THEN
+ WRITE(OUTNUM,*) ' '
+ WRITE(OUTNUM, 2000) 'NSCOPE:', NSCOPE
+ WRITE(OUTNUM, 3000) ' SCOPE:', ( SCOPE0(I), I = 1, NSCOPE )
+ WRITE(OUTNUM, 2000) 'TReps :', TOPSREPEAT
+ WRITE(OUTNUM, 2000) 'TCohr :', TOPSCOHRNT
+ WRITE(OUTNUM, 2000) 'NTOP :', NTOP
+ WRITE(OUTNUM, 3000) ' TOP :', ( TOP0(I), I = 1, NTOP )
+ WRITE(OUTNUM, 2000) 'NMAT :', NMAT
+ WRITE(OUTNUM, 2000) ' M :', ( M0(I), I = 1, NMAT )
+ WRITE(OUTNUM, 2000) ' N :', ( N0(I), I = 1, NMAT )
+ WRITE(OUTNUM, 2000) ' LDAS :', ( LDAS0(I), I = 1, NMAT )
+ WRITE(OUTNUM, 2000) ' LDAD :', ( LDAD0(I), I = 1, NMAT )
+ WRITE(OUTNUM, 2000) ' LDI :', ( LDI0(I), I = 1, NMAT )
+ WRITE(OUTNUM, 2000) 'NDEST :', NDEST
+ WRITE(OUTNUM, 2000) ' RDEST:',( RDEST0(I), I = 1, NDEST )
+ WRITE(OUTNUM, 2000) ' CDEST:',( CDEST0(I), I = 1, NDEST )
+ WRITE(OUTNUM, 2000) 'NGRIDS:', NGRID
+ WRITE(OUTNUM, 2000) ' P :', ( P0(I), I = 1, NGRID )
+ WRITE(OUTNUM, 2000) ' Q :', ( Q0(I), I = 1, NGRID )
+ WRITE(OUTNUM, 2000) 'VERB :', VERB
+ WRITE(OUTNUM,*) ' '
+ END IF
+ IF( VERB .GT. 1 ) THEN
+ WRITE(OUTNUM,4000)
+ WRITE(OUTNUM,5000)
+ END IF
+ END IF
+ IF (TOPSREPEAT.EQ.0) THEN
+ ITR1 = 0
+ ITR2 = 0
+ ELSE IF (TOPSREPEAT.EQ.1) THEN
+ ITR1 = 1
+ ITR2 = 1
+ ELSE
+ ITR1 = 0
+ ITR2 = 1
+ END IF
+*
+* Find biggest matrix, so we know where to stick error info
+*
+ I = 0
+ DO 10 IMA = 1, NMAT
+ IPAD = 4 * M0(IMA)
+ K = N0(IMA) * MAX0( LDAS0(IMA), LDAD0(IMA) ) + IPAD
+ IF( K .GT. I ) I = K
+ 10 CONTINUE
+ I = I + IBTNPROCS()
+ MAXERR = ( DSIZE * (MEMLEN-I) ) / ( DSIZE*2 + ISIZE*6 )
+ IF( MAXERR .LT. 1 ) THEN
+ WRITE(OUTNUM,*) 'ERROR: Not enough memory to run MAX tests.'
+ CALL BLACS_ABORT(-1, 1)
+ END IF
+ ERRDPTR = I + 1
+ ERRIPTR = ERRDPTR + MAXERR
+ NERR = 0
+ TESTNUM = 0
+ NFAIL = 0
+ NSKIP = 0
+*
+* Loop over grids of matrix
+*
+ DO 90 IGR = 1, NGRID
+*
+* allocate process grid for the next batch of tests
+*
+ CONTEXT = CONTEXT0(IGR)
+ CALL BLACS_GRIDINFO( CONTEXT, NPROW, NPCOL, MYROW, MYCOL )
+ INGRID = ( (MYROW.LT.NPROW) .AND. (MYCOL.LT.NPCOL) )
+*
+ DO 80 ISC = 1, NSCOPE
+ SCOPE = SCOPE0(ISC)
+ DO 70 ITO = 1, NTOP
+ TOP = TOP0(ITO)
+*
+* If testing multiring ('M') or general tree ('T'), need to
+* loop over calls to BLACS_SET to do full test
+*
+ IF( LSAME(TOP, 'M') ) THEN
+ SETWHAT = 13
+ IF( SCOPE .EQ. 'R' ) THEN
+ ISTART = -(NPCOL - 1)
+ ISTOP = -ISTART
+ ELSE IF (SCOPE .EQ. 'C') THEN
+ ISTART = -(NPROW - 1)
+ ISTOP = -ISTART
+ ELSE
+ ISTART = -(NPROW*NPCOL - 1)
+ ISTOP = -ISTART
+ ENDIF
+ ELSE IF( LSAME(TOP, 'T') ) THEN
+ SETWHAT = 14
+ ISTART = 1
+ IF( SCOPE .EQ. 'R' ) THEN
+ ISTOP = NPCOL - 1
+ ELSE IF (SCOPE .EQ. 'C') THEN
+ ISTOP = NPROW - 1
+ ELSE
+ ISTOP = NPROW*NPCOL - 1
+ ENDIF
+ ELSE
+ SETWHAT = 0
+ ISTART = 1
+ ISTOP = 1
+ ENDIF
+ DO 60 IMA = 1, NMAT
+ M = M0(IMA)
+ N = N0(IMA)
+ LDASRC = LDAS0(IMA)
+ LDADST = LDAD0(IMA)
+ LDI = LDI0(IMA)
+ IPRE = 2 * M
+ IPOST = IPRE
+ PREAPTR = 1
+ APTR = PREAPTR + IPRE
+*
+ DO 50 IDE = 1, NDEST
+ TESTNUM = TESTNUM + 1
+ RDEST2 = RDEST0(IDE)
+ CDEST2 = CDEST0(IDE)
+*
+* If everyone gets the answer, create some bogus rdest/cdest
+* so IF's are easier
+*
+ ALLRCV = ( (RDEST2.EQ.-1) .OR. (CDEST2.EQ.-1) )
+ IF( ALLRCV ) THEN
+ RDEST = NPROW - 1
+ CDEST = NPCOL - 1
+ IF (TOPSCOHRNT.EQ.0) THEN
+ ITR1 = 0
+ ITR2 = 0
+ ELSE IF (TOPSCOHRNT.EQ.1) THEN
+ ITR1 = 1
+ ITR2 = 1
+ ELSE
+ ITR1 = 0
+ ITR2 = 1
+ END IF
+ ELSE
+ RDEST = RDEST2
+ CDEST = CDEST2
+ ITC1 = 0
+ ITC2 = 0
+ END IF
+ IF( RDEST.GE.P0(IGR) .OR. CDEST.GE.Q0(IGR) ) THEN
+ NSKIP = NSKIP + 1
+ GOTO 50
+ END IF
+*
+ IF( MYROW.EQ.RDEST .AND. MYCOL.EQ.CDEST ) THEN
+ LDA = LDADST
+ ELSE
+ LDA = LDASRC
+ END IF
+ VALPTR = APTR + IPOST + N * LDA
+ IF( VERB .GT. 1 ) THEN
+ IF( IAM .EQ. 0 ) THEN
+ WRITE(OUTNUM, 6000)
+ $ TESTNUM, 'RUNNING', SCOPE, TOP, M, N,
+ $ LDASRC, LDADST, LDI, RDEST2, CDEST2,
+ $ NPROW, NPCOL
+ END IF
+ END IF
+*
+* If I am in scope
+*
+ TESTOK = .TRUE.
+ IF( INGRID ) THEN
+ IF( (MYROW.EQ.RDEST .AND. SCOPE.EQ.'R') .OR.
+ $ (MYCOL.EQ.CDEST .AND. SCOPE.EQ.'C') .OR.
+ $ (SCOPE .EQ. 'A') ) THEN
+*
+ K = NERR
+ DO 40 ITR = ITR1, ITR2
+ CALL BLACS_SET(CONTEXT, 15, ITR)
+ DO 35 ITC = ITC1, ITC2
+ CALL BLACS_SET(CONTEXT, 16, ITC)
+ DO 30 J = ISTART, ISTOP
+ IF( J.EQ.0) GOTO 30
+ IF( SETWHAT.NE.0 )
+ $ CALL BLACS_SET(CONTEXT, SETWHAT, J)
+*
+*
+* generate and pad matrix A
+*
+ CALL DINITMAT('G','-', M, N, MEM(PREAPTR),
+ $ LDA, IPRE, IPOST,
+ $ CHECKVAL, TESTNUM,
+ $ MYROW, MYCOL )
+*
+* If they exist, pad RA and CA arrays
+*
+ IF( LDI .NE. -1 ) THEN
+ DO 15 I = 1, N*LDI + IPRE + IPOST
+ RMEM(I) = ICHECKVAL
+ CMEM(I) = ICHECKVAL
+ 15 CONTINUE
+ RAPTR = 1 + IPRE
+ CAPTR = 1 + IPRE
+ ELSE
+ DO 20 I = 1, IPRE+IPOST
+ RMEM(I) = ICHECKVAL
+ CMEM(I) = ICHECKVAL
+ 20 CONTINUE
+ RAPTR = 1
+ CAPTR = 1
+ END IF
+*
+ CALL DGAMX2D(CONTEXT, SCOPE, TOP, M, N,
+ $ MEM(APTR), LDA, RMEM(RAPTR),
+ $ CMEM(CAPTR), LDI,
+ $ RDEST2, CDEST2)
+*
+* If I've got the answer, check for errors in
+* matrix or padding
+*
+ IF( (MYROW.EQ.RDEST .AND. MYCOL.EQ.CDEST)
+ $ .OR. ALLRCV ) THEN
+ CALL DCHKPAD('G','-', M, N,
+ $ MEM(PREAPTR), LDA, RDEST,
+ $ CDEST, MYROW, MYCOL,
+ $ IPRE, IPOST, CHECKVAL,
+ $ TESTNUM, MAXERR, NERR,
+ $ MEM(ERRIPTR),MEM(ERRDPTR))
+ CALL DCHKAMX(SCOPE, CONTEXT, M, N,
+ $ MEM(APTR), LDA,
+ $ RMEM(RAPTR), CMEM(CAPTR),
+ $ LDI, TESTNUM, MAXERR,NERR,
+ $ MEM(ERRIPTR),MEM(ERRDPTR),
+ $ ISEED, MEM(VALPTR))
+ CALL DRCCHK(IPRE, IPOST, ICHECKVAL,
+ $ M, N, RMEM, CMEM, LDI,
+ $ MYROW, MYCOL, TESTNUM,
+ $ MAXERR, NERR,
+ $ MEM(ERRIPTR), MEM(ERRDPTR))
+ END IF
+ 30 CONTINUE
+ CALL BLACS_SET(CONTEXT, 16, 0)
+ 35 CONTINUE
+ CALL BLACS_SET(CONTEXT, 15, 0)
+ 40 CONTINUE
+ TESTOK = ( K .EQ. NERR )
+ END IF
+ END IF
+*
+ IF( VERB .GT. 1 ) THEN
+ I = NERR
+ CALL DBTCHECKIN(0, OUTNUM, MAXERR, NERR,
+ $ MEM(ERRIPTR), MEM(ERRDPTR), ISEED)
+ IF( IAM .EQ. 0 ) THEN
+ IF( TESTOK .AND. NERR.EQ.I ) THEN
+ WRITE(OUTNUM,6000)TESTNUM,'PASSED ',
+ $ SCOPE, TOP, M, N, LDASRC,
+ $ LDADST, LDI, RDEST2, CDEST2,
+ $ NPROW, NPCOL
+ ELSE
+ NFAIL = NFAIL + 1
+ WRITE(OUTNUM,6000)TESTNUM,'FAILED ',
+ $ SCOPE, TOP, M, N, LDASRC,
+ $ LDADST, LDI, RDEST2, CDEST2,
+ $ NPROW, NPCOL
+ END IF
+ END IF
+*
+* Once we've printed out errors, can re-use buf space
+*
+ NERR = 0
+ END IF
+ 50 CONTINUE
+ 60 CONTINUE
+ 70 CONTINUE
+ 80 CONTINUE
+ 90 CONTINUE
+*
+ IF( VERB .LT. 2 ) THEN
+ NFAIL = TESTNUM
+ CALL DBTCHECKIN( NFAIL, OUTNUM, MAXERR, NERR, MEM(ERRIPTR),
+ $ MEM(ERRDPTR), ISEED )
+ END IF
+ IF( IAM .EQ. 0 ) THEN
+ IF( VERB .GT. 1 ) WRITE(OUTNUM,*) ' '
+ IF( NFAIL+NSKIP .EQ. 0 ) THEN
+ WRITE(OUTNUM, 7000 ) TESTNUM
+ ELSE
+ WRITE(OUTNUM, 8000 ) TESTNUM, TESTNUM-NSKIP-NFAIL,
+ $ NSKIP, NFAIL
+ END IF
+ END IF
+*
+* Log whether their were any failures
+*
+ TESTOK = ALLPASS( (NFAIL.EQ.0) )
+*
+ 1000 FORMAT('DOUBLE PRECISION AMX TESTS: BEGIN.' )
+ 2000 FORMAT(1X,A7,3X,10I6)
+ 3000 FORMAT(1X,A7,3X,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1,
+ $ 5X,A1,5X,A1)
+ 4000 FORMAT(' TEST# STATUS SCOPE TOP M N LDAS LDAD LDI ',
+ $ 'RDEST CDEST P Q')
+ 5000 FORMAT(' ----- ------- ----- --- ----- ----- ----- ----- ----- ',
+ $ '----- ----- ---- ----')
+ 6000 FORMAT(I6,1X,A7,5X,A1,3X,A1,7I6,2I5)
+ 7000 FORMAT('DOUBLE PRECISION AMX TESTS: PASSED ALL',
+ $ I5, ' TESTS.')
+ 8000 FORMAT('DOUBLE PRECISION AMX TESTS:',I5,' TESTS;',I5,' PASSED,',
+ $ I5,' SKIPPED,',I5,' FAILED.')
+*
+ RETURN
+*
+* End of DTESTAMX.
+*
+ END
+*
+ SUBROUTINE DRCCHK( IPRE, IPOST, PADVAL, M, N, RA, CA, LDI, MYROW,
+ $ MYCOL, TESTNUM, MAXERR, NERR,
+ $ ERRIBUF, ERRDBUF )
+*
+* .. Scalar Arguments ..
+ INTEGER IPRE, IPOST, PADVAL, M, N, LDI, MYROW, MYCOL, TESTNUM
+ INTEGER MAXERR, NERR
+* ..
+* .. Array Arguments ..
+ INTEGER RA(*), CA(*), ERRIBUF(6, MAXERR)
+ DOUBLE PRECISION ERRDBUF(2, MAXERR)
+* ..
+* .. Parameters ..
+ INTEGER ERR_PRE, ERR_POST, ERR_GAP, ERR_TRI, ERR_MAT
+ PARAMETER( ERR_PRE = 1, ERR_POST = 2, ERR_GAP = 3, ERR_TRI = 4 )
+ PARAMETER( ERR_MAT = 5 )
+* ..
+* .. External Functions ..
+ INTEGER IBTNPROCS
+ EXTERNAL IBTNPROCS
+* ..
+* .. Local Scalars ..
+ INTEGER I, J, K, IAM
+* ..
+* .. Executable Statements ..
+*
+ IAM = MYROW * IBTNPROCS() + MYCOL
+*
+* Check pre padding
+*
+ IF( LDI .NE. -1 ) THEN
+ IF( IPRE .GT. 0 ) THEN
+ DO 10 I = 1, IPRE
+ IF( RA(I) .NE. PADVAL ) THEN
+ NERR = NERR + 1
+ IF( NERR .LE. MAXERR ) THEN
+ ERRIBUF(1, NERR) = TESTNUM
+ ERRIBUF(2, NERR) = LDI
+ ERRIBUF(3, NERR) = IAM
+ ERRIBUF(4, NERR) = I
+ ERRIBUF(5, NERR) = IPRE - I + 1
+ ERRIBUF(6, NERR) = -ERR_PRE
+ ERRDBUF(1, NERR) = DBLE( RA(I) )
+ ERRDBUF(2, NERR) = DBLE( PADVAL )
+ END IF
+ ENDIF
+ IF( CA(I) .NE. PADVAL ) THEN
+ NERR = NERR + 1
+ IF( NERR .LE. MAXERR ) THEN
+ ERRIBUF(1, NERR) = TESTNUM
+ ERRIBUF(2, NERR) = LDI
+ ERRIBUF(3, NERR) = IAM
+ ERRIBUF(4, NERR) = I
+ ERRIBUF(5, NERR) = IPRE - I + 1
+ ERRIBUF(6, NERR) = -10 - ERR_PRE
+ ERRDBUF(1, NERR) = DBLE( CA(I) )
+ ERRDBUF(2, NERR) = DBLE( PADVAL )
+ END IF
+ ENDIF
+ 10 CONTINUE
+ END IF
+*
+* Check post padding
+*
+ IF( IPOST .GT. 0 ) THEN
+ K = IPRE + LDI*N
+ DO 20 I = K+1, K+IPOST
+ IF( RA(I) .NE. PADVAL ) THEN
+ NERR = NERR + 1
+ IF( NERR .LE. MAXERR ) THEN
+ ERRIBUF(1, NERR) = TESTNUM
+ ERRIBUF(2, NERR) = LDI
+ ERRIBUF(3, NERR) = IAM
+ ERRIBUF(4, NERR) = I - K
+ ERRIBUF(5, NERR) = I
+ ERRIBUF(6, NERR) = -ERR_POST
+ ERRDBUF(1, NERR) = DBLE( RA(I) )
+ ERRDBUF(2, NERR) = DBLE( PADVAL )
+ END IF
+ ENDIF
+ IF( CA(I) .NE. PADVAL ) THEN
+ NERR = NERR + 1
+ IF( NERR .LE. MAXERR ) THEN
+ ERRIBUF(1, NERR) = TESTNUM
+ ERRIBUF(2, NERR) = LDI
+ ERRIBUF(3, NERR) = IAM
+ ERRIBUF(4, NERR) = I - K
+ ERRIBUF(5, NERR) = I
+ ERRIBUF(6, NERR) = -10 - ERR_POST
+ ERRDBUF(1, NERR) = DBLE( CA(I) )
+ ERRDBUF(2, NERR) = DBLE( PADVAL )
+ END IF
+ ENDIF
+ 20 CONTINUE
+ END IF
+*
+* Check all (LDI-M) gaps
+*
+ IF( LDI .GT. M ) THEN
+ K = IPRE + M + 1
+ DO 40 J = 1, N
+ DO 30 I = M+1, LDI
+ K = IPRE + (J-1)*LDI + I
+ IF( RA(K) .NE. PADVAL) THEN
+ NERR = NERR + 1
+ IF( NERR .LE. MAXERR ) THEN
+ ERRIBUF(1, NERR) = TESTNUM
+ ERRIBUF(2, NERR) = LDI
+ ERRIBUF(3, NERR) = IAM
+ ERRIBUF(4, NERR) = I
+ ERRIBUF(5, NERR) = J
+ ERRIBUF(6, NERR) = -ERR_GAP
+ ERRDBUF(1, NERR) = DBLE( RA(K) )
+ ERRDBUF(2, NERR) = DBLE( PADVAL )
+ END IF
+ END IF
+ IF( CA(K) .NE. PADVAL) THEN
+ NERR = NERR + 1
+ IF( NERR .LE. MAXERR ) THEN
+ ERRIBUF(1, NERR) = TESTNUM
+ ERRIBUF(2, NERR) = LDI
+ ERRIBUF(3, NERR) = IAM
+ ERRIBUF(4, NERR) = I
+ ERRIBUF(5, NERR) = J
+ ERRIBUF(6, NERR) = -10 - ERR_GAP
+ ERRDBUF(1, NERR) = DBLE( CA(K) )
+ ERRDBUF(2, NERR) = DBLE( PADVAL )
+ END IF
+ END IF
+ 30 CONTINUE
+ 40 CONTINUE
+ END IF
+*
+* if RA and CA don't exist, buffs better be untouched
+*
+ ELSE
+ DO 50 I = 1, IPRE+IPOST
+ IF( RA(I) .NE. PADVAL) THEN
+ NERR = NERR + 1
+ IF( NERR .LE. MAXERR ) THEN
+ ERRIBUF(1, NERR) = TESTNUM
+ ERRIBUF(2, NERR) = LDI
+ ERRIBUF(3, NERR) = IAM
+ ERRIBUF(4, NERR) = I
+ ERRIBUF(5, NERR) = IPRE+IPOST
+ ERRIBUF(6, NERR) = -ERR_PRE
+ ERRDBUF(1, NERR) = DBLE( RA(I) )
+ ERRDBUF(2, NERR) = DBLE( PADVAL )
+ END IF
+ END IF
+ IF( CA(I) .NE. PADVAL) THEN
+ NERR = NERR + 1
+ IF( NERR .LE. MAXERR ) THEN
+ ERRIBUF(1, NERR) = TESTNUM
+ ERRIBUF(2, NERR) = LDI
+ ERRIBUF(3, NERR) = IAM
+ ERRIBUF(4, NERR) = I
+ ERRIBUF(5, NERR) = IPRE+IPOST
+ ERRIBUF(6, NERR) = -10 - ERR_PRE
+ ERRDBUF(1, NERR) = DBLE( CA(I) )
+ ERRDBUF(2, NERR) = DBLE( PADVAL )
+ END IF
+ END IF
+ 50 CONTINUE
+ ENDIF
+*
+ RETURN
+ END
+*
+ SUBROUTINE DCHKAMX( SCOPE, ICTXT, M, N, A, LDA, RA, CA, LDI,
+ $ TESTNUM, MAXERR, NERR, ERRIBUF, ERRDBUF,
+ $ ISEED, VALS )
+*
+* .. Scalar Arguments ..
+ CHARACTER*1 SCOPE
+ INTEGER ICTXT, M, N, LDA, LDI, TESTNUM, MAXERR, NERR
+* ..
+* .. Array Arguments ..
+ INTEGER RA(*), CA(*), ERRIBUF(6, MAXERR), ISEED(*)
+ DOUBLE PRECISION A(LDA,*), ERRDBUF(2, MAXERR), VALS(*)
+* ..
+* .. External Functions ..
+ INTEGER IBTMYPROC, IBTNPROCS, IBTSPNUM
+ DOUBLE PRECISION DBTEPS, DBTABS
+ DOUBLE PRECISION DBTRAN
+ EXTERNAL IBTMYPROC, IBTNPROCS, IBTSPNUM, DBTRAN, DBTEPS, DBTABS
+* ..
+* .. External Subroutines ..
+ EXTERNAL IBTSPCOORD
+* ..
+* .. Local Scalars ..
+ LOGICAL ERROR
+ INTEGER NPROCS, NNODES, NPROW, NPCOL, MYROW, MYCOL, RAMX, CAMX
+ INTEGER IAMX, I, J, K, H, DEST, NODE
+ DOUBLE PRECISION EPS
+* ..
+* .. Executable Statements ..
+*
+ NPROCS = IBTNPROCS()
+ EPS = DBTEPS()
+ CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL )
+ DEST = MYROW*NPROCS + MYCOL
+*
+* Set up seeds to match those used by each proc's genmat call
+*
+ IF( SCOPE .EQ. 'R' ) THEN
+ NNODES = NPCOL
+ DO 10 I = 0, NNODES-1
+ NODE = MYROW * NPROCS + I
+ ISEED(I*4+1) = MOD( 1002 + TESTNUM*5 + NODE*3, 4096 )
+ ISEED(I*4+2) = MOD( 2027 + TESTNUM*7 + NODE, 4096 )
+ ISEED(I*4+3) = MOD( 1234 + TESTNUM + NODE*3, 4096 )
+ ISEED(I*4+4) = MOD( 4311 + TESTNUM*10 + NODE*2, 4096 )
+ 10 CONTINUE
+ ELSE IF( SCOPE .EQ. 'C' ) THEN
+ NNODES = NPROW
+ DO 20 I = 0, NNODES-1
+ NODE = I * NPROCS + MYCOL
+ ISEED(I*4+1) = MOD( 1002 + TESTNUM*5 + NODE*3, 4096 )
+ ISEED(I*4+2) = MOD( 2027 + TESTNUM*7 + NODE, 4096 )
+ ISEED(I*4+3) = MOD( 1234 + TESTNUM + NODE*3, 4096 )
+ ISEED(I*4+4) = MOD( 4311 + TESTNUM*10 + NODE*2, 4096 )
+ 20 CONTINUE
+ ELSE
+ NNODES = NPROW * NPCOL
+ DO 30 I = 0, NNODES-1
+ NODE = (I / NPCOL) * NPROCS + MOD(I, NPCOL)
+ ISEED(I*4+1) = MOD( 1002 + TESTNUM*5 + NODE*3, 4096 )
+ ISEED(I*4+2) = MOD( 2027 + TESTNUM*7 + NODE, 4096 )
+ ISEED(I*4+3) = MOD( 1234 + TESTNUM + NODE*3, 4096 )
+ ISEED(I*4+4) = MOD( 4311 + TESTNUM*10 + NODE*2, 4096 )
+ 30 CONTINUE
+ END IF
+*
+ DO 100 J = 1, N
+ DO 90 I = 1, M
+ H = (J-1)*LDI + I
+ VALS(1) = DBTRAN( ISEED )
+ IAMX = 1
+ IF( NNODES .GT. 1 ) THEN
+ DO 40 K = 1, NNODES-1
+ VALS(K+1) = DBTRAN( ISEED(K*4+1) )
+ IF( DBTABS( VALS(K+1) ) .GT. DBTABS( VALS(IAMX) ) )
+ $ IAMX = K + 1
+ 40 CONTINUE
+ END IF
+*
+* If BLACS have not returned same value we've chosen
+*
+ IF( A(I,J) .NE. VALS(IAMX) ) THEN
+*
+* If we have RA and CA arrays
+*
+ IF( LDI .NE. -1 ) THEN
+*
+* Any number having the same absolute value is a valid max
+*
+ K = IBTSPNUM( SCOPE, RA(H), CA(H), NPCOL ) + 1
+ IF( K.GT.0 .AND. K.LE.NNODES ) THEN
+ ERROR = DBTABS( VALS(K) ).NE.DBTABS( VALS(IAMX) )
+ IF( .NOT.ERROR ) IAMX = K
+ ELSE
+ ERROR = .TRUE.
+ END IF
+ ELSE
+*
+* Error if BLACS answer not same absolute value, or if it
+* was not really in the numbers being compared
+*
+ ERROR = ( DBTABS( A(I,J) ) .NE. DBTABS( VALS(IAMX) ) )
+ IF( .NOT.ERROR ) THEN
+ DO 50 K = 1, NNODES
+ IF( VALS(K) .EQ. A(I,J) ) GOTO 60
+ 50 CONTINUE
+ ERROR = .TRUE.
+ 60 CONTINUE
+ ENDIF
+ END IF
+*
+* If the value is in error
+*
+ IF( ERROR ) THEN
+ NERR = NERR + 1
+ ERRIBUF(1, NERR) = TESTNUM
+ ERRIBUF(2, NERR) = NNODES
+ ERRIBUF(3, NERR) = DEST
+ ERRIBUF(4, NERR) = I
+ ERRIBUF(5, NERR) = J
+ ERRIBUF(6, NERR) = 5
+ ERRDBUF(1, NERR) = A(I,J)
+ ERRDBUF(2, NERR) = VALS(IAMX)
+ END IF
+ END IF
+*
+* If they are defined, make sure coordinate entries are OK
+*
+ IF( LDI .NE. -1 ) THEN
+ K = IBTSPNUM( SCOPE, RA(H), CA(H), NPCOL ) + 1
+ IF( K.NE.IAMX ) THEN
+*
+* Make sure more than one proc doesn't have exact same value
+* (and therefore there may be more than one valid coordinate
+* for a single value)
+*
+ IF( K.GT.NNODES .OR. K.LT.1 ) THEN
+ ERROR = .TRUE.
+ ELSE
+ ERROR = ( VALS(K) .NE. VALS(IAMX) )
+ END IF
+ IF( ERROR ) THEN
+ CALL IBTSPCOORD( SCOPE, IAMX-1, MYROW, MYCOL,
+ $ NPCOL, RAMX, CAMX )
+ IF( RAMX .NE. RA(H) ) THEN
+ NERR = NERR + 1
+ ERRIBUF(1, NERR) = TESTNUM
+ ERRIBUF(2, NERR) = NNODES
+ ERRIBUF(3, NERR) = DEST
+ ERRIBUF(4, NERR) = I
+ ERRIBUF(5, NERR) = J
+ ERRIBUF(6, NERR) = -5
+ ERRDBUF(1, NERR) = RA(H)
+ ERRDBUF(2, NERR) = RAMX
+ END IF
+ IF( CAMX .NE. CA(H) ) THEN
+ NERR = NERR + 1
+ ERRIBUF(1, NERR) = TESTNUM
+ ERRIBUF(2, NERR) = NNODES
+ ERRIBUF(3, NERR) = DEST
+ ERRIBUF(4, NERR) = I
+ ERRIBUF(5, NERR) = J
+ ERRIBUF(6, NERR) = -15
+ ERRDBUF(1, NERR) = CA(H)
+ ERRDBUF(2, NERR) = CAMX
+ END IF
+ END IF
+ END IF
+ END IF
+ 90 CONTINUE
+ 100 CONTINUE
+*
+ RETURN
+*
+* End of DCHKAMX
+*
+ END
+*
+*
+ SUBROUTINE CAMXTEST( OUTNUM, VERB, TOPSREPEAT, TOPSCOHRNT, NSCOPE,
+ $ SCOPE0, NTOP, TOP0, NMAT, M0, N0, LDAS0,
+ $ LDAD0, LDI0, NDEST, RDEST0, CDEST0, NGRID,
+ $ CONTEXT0, P0, Q0, ISEED, RMEM, CMEM, RCLEN,
+ $ MEM, MEMLEN )
+*
+* -- BLACS tester (version 1.0) --
+* University of Tennessee
+* December 15, 1994
+*
+*
+* .. Scalar Arguments ..
+ INTEGER MEMLEN, NDEST, NGRID, NMAT, NSCOPE, NTOP, OUTNUM, RCLEN,
+ $ TOPSCOHRNT, TOPSREPEAT, VERB
+* ..
+* .. Array Arguments ..
+ CHARACTER*1 SCOPE0(NSCOPE), TOP0(NTOP)
+ INTEGER M0(NMAT), N0(NMAT), LDAS0(NMAT), LDAD0(NMAT), LDI0(NMAT)
+ INTEGER RDEST0(NDEST), CDEST0(NDEST), CONTEXT0(NGRID)
+ INTEGER P0(NGRID), Q0(NGRID), ISEED(*), RMEM(RCLEN), CMEM(RCLEN)
+ COMPLEX MEM(MEMLEN)
+* ..
+*
+* Purpose
+* =======
+* CTESTAMX: Test complex AMX COMBINE
+*
+* Arguments
+* =========
+* OUTNUM (input) INTEGER
+* The device number to write output to.
+*
+* VERB (input) INTEGER
+* The level of verbosity (how much printing to do).
+*
+* NSCOPE (input) INTEGER
+* The number of scopes to be tested.
+*
+* SCOPE0 (input) CHARACTER*1 array of dimension (NSCOPE)
+* Values of the scopes to be tested.
+*
+* NTOP (input) INTEGER
+* The number of topologies to be tested.
+*
+* TOP0 (input) CHARACTER*1 array of dimension (NTOP)
+* Values of the topologies to be tested.
+*
+* NMAT (input) INTEGER
+* The number of matrices to be tested.
+*
+* M0 (input) INTEGER array of dimension (NMAT)
+* Values of M to be tested.
+*
+* M0 (input) INTEGER array of dimension (NMAT)
+* Values of M to be tested.
+*
+* N0 (input) INTEGER array of dimension (NMAT)
+* Values of N to be tested.
+*
+* LDAS0 (input) INTEGER array of dimension (NMAT)
+* Values of LDAS (leading dimension of A on source process)
+* to be tested.
+*
+* LDAD0 (input) INTEGER array of dimension (NMAT)
+* Values of LDAD (leading dimension of A on destination
+* process) to be tested.
+* LDI0 (input) INTEGER array of dimension (NMAT)
+* Values of LDI (leading dimension of RA/CA) to be tested.
+* If LDI == -1, these RA/CA should not be accessed.
+*
+* NDEST (input) INTEGER
+* The number of destinations to be tested.
+*
+* RDEST0 (input) INTEGER array of dimension (NNDEST)
+* Values of RDEST (row coordinate of destination) to be
+* tested.
+*
+* CDEST0 (input) INTEGER array of dimension (NNDEST)
+* Values of CDEST (column coordinate of destination) to be
+* tested.
+*
+* NGRID (input) INTEGER
+* The number of process grids to be tested.
+*
+* CONTEXT0 (input) INTEGER array of dimension (NGRID)
+* The BLACS context handles corresponding to the grids.
+*
+* P0 (input) INTEGER array of dimension (NGRID)
+* Values of P (number of process rows, NPROW).
+*
+* Q0 (input) INTEGER array of dimension (NGRID)
+* Values of Q (number of process columns, NPCOL).
+*
+* ISEED (workspace) INTEGER array of dimension ( MAX(NPROCS, NTESTS) )
+* Workspace used to hold each process's random number SEED.
+* This requires NPROCS (number of processor) elements.
+* If VERB < 2, this workspace also serves to indicate which
+* tests fail. This requires workspace of NTESTS
+* (number of tests performed).
+*
+* RMEM (workspace) INTEGER array of dimension (RCLEN)
+* Used for all RA arrays, and their pre and post padding.
+*
+* CMEM (workspace) INTEGER array of dimension (RCLEN)
+* Used for all CA arrays, and their pre and post padding.
+*
+* RCLEN (input) INTEGER
+* The length, in elements, of RMEM and CMEM.
+*
+* MEM (workspace) COMPLEX array of dimension (MEMLEN)
+* Used for all other workspaces, including the matrix A,
+* and its pre and post padding.
+*
+* MEMLEN (input) INTEGER
+* The length, in elements, of MEM.
+*
+* =====================================================================
+*
+* .. External Functions ..
+ LOGICAL ALLPASS, LSAME
+ INTEGER IBTMYPROC, IBTNPROCS, IBTSIZEOF
+ EXTERNAL ALLPASS, LSAME, IBTMYPROC, IBTNPROCS, IBTSIZEOF
+* ..
+* .. External Subroutines ..
+ EXTERNAL BLACS_GRIDINFO, CGAMX2D
+ EXTERNAL CINITMAT, CCHKPAD, CBTCHECKIN
+* ..
+* .. Local Scalars ..
+ CHARACTER*1 SCOPE, TOP
+ LOGICAL INGRID, TESTOK, ALLRCV
+ INTEGER APTR, CAPTR, CDEST, CDEST2, CONTEXT, CSIZE, ERRDPTR,
+ $ ERRIPTR, I, IAM, ICHECKVAL, IDE, IGR, IMA, IPAD, IPOST,
+ $ IPRE, ISC, ISIZE, ISTART, ISTOP, ITC, ITC1, ITC2, ITO,
+ $ ITR, ITR1, ITR2, J, K, LDA, LDADST, LDASRC, LDI, M,
+ $ MAXERR, MYCOL, MYROW, N, NERR, NFAIL, NPCOL, NPROW, NSKIP,
+ $ PREAPTR, RAPTR, RDEST, RDEST2, SETWHAT, TESTNUM, VALPTR
+ COMPLEX CHECKVAL
+* ..
+* .. Executable Statements ..
+*
+* Choose padding value, and make it unique
+*
+ CHECKVAL = CMPLX( -0.91E0, -0.71E0 )
+ IAM = IBTMYPROC()
+ CHECKVAL = IAM * CHECKVAL
+ ISIZE = IBTSIZEOF('I')
+ CSIZE = IBTSIZEOF('C')
+ ICHECKVAL = -IAM
+*
+* Verify file parameters
+*
+ IF( IAM .EQ. 0 ) THEN
+ WRITE(OUTNUM, *) ' '
+ WRITE(OUTNUM, *) ' '
+ WRITE(OUTNUM, 1000 )
+ IF( VERB .GT. 0 ) THEN
+ WRITE(OUTNUM,*) ' '
+ WRITE(OUTNUM, 2000) 'NSCOPE:', NSCOPE
+ WRITE(OUTNUM, 3000) ' SCOPE:', ( SCOPE0(I), I = 1, NSCOPE )
+ WRITE(OUTNUM, 2000) 'TReps :', TOPSREPEAT
+ WRITE(OUTNUM, 2000) 'TCohr :', TOPSCOHRNT
+ WRITE(OUTNUM, 2000) 'NTOP :', NTOP
+ WRITE(OUTNUM, 3000) ' TOP :', ( TOP0(I), I = 1, NTOP )
+ WRITE(OUTNUM, 2000) 'NMAT :', NMAT
+ WRITE(OUTNUM, 2000) ' M :', ( M0(I), I = 1, NMAT )
+ WRITE(OUTNUM, 2000) ' N :', ( N0(I), I = 1, NMAT )
+ WRITE(OUTNUM, 2000) ' LDAS :', ( LDAS0(I), I = 1, NMAT )
+ WRITE(OUTNUM, 2000) ' LDAD :', ( LDAD0(I), I = 1, NMAT )
+ WRITE(OUTNUM, 2000) ' LDI :', ( LDI0(I), I = 1, NMAT )
+ WRITE(OUTNUM, 2000) 'NDEST :', NDEST
+ WRITE(OUTNUM, 2000) ' RDEST:',( RDEST0(I), I = 1, NDEST )
+ WRITE(OUTNUM, 2000) ' CDEST:',( CDEST0(I), I = 1, NDEST )
+ WRITE(OUTNUM, 2000) 'NGRIDS:', NGRID
+ WRITE(OUTNUM, 2000) ' P :', ( P0(I), I = 1, NGRID )
+ WRITE(OUTNUM, 2000) ' Q :', ( Q0(I), I = 1, NGRID )
+ WRITE(OUTNUM, 2000) 'VERB :', VERB
+ WRITE(OUTNUM,*) ' '
+ END IF
+ IF( VERB .GT. 1 ) THEN
+ WRITE(OUTNUM,4000)
+ WRITE(OUTNUM,5000)
+ END IF
+ END IF
+ IF (TOPSREPEAT.EQ.0) THEN
+ ITR1 = 0
+ ITR2 = 0
+ ELSE IF (TOPSREPEAT.EQ.1) THEN
+ ITR1 = 1
+ ITR2 = 1
+ ELSE
+ ITR1 = 0
+ ITR2 = 1
+ END IF
+*
+* Find biggest matrix, so we know where to stick error info
+*
+ I = 0
+ DO 10 IMA = 1, NMAT
+ IPAD = 4 * M0(IMA)
+ K = N0(IMA) * MAX0( LDAS0(IMA), LDAD0(IMA) ) + IPAD
+ IF( K .GT. I ) I = K
+ 10 CONTINUE
+ I = I + IBTNPROCS()
+ MAXERR = ( CSIZE * (MEMLEN-I) ) / ( CSIZE*2 + ISIZE*6 )
+ IF( MAXERR .LT. 1 ) THEN
+ WRITE(OUTNUM,*) 'ERROR: Not enough memory to run MAX tests.'
+ CALL BLACS_ABORT(-1, 1)
+ END IF
+ ERRDPTR = I + 1
+ ERRIPTR = ERRDPTR + MAXERR
+ NERR = 0
+ TESTNUM = 0
+ NFAIL = 0
+ NSKIP = 0
+*
+* Loop over grids of matrix
+*
+ DO 90 IGR = 1, NGRID
+*
+* allocate process grid for the next batch of tests
+*
+ CONTEXT = CONTEXT0(IGR)
+ CALL BLACS_GRIDINFO( CONTEXT, NPROW, NPCOL, MYROW, MYCOL )
+ INGRID = ( (MYROW.LT.NPROW) .AND. (MYCOL.LT.NPCOL) )
+*
+ DO 80 ISC = 1, NSCOPE
+ SCOPE = SCOPE0(ISC)
+ DO 70 ITO = 1, NTOP
+ TOP = TOP0(ITO)
+*
+* If testing multiring ('M') or general tree ('T'), need to
+* loop over calls to BLACS_SET to do full test
+*
+ IF( LSAME(TOP, 'M') ) THEN
+ SETWHAT = 13
+ IF( SCOPE .EQ. 'R' ) THEN
+ ISTART = -(NPCOL - 1)
+ ISTOP = -ISTART
+ ELSE IF (SCOPE .EQ. 'C') THEN
+ ISTART = -(NPROW - 1)
+ ISTOP = -ISTART
+ ELSE
+ ISTART = -(NPROW*NPCOL - 1)
+ ISTOP = -ISTART
+ ENDIF
+ ELSE IF( LSAME(TOP, 'T') ) THEN
+ SETWHAT = 14
+ ISTART = 1
+ IF( SCOPE .EQ. 'R' ) THEN
+ ISTOP = NPCOL - 1
+ ELSE IF (SCOPE .EQ. 'C') THEN
+ ISTOP = NPROW - 1
+ ELSE
+ ISTOP = NPROW*NPCOL - 1
+ ENDIF
+ ELSE
+ SETWHAT = 0
+ ISTART = 1
+ ISTOP = 1
+ ENDIF
+ DO 60 IMA = 1, NMAT
+ M = M0(IMA)
+ N = N0(IMA)
+ LDASRC = LDAS0(IMA)
+ LDADST = LDAD0(IMA)
+ LDI = LDI0(IMA)
+ IPRE = 2 * M
+ IPOST = IPRE
+ PREAPTR = 1
+ APTR = PREAPTR + IPRE
+*
+ DO 50 IDE = 1, NDEST
+ TESTNUM = TESTNUM + 1
+ RDEST2 = RDEST0(IDE)
+ CDEST2 = CDEST0(IDE)
+*
+* If everyone gets the answer, create some bogus rdest/cdest
+* so IF's are easier
+*
+ ALLRCV = ( (RDEST2.EQ.-1) .OR. (CDEST2.EQ.-1) )
+ IF( ALLRCV ) THEN
+ RDEST = NPROW - 1
+ CDEST = NPCOL - 1
+ IF (TOPSCOHRNT.EQ.0) THEN
+ ITR1 = 0
+ ITR2 = 0
+ ELSE IF (TOPSCOHRNT.EQ.1) THEN
+ ITR1 = 1
+ ITR2 = 1
+ ELSE
+ ITR1 = 0
+ ITR2 = 1
+ END IF
+ ELSE
+ RDEST = RDEST2
+ CDEST = CDEST2
+ ITC1 = 0
+ ITC2 = 0
+ END IF
+ IF( RDEST.GE.P0(IGR) .OR. CDEST.GE.Q0(IGR) ) THEN
+ NSKIP = NSKIP + 1
+ GOTO 50
+ END IF
+*
+ IF( MYROW.EQ.RDEST .AND. MYCOL.EQ.CDEST ) THEN
+ LDA = LDADST
+ ELSE
+ LDA = LDASRC
+ END IF
+ VALPTR = APTR + IPOST + N * LDA
+ IF( VERB .GT. 1 ) THEN
+ IF( IAM .EQ. 0 ) THEN
+ WRITE(OUTNUM, 6000)
+ $ TESTNUM, 'RUNNING', SCOPE, TOP, M, N,
+ $ LDASRC, LDADST, LDI, RDEST2, CDEST2,
+ $ NPROW, NPCOL
+ END IF
+ END IF
+*
+* If I am in scope
+*
+ TESTOK = .TRUE.
+ IF( INGRID ) THEN
+ IF( (MYROW.EQ.RDEST .AND. SCOPE.EQ.'R') .OR.
+ $ (MYCOL.EQ.CDEST .AND. SCOPE.EQ.'C') .OR.
+ $ (SCOPE .EQ. 'A') ) THEN
+*
+ K = NERR
+ DO 40 ITR = ITR1, ITR2
+ CALL BLACS_SET(CONTEXT, 15, ITR)
+ DO 35 ITC = ITC1, ITC2
+ CALL BLACS_SET(CONTEXT, 16, ITC)
+ DO 30 J = ISTART, ISTOP
+ IF( J.EQ.0) GOTO 30
+ IF( SETWHAT.NE.0 )
+ $ CALL BLACS_SET(CONTEXT, SETWHAT, J)
+*
+*
+* generate and pad matrix A
+*
+ CALL CINITMAT('G','-', M, N, MEM(PREAPTR),
+ $ LDA, IPRE, IPOST,
+ $ CHECKVAL, TESTNUM,
+ $ MYROW, MYCOL )
+*
+* If they exist, pad RA and CA arrays
+*
+ IF( LDI .NE. -1 ) THEN
+ DO 15 I = 1, N*LDI + IPRE + IPOST
+ RMEM(I) = ICHECKVAL
+ CMEM(I) = ICHECKVAL
+ 15 CONTINUE
+ RAPTR = 1 + IPRE
+ CAPTR = 1 + IPRE
+ ELSE
+ DO 20 I = 1, IPRE+IPOST
+ RMEM(I) = ICHECKVAL
+ CMEM(I) = ICHECKVAL
+ 20 CONTINUE
+ RAPTR = 1
+ CAPTR = 1
+ END IF
+*
+ CALL CGAMX2D(CONTEXT, SCOPE, TOP, M, N,
+ $ MEM(APTR), LDA, RMEM(RAPTR),
+ $ CMEM(CAPTR), LDI,
+ $ RDEST2, CDEST2)
+*
+* If I've got the answer, check for errors in
+* matrix or padding
+*
+ IF( (MYROW.EQ.RDEST .AND. MYCOL.EQ.CDEST)
+ $ .OR. ALLRCV ) THEN
+ CALL CCHKPAD('G','-', M, N,
+ $ MEM(PREAPTR), LDA, RDEST,
+ $ CDEST, MYROW, MYCOL,
+ $ IPRE, IPOST, CHECKVAL,
+ $ TESTNUM, MAXERR, NERR,
+ $ MEM(ERRIPTR),MEM(ERRDPTR))
+ CALL CCHKAMX(SCOPE, CONTEXT, M, N,
+ $ MEM(APTR), LDA,
+ $ RMEM(RAPTR), CMEM(CAPTR),
+ $ LDI, TESTNUM, MAXERR,NERR,
+ $ MEM(ERRIPTR),MEM(ERRDPTR),
+ $ ISEED, MEM(VALPTR))
+ CALL CRCCHK(IPRE, IPOST, ICHECKVAL,
+ $ M, N, RMEM, CMEM, LDI,
+ $ MYROW, MYCOL, TESTNUM,
+ $ MAXERR, NERR,
+ $ MEM(ERRIPTR), MEM(ERRDPTR))
+ END IF
+ 30 CONTINUE
+ CALL BLACS_SET(CONTEXT, 16, 0)
+ 35 CONTINUE
+ CALL BLACS_SET(CONTEXT, 15, 0)
+ 40 CONTINUE
+ TESTOK = ( K .EQ. NERR )
+ END IF
+ END IF
+*
+ IF( VERB .GT. 1 ) THEN
+ I = NERR
+ CALL CBTCHECKIN(0, OUTNUM, MAXERR, NERR,
+ $ MEM(ERRIPTR), MEM(ERRDPTR), ISEED)
+ IF( IAM .EQ. 0 ) THEN
+ IF( TESTOK .AND. NERR.EQ.I ) THEN
+ WRITE(OUTNUM,6000)TESTNUM,'PASSED ',
+ $ SCOPE, TOP, M, N, LDASRC,
+ $ LDADST, LDI, RDEST2, CDEST2,
+ $ NPROW, NPCOL
+ ELSE
+ NFAIL = NFAIL + 1
+ WRITE(OUTNUM,6000)TESTNUM,'FAILED ',
+ $ SCOPE, TOP, M, N, LDASRC,
+ $ LDADST, LDI, RDEST2, CDEST2,
+ $ NPROW, NPCOL
+ END IF
+ END IF
+*
+* Once we've printed out errors, can re-use buf space
+*
+ NERR = 0
+ END IF
+ 50 CONTINUE
+ 60 CONTINUE
+ 70 CONTINUE
+ 80 CONTINUE
+ 90 CONTINUE
+*
+ IF( VERB .LT. 2 ) THEN
+ NFAIL = TESTNUM
+ CALL CBTCHECKIN( NFAIL, OUTNUM, MAXERR, NERR, MEM(ERRIPTR),
+ $ MEM(ERRDPTR), ISEED )
+ END IF
+ IF( IAM .EQ. 0 ) THEN
+ IF( VERB .GT. 1 ) WRITE(OUTNUM,*) ' '
+ IF( NFAIL+NSKIP .EQ. 0 ) THEN
+ WRITE(OUTNUM, 7000 ) TESTNUM
+ ELSE
+ WRITE(OUTNUM, 8000 ) TESTNUM, TESTNUM-NSKIP-NFAIL,
+ $ NSKIP, NFAIL
+ END IF
+ END IF
+*
+* Log whether their were any failures
+*
+ TESTOK = ALLPASS( (NFAIL.EQ.0) )
+*
+ 1000 FORMAT('COMPLEX AMX TESTS: BEGIN.' )
+ 2000 FORMAT(1X,A7,3X,10I6)
+ 3000 FORMAT(1X,A7,3X,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1,
+ $ 5X,A1,5X,A1)
+ 4000 FORMAT(' TEST# STATUS SCOPE TOP M N LDAS LDAD LDI ',
+ $ 'RDEST CDEST P Q')
+ 5000 FORMAT(' ----- ------- ----- --- ----- ----- ----- ----- ----- ',
+ $ '----- ----- ---- ----')
+ 6000 FORMAT(I6,1X,A7,5X,A1,3X,A1,7I6,2I5)
+ 7000 FORMAT('COMPLEX AMX TESTS: PASSED ALL',
+ $ I5, ' TESTS.')
+ 8000 FORMAT('COMPLEX AMX TESTS:',I5,' TESTS;',I5,' PASSED,',
+ $ I5,' SKIPPED,',I5,' FAILED.')
+*
+ RETURN
+*
+* End of CTESTAMX.
+*
+ END
+*
+ SUBROUTINE CRCCHK( IPRE, IPOST, PADVAL, M, N, RA, CA, LDI, MYROW,
+ $ MYCOL, TESTNUM, MAXERR, NERR,
+ $ ERRIBUF, ERRDBUF )
+*
+* .. Scalar Arguments ..
+ INTEGER IPRE, IPOST, PADVAL, M, N, LDI, MYROW, MYCOL, TESTNUM
+ INTEGER MAXERR, NERR
+* ..
+* .. Array Arguments ..
+ INTEGER RA(*), CA(*), ERRIBUF(6, MAXERR)
+ COMPLEX ERRDBUF(2, MAXERR)
+* ..
+* .. Parameters ..
+ INTEGER ERR_PRE, ERR_POST, ERR_GAP, ERR_TRI, ERR_MAT
+ PARAMETER( ERR_PRE = 1, ERR_POST = 2, ERR_GAP = 3, ERR_TRI = 4 )
+ PARAMETER( ERR_MAT = 5 )
+* ..
+* .. External Functions ..
+ INTEGER IBTNPROCS
+ EXTERNAL IBTNPROCS
+* ..
+* .. Local Scalars ..
+ INTEGER I, J, K, IAM
+* ..
+* .. Executable Statements ..
+*
+ IAM = MYROW * IBTNPROCS() + MYCOL
+*
+* Check pre padding
+*
+ IF( LDI .NE. -1 ) THEN
+ IF( IPRE .GT. 0 ) THEN
+ DO 10 I = 1, IPRE
+ IF( RA(I) .NE. PADVAL ) THEN
+ NERR = NERR + 1
+ IF( NERR .LE. MAXERR ) THEN
+ ERRIBUF(1, NERR) = TESTNUM
+ ERRIBUF(2, NERR) = LDI
+ ERRIBUF(3, NERR) = IAM
+ ERRIBUF(4, NERR) = I
+ ERRIBUF(5, NERR) = IPRE - I + 1
+ ERRIBUF(6, NERR) = -ERR_PRE
+ ERRDBUF(1, NERR) = CMPLX( RA(I) )
+ ERRDBUF(2, NERR) = CMPLX( PADVAL )
+ END IF
+ ENDIF
+ IF( CA(I) .NE. PADVAL ) THEN
+ NERR = NERR + 1
+ IF( NERR .LE. MAXERR ) THEN
+ ERRIBUF(1, NERR) = TESTNUM
+ ERRIBUF(2, NERR) = LDI
+ ERRIBUF(3, NERR) = IAM
+ ERRIBUF(4, NERR) = I
+ ERRIBUF(5, NERR) = IPRE - I + 1
+ ERRIBUF(6, NERR) = -10 - ERR_PRE
+ ERRDBUF(1, NERR) = CMPLX( CA(I) )
+ ERRDBUF(2, NERR) = CMPLX( PADVAL )
+ END IF
+ ENDIF
+ 10 CONTINUE
+ END IF
+*
+* Check post padding
+*
+ IF( IPOST .GT. 0 ) THEN
+ K = IPRE + LDI*N
+ DO 20 I = K+1, K+IPOST
+ IF( RA(I) .NE. PADVAL ) THEN
+ NERR = NERR + 1
+ IF( NERR .LE. MAXERR ) THEN
+ ERRIBUF(1, NERR) = TESTNUM
+ ERRIBUF(2, NERR) = LDI
+ ERRIBUF(3, NERR) = IAM
+ ERRIBUF(4, NERR) = I - K
+ ERRIBUF(5, NERR) = I
+ ERRIBUF(6, NERR) = -ERR_POST
+ ERRDBUF(1, NERR) = CMPLX( RA(I) )
+ ERRDBUF(2, NERR) = CMPLX( PADVAL )
+ END IF
+ ENDIF
+ IF( CA(I) .NE. PADVAL ) THEN
+ NERR = NERR + 1
+ IF( NERR .LE. MAXERR ) THEN
+ ERRIBUF(1, NERR) = TESTNUM
+ ERRIBUF(2, NERR) = LDI
+ ERRIBUF(3, NERR) = IAM
+ ERRIBUF(4, NERR) = I - K
+ ERRIBUF(5, NERR) = I
+ ERRIBUF(6, NERR) = -10 - ERR_POST
+ ERRDBUF(1, NERR) = CMPLX( CA(I) )
+ ERRDBUF(2, NERR) = CMPLX( PADVAL )
+ END IF
+ ENDIF
+ 20 CONTINUE
+ END IF
+*
+* Check all (LDI-M) gaps
+*
+ IF( LDI .GT. M ) THEN
+ K = IPRE + M + 1
+ DO 40 J = 1, N
+ DO 30 I = M+1, LDI
+ K = IPRE + (J-1)*LDI + I
+ IF( RA(K) .NE. PADVAL) THEN
+ NERR = NERR + 1
+ IF( NERR .LE. MAXERR ) THEN
+ ERRIBUF(1, NERR) = TESTNUM
+ ERRIBUF(2, NERR) = LDI
+ ERRIBUF(3, NERR) = IAM
+ ERRIBUF(4, NERR) = I
+ ERRIBUF(5, NERR) = J
+ ERRIBUF(6, NERR) = -ERR_GAP
+ ERRDBUF(1, NERR) = CMPLX( RA(K) )
+ ERRDBUF(2, NERR) = CMPLX( PADVAL )
+ END IF
+ END IF
+ IF( CA(K) .NE. PADVAL) THEN
+ NERR = NERR + 1
+ IF( NERR .LE. MAXERR ) THEN
+ ERRIBUF(1, NERR) = TESTNUM
+ ERRIBUF(2, NERR) = LDI
+ ERRIBUF(3, NERR) = IAM
+ ERRIBUF(4, NERR) = I
+ ERRIBUF(5, NERR) = J
+ ERRIBUF(6, NERR) = -10 - ERR_GAP
+ ERRDBUF(1, NERR) = CMPLX( CA(K) )
+ ERRDBUF(2, NERR) = CMPLX( PADVAL )
+ END IF
+ END IF
+ 30 CONTINUE
+ 40 CONTINUE
+ END IF
+*
+* if RA and CA don't exist, buffs better be untouched
+*
+ ELSE
+ DO 50 I = 1, IPRE+IPOST
+ IF( RA(I) .NE. PADVAL) THEN
+ NERR = NERR + 1
+ IF( NERR .LE. MAXERR ) THEN
+ ERRIBUF(1, NERR) = TESTNUM
+ ERRIBUF(2, NERR) = LDI
+ ERRIBUF(3, NERR) = IAM
+ ERRIBUF(4, NERR) = I
+ ERRIBUF(5, NERR) = IPRE+IPOST
+ ERRIBUF(6, NERR) = -ERR_PRE
+ ERRDBUF(1, NERR) = CMPLX( RA(I) )
+ ERRDBUF(2, NERR) = CMPLX( PADVAL )
+ END IF
+ END IF
+ IF( CA(I) .NE. PADVAL) THEN
+ NERR = NERR + 1
+ IF( NERR .LE. MAXERR ) THEN
+ ERRIBUF(1, NERR) = TESTNUM
+ ERRIBUF(2, NERR) = LDI
+ ERRIBUF(3, NERR) = IAM
+ ERRIBUF(4, NERR) = I
+ ERRIBUF(5, NERR) = IPRE+IPOST
+ ERRIBUF(6, NERR) = -10 - ERR_PRE
+ ERRDBUF(1, NERR) = CMPLX( CA(I) )
+ ERRDBUF(2, NERR) = CMPLX( PADVAL )
+ END IF
+ END IF
+ 50 CONTINUE
+ ENDIF
+*
+ RETURN
+ END
+*
+ SUBROUTINE CCHKAMX( SCOPE, ICTXT, M, N, A, LDA, RA, CA, LDI,
+ $ TESTNUM, MAXERR, NERR, ERRIBUF, ERRDBUF,
+ $ ISEED, VALS )
+*
+* .. Scalar Arguments ..
+ CHARACTER*1 SCOPE
+ INTEGER ICTXT, M, N, LDA, LDI, TESTNUM, MAXERR, NERR
+* ..
+* .. Array Arguments ..
+ INTEGER RA(*), CA(*), ERRIBUF(6, MAXERR), ISEED(*)
+ COMPLEX A(LDA,*), ERRDBUF(2, MAXERR), VALS(*)
+* ..
+* .. External Functions ..
+ INTEGER IBTMYPROC, IBTNPROCS, IBTSPNUM
+ REAL SBTEPS, CBTABS
+ COMPLEX CBTRAN
+ EXTERNAL IBTMYPROC, IBTNPROCS, IBTSPNUM, CBTRAN, SBTEPS, CBTABS
+* ..
+* .. External Subroutines ..
+ EXTERNAL IBTSPCOORD
+* ..
+* .. Local Scalars ..
+ LOGICAL ERROR
+ INTEGER NPROCS, NNODES, NPROW, NPCOL, MYROW, MYCOL, RAMX, CAMX
+ INTEGER IAMX, I, J, K, H, DEST, NODE
+ REAL EPS
+* ..
+* .. Executable Statements ..
+*
+ NPROCS = IBTNPROCS()
+ EPS = SBTEPS()
+ CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL )
+ DEST = MYROW*NPROCS + MYCOL
+*
+* Set up seeds to match those used by each proc's genmat call
+*
+ IF( SCOPE .EQ. 'R' ) THEN
+ NNODES = NPCOL
+ DO 10 I = 0, NNODES-1
+ NODE = MYROW * NPROCS + I
+ ISEED(I*4+1) = MOD( 1002 + TESTNUM*5 + NODE*3, 4096 )
+ ISEED(I*4+2) = MOD( 2027 + TESTNUM*7 + NODE, 4096 )
+ ISEED(I*4+3) = MOD( 1234 + TESTNUM + NODE*3, 4096 )
+ ISEED(I*4+4) = MOD( 4311 + TESTNUM*10 + NODE*2, 4096 )
+ 10 CONTINUE
+ ELSE IF( SCOPE .EQ. 'C' ) THEN
+ NNODES = NPROW
+ DO 20 I = 0, NNODES-1
+ NODE = I * NPROCS + MYCOL
+ ISEED(I*4+1) = MOD( 1002 + TESTNUM*5 + NODE*3, 4096 )
+ ISEED(I*4+2) = MOD( 2027 + TESTNUM*7 + NODE, 4096 )
+ ISEED(I*4+3) = MOD( 1234 + TESTNUM + NODE*3, 4096 )
+ ISEED(I*4+4) = MOD( 4311 + TESTNUM*10 + NODE*2, 4096 )
+ 20 CONTINUE
+ ELSE
+ NNODES = NPROW * NPCOL
+ DO 30 I = 0, NNODES-1
+ NODE = (I / NPCOL) * NPROCS + MOD(I, NPCOL)
+ ISEED(I*4+1) = MOD( 1002 + TESTNUM*5 + NODE*3, 4096 )
+ ISEED(I*4+2) = MOD( 2027 + TESTNUM*7 + NODE, 4096 )
+ ISEED(I*4+3) = MOD( 1234 + TESTNUM + NODE*3, 4096 )
+ ISEED(I*4+4) = MOD( 4311 + TESTNUM*10 + NODE*2, 4096 )
+ 30 CONTINUE
+ END IF
+*
+ DO 100 J = 1, N
+ DO 90 I = 1, M
+ H = (J-1)*LDI + I
+ VALS(1) = CBTRAN( ISEED )
+ IAMX = 1
+ IF( NNODES .GT. 1 ) THEN
+ DO 40 K = 1, NNODES-1
+ VALS(K+1) = CBTRAN( ISEED(K*4+1) )
+ IF( CBTABS( VALS(K+1) ) .GT. CBTABS( VALS(IAMX) ) )
+ $ IAMX = K + 1
+ 40 CONTINUE
+ END IF
+*
+* If BLACS have not returned same value we've chosen
+*
+ IF( A(I,J) .NE. VALS(IAMX) ) THEN
+*
+* If we have RA and CA arrays
+*
+ IF( LDI .NE. -1 ) THEN
+*
+* Any number having the same absolute value is a valid max
+*
+ K = IBTSPNUM( SCOPE, RA(H), CA(H), NPCOL ) + 1
+ IF( K.GT.0 .AND. K.LE.NNODES ) THEN
+ ERROR = ABS( CBTABS(VALS(K)) - CBTABS(VALS(IAMX)) )
+ $ .GT. 3*EPS
+ IF( .NOT.ERROR ) IAMX = K
+ ELSE
+ ERROR = .TRUE.
+ END IF
+ ELSE
+*
+* Error if BLACS answer not same absolute value, or if it
+* was not really in the numbers being compared
+*
+ ERROR = ABS( CBTABS(A(I,J)) - CBTABS(VALS(IAMX)) )
+ $ .GT. 3*EPS
+ IF( .NOT.ERROR ) THEN
+ DO 50 K = 1, NNODES
+ IF( VALS(K) .EQ. A(I,J) ) GOTO 60
+ 50 CONTINUE
+ ERROR = .TRUE.
+ 60 CONTINUE
+ ENDIF
+ END IF
+*
+* If the value is in error
+*
+ IF( ERROR ) THEN
+ NERR = NERR + 1
+ ERRIBUF(1, NERR) = TESTNUM
+ ERRIBUF(2, NERR) = NNODES
+ ERRIBUF(3, NERR) = DEST
+ ERRIBUF(4, NERR) = I
+ ERRIBUF(5, NERR) = J
+ ERRIBUF(6, NERR) = 5
+ ERRDBUF(1, NERR) = A(I,J)
+ ERRDBUF(2, NERR) = VALS(IAMX)
+ END IF
+ END IF
+*
+* If they are defined, make sure coordinate entries are OK
+*
+ IF( LDI .NE. -1 ) THEN
+ K = IBTSPNUM( SCOPE, RA(H), CA(H), NPCOL ) + 1
+ IF( K.NE.IAMX ) THEN
+*
+* Make sure more than one proc doesn't have exact same value
+* (and therefore there may be more than one valid coordinate
+* for a single value)
+*
+ IF( K.GT.NNODES .OR. K.LT.1 ) THEN
+ ERROR = .TRUE.
+ ELSE
+ ERROR = ( VALS(K) .NE. VALS(IAMX) )
+ END IF
+ IF( ERROR ) THEN
+ CALL IBTSPCOORD( SCOPE, IAMX-1, MYROW, MYCOL,
+ $ NPCOL, RAMX, CAMX )
+ IF( RAMX .NE. RA(H) ) THEN
+ NERR = NERR + 1
+ ERRIBUF(1, NERR) = TESTNUM
+ ERRIBUF(2, NERR) = NNODES
+ ERRIBUF(3, NERR) = DEST
+ ERRIBUF(4, NERR) = I
+ ERRIBUF(5, NERR) = J
+ ERRIBUF(6, NERR) = -5
+ ERRDBUF(1, NERR) = RA(H)
+ ERRDBUF(2, NERR) = RAMX
+ END IF
+ IF( CAMX .NE. CA(H) ) THEN
+ NERR = NERR + 1
+ ERRIBUF(1, NERR) = TESTNUM
+ ERRIBUF(2, NERR) = NNODES
+ ERRIBUF(3, NERR) = DEST
+ ERRIBUF(4, NERR) = I
+ ERRIBUF(5, NERR) = J
+ ERRIBUF(6, NERR) = -15
+ ERRDBUF(1, NERR) = CA(H)
+ ERRDBUF(2, NERR) = CAMX
+ END IF
+ END IF
+ END IF
+ END IF
+ 90 CONTINUE
+ 100 CONTINUE
+*
+ RETURN
+*
+* End of CCHKAMX
+*
+ END
+*
+*
+ SUBROUTINE ZAMXTEST( OUTNUM, VERB, TOPSREPEAT, TOPSCOHRNT, NSCOPE,
+ $ SCOPE0, NTOP, TOP0, NMAT, M0, N0, LDAS0,
+ $ LDAD0, LDI0, NDEST, RDEST0, CDEST0, NGRID,
+ $ CONTEXT0, P0, Q0, ISEED, RMEM, CMEM, RCLEN,
+ $ MEM, MEMLEN )
+*
+* -- BLACS tester (version 1.0) --
+* University of Tennessee
+* December 15, 1994
+*
+*
+* .. Scalar Arguments ..
+ INTEGER MEMLEN, NDEST, NGRID, NMAT, NSCOPE, NTOP, OUTNUM, RCLEN,
+ $ TOPSCOHRNT, TOPSREPEAT, VERB
+* ..
+* .. Array Arguments ..
+ CHARACTER*1 SCOPE0(NSCOPE), TOP0(NTOP)
+ INTEGER M0(NMAT), N0(NMAT), LDAS0(NMAT), LDAD0(NMAT), LDI0(NMAT)
+ INTEGER RDEST0(NDEST), CDEST0(NDEST), CONTEXT0(NGRID)
+ INTEGER P0(NGRID), Q0(NGRID), ISEED(*), RMEM(RCLEN), CMEM(RCLEN)
+ DOUBLE COMPLEX MEM(MEMLEN)
+* ..
+*
+* Purpose
+* =======
+* ZTESTAMX: Test double complex AMX COMBINE
+*
+* Arguments
+* =========
+* OUTNUM (input) INTEGER
+* The device number to write output to.
+*
+* VERB (input) INTEGER
+* The level of verbosity (how much printing to do).
+*
+* NSCOPE (input) INTEGER
+* The number of scopes to be tested.
+*
+* SCOPE0 (input) CHARACTER*1 array of dimension (NSCOPE)
+* Values of the scopes to be tested.
+*
+* NTOP (input) INTEGER
+* The number of topologies to be tested.
+*
+* TOP0 (input) CHARACTER*1 array of dimension (NTOP)
+* Values of the topologies to be tested.
+*
+* NMAT (input) INTEGER
+* The number of matrices to be tested.
+*
+* M0 (input) INTEGER array of dimension (NMAT)
+* Values of M to be tested.
+*
+* M0 (input) INTEGER array of dimension (NMAT)
+* Values of M to be tested.
+*
+* N0 (input) INTEGER array of dimension (NMAT)
+* Values of N to be tested.
+*
+* LDAS0 (input) INTEGER array of dimension (NMAT)
+* Values of LDAS (leading dimension of A on source process)
+* to be tested.
+*
+* LDAD0 (input) INTEGER array of dimension (NMAT)
+* Values of LDAD (leading dimension of A on destination
+* process) to be tested.
+* LDI0 (input) INTEGER array of dimension (NMAT)
+* Values of LDI (leading dimension of RA/CA) to be tested.
+* If LDI == -1, these RA/CA should not be accessed.
+*
+* NDEST (input) INTEGER
+* The number of destinations to be tested.
+*
+* RDEST0 (input) INTEGER array of dimension (NNDEST)
+* Values of RDEST (row coordinate of destination) to be
+* tested.
+*
+* CDEST0 (input) INTEGER array of dimension (NNDEST)
+* Values of CDEST (column coordinate of destination) to be
+* tested.
+*
+* NGRID (input) INTEGER
+* The number of process grids to be tested.
+*
+* CONTEXT0 (input) INTEGER array of dimension (NGRID)
+* The BLACS context handles corresponding to the grids.
+*
+* P0 (input) INTEGER array of dimension (NGRID)
+* Values of P (number of process rows, NPROW).
+*
+* Q0 (input) INTEGER array of dimension (NGRID)
+* Values of Q (number of process columns, NPCOL).
+*
+* ISEED (workspace) INTEGER array of dimension ( MAX(NPROCS, NTESTS) )
+* Workspace used to hold each process's random number SEED.
+* This requires NPROCS (number of processor) elements.
+* If VERB < 2, this workspace also serves to indicate which
+* tests fail. This requires workspace of NTESTS
+* (number of tests performed).
+*
+* RMEM (workspace) INTEGER array of dimension (RCLEN)
+* Used for all RA arrays, and their pre and post padding.
+*
+* CMEM (workspace) INTEGER array of dimension (RCLEN)
+* Used for all CA arrays, and their pre and post padding.
+*
+* RCLEN (input) INTEGER
+* The length, in elements, of RMEM and CMEM.
+*
+* MEM (workspace) DOUBLE COMPLEX array of dimension (MEMLEN)
+* Used for all other workspaces, including the matrix A,
+* and its pre and post padding.
+*
+* MEMLEN (input) INTEGER
+* The length, in elements, of MEM.
+*
+* =====================================================================
+*
+* .. External Functions ..
+ LOGICAL ALLPASS, LSAME
+ INTEGER IBTMYPROC, IBTNPROCS, IBTSIZEOF
+ EXTERNAL ALLPASS, LSAME, IBTMYPROC, IBTNPROCS, IBTSIZEOF
+* ..
+* .. External Subroutines ..
+ EXTERNAL BLACS_GRIDINFO, ZGAMX2D
+ EXTERNAL ZINITMAT, ZCHKPAD, ZBTCHECKIN
+* ..
+* .. Local Scalars ..
+ CHARACTER*1 SCOPE, TOP
+ LOGICAL INGRID, TESTOK, ALLRCV
+ INTEGER APTR, CAPTR, CDEST, CDEST2, CONTEXT, ERRDPTR, ERRIPTR, I,
+ $ IAM, ICHECKVAL, IDE, IGR, IMA, IPAD, IPOST, IPRE, ISC,
+ $ ISIZE, ISTART, ISTOP, ITC, ITC1, ITC2, ITO, ITR, ITR1,
+ $ ITR2, J, K, LDA, LDADST, LDASRC, LDI, M, MAXERR, MYCOL,
+ $ MYROW, N, NERR, NFAIL, NPCOL, NPROW, NSKIP, PREAPTR,
+ $ RAPTR, RDEST, RDEST2, SETWHAT, TESTNUM, VALPTR, ZSIZE
+ DOUBLE COMPLEX CHECKVAL
+* ..
+* .. Executable Statements ..
+*
+* Choose padding value, and make it unique
+*
+ CHECKVAL = DCMPLX( -9.11D0, -9.21D0 )
+ IAM = IBTMYPROC()
+ CHECKVAL = IAM * CHECKVAL
+ ISIZE = IBTSIZEOF('I')
+ ZSIZE = IBTSIZEOF('Z')
+ ICHECKVAL = -IAM
+*
+* Verify file parameters
+*
+ IF( IAM .EQ. 0 ) THEN
+ WRITE(OUTNUM, *) ' '
+ WRITE(OUTNUM, *) ' '
+ WRITE(OUTNUM, 1000 )
+ IF( VERB .GT. 0 ) THEN
+ WRITE(OUTNUM,*) ' '
+ WRITE(OUTNUM, 2000) 'NSCOPE:', NSCOPE
+ WRITE(OUTNUM, 3000) ' SCOPE:', ( SCOPE0(I), I = 1, NSCOPE )
+ WRITE(OUTNUM, 2000) 'TReps :', TOPSREPEAT
+ WRITE(OUTNUM, 2000) 'TCohr :', TOPSCOHRNT
+ WRITE(OUTNUM, 2000) 'NTOP :', NTOP
+ WRITE(OUTNUM, 3000) ' TOP :', ( TOP0(I), I = 1, NTOP )
+ WRITE(OUTNUM, 2000) 'NMAT :', NMAT
+ WRITE(OUTNUM, 2000) ' M :', ( M0(I), I = 1, NMAT )
+ WRITE(OUTNUM, 2000) ' N :', ( N0(I), I = 1, NMAT )
+ WRITE(OUTNUM, 2000) ' LDAS :', ( LDAS0(I), I = 1, NMAT )
+ WRITE(OUTNUM, 2000) ' LDAD :', ( LDAD0(I), I = 1, NMAT )
+ WRITE(OUTNUM, 2000) ' LDI :', ( LDI0(I), I = 1, NMAT )
+ WRITE(OUTNUM, 2000) 'NDEST :', NDEST
+ WRITE(OUTNUM, 2000) ' RDEST:',( RDEST0(I), I = 1, NDEST )
+ WRITE(OUTNUM, 2000) ' CDEST:',( CDEST0(I), I = 1, NDEST )
+ WRITE(OUTNUM, 2000) 'NGRIDS:', NGRID
+ WRITE(OUTNUM, 2000) ' P :', ( P0(I), I = 1, NGRID )
+ WRITE(OUTNUM, 2000) ' Q :', ( Q0(I), I = 1, NGRID )
+ WRITE(OUTNUM, 2000) 'VERB :', VERB
+ WRITE(OUTNUM,*) ' '
+ END IF
+ IF( VERB .GT. 1 ) THEN
+ WRITE(OUTNUM,4000)
+ WRITE(OUTNUM,5000)
+ END IF
+ END IF
+ IF (TOPSREPEAT.EQ.0) THEN
+ ITR1 = 0
+ ITR2 = 0
+ ELSE IF (TOPSREPEAT.EQ.1) THEN
+ ITR1 = 1
+ ITR2 = 1
+ ELSE
+ ITR1 = 0
+ ITR2 = 1
+ END IF
+*
+* Find biggest matrix, so we know where to stick error info
+*
+ I = 0
+ DO 10 IMA = 1, NMAT
+ IPAD = 4 * M0(IMA)
+ K = N0(IMA) * MAX0( LDAS0(IMA), LDAD0(IMA) ) + IPAD
+ IF( K .GT. I ) I = K
+ 10 CONTINUE
+ I = I + IBTNPROCS()
+ MAXERR = ( ZSIZE * (MEMLEN-I) ) / ( ZSIZE*2 + ISIZE*6 )
+ IF( MAXERR .LT. 1 ) THEN
+ WRITE(OUTNUM,*) 'ERROR: Not enough memory to run MAX tests.'
+ CALL BLACS_ABORT(-1, 1)
+ END IF
+ ERRDPTR = I + 1
+ ERRIPTR = ERRDPTR + MAXERR
+ NERR = 0
+ TESTNUM = 0
+ NFAIL = 0
+ NSKIP = 0
+*
+* Loop over grids of matrix
+*
+ DO 90 IGR = 1, NGRID
+*
+* allocate process grid for the next batch of tests
+*
+ CONTEXT = CONTEXT0(IGR)
+ CALL BLACS_GRIDINFO( CONTEXT, NPROW, NPCOL, MYROW, MYCOL )
+ INGRID = ( (MYROW.LT.NPROW) .AND. (MYCOL.LT.NPCOL) )
+*
+ DO 80 ISC = 1, NSCOPE
+ SCOPE = SCOPE0(ISC)
+ DO 70 ITO = 1, NTOP
+ TOP = TOP0(ITO)
+*
+* If testing multiring ('M') or general tree ('T'), need to
+* loop over calls to BLACS_SET to do full test
+*
+ IF( LSAME(TOP, 'M') ) THEN
+ SETWHAT = 13
+ IF( SCOPE .EQ. 'R' ) THEN
+ ISTART = -(NPCOL - 1)
+ ISTOP = -ISTART
+ ELSE IF (SCOPE .EQ. 'C') THEN
+ ISTART = -(NPROW - 1)
+ ISTOP = -ISTART
+ ELSE
+ ISTART = -(NPROW*NPCOL - 1)
+ ISTOP = -ISTART
+ ENDIF
+ ELSE IF( LSAME(TOP, 'T') ) THEN
+ SETWHAT = 14
+ ISTART = 1
+ IF( SCOPE .EQ. 'R' ) THEN
+ ISTOP = NPCOL - 1
+ ELSE IF (SCOPE .EQ. 'C') THEN
+ ISTOP = NPROW - 1
+ ELSE
+ ISTOP = NPROW*NPCOL - 1
+ ENDIF
+ ELSE
+ SETWHAT = 0
+ ISTART = 1
+ ISTOP = 1
+ ENDIF
+ DO 60 IMA = 1, NMAT
+ M = M0(IMA)
+ N = N0(IMA)
+ LDASRC = LDAS0(IMA)
+ LDADST = LDAD0(IMA)
+ LDI = LDI0(IMA)
+ IPRE = 2 * M
+ IPOST = IPRE
+ PREAPTR = 1
+ APTR = PREAPTR + IPRE
+*
+ DO 50 IDE = 1, NDEST
+ TESTNUM = TESTNUM + 1
+ RDEST2 = RDEST0(IDE)
+ CDEST2 = CDEST0(IDE)
+*
+* If everyone gets the answer, create some bogus rdest/cdest
+* so IF's are easier
+*
+ ALLRCV = ( (RDEST2.EQ.-1) .OR. (CDEST2.EQ.-1) )
+ IF( ALLRCV ) THEN
+ RDEST = NPROW - 1
+ CDEST = NPCOL - 1
+ IF (TOPSCOHRNT.EQ.0) THEN
+ ITR1 = 0
+ ITR2 = 0
+ ELSE IF (TOPSCOHRNT.EQ.1) THEN
+ ITR1 = 1
+ ITR2 = 1
+ ELSE
+ ITR1 = 0
+ ITR2 = 1
+ END IF
+ ELSE
+ RDEST = RDEST2
+ CDEST = CDEST2
+ ITC1 = 0
+ ITC2 = 0
+ END IF
+ IF( RDEST.GE.P0(IGR) .OR. CDEST.GE.Q0(IGR) ) THEN
+ NSKIP = NSKIP + 1
+ GOTO 50
+ END IF
+*
+ IF( MYROW.EQ.RDEST .AND. MYCOL.EQ.CDEST ) THEN
+ LDA = LDADST
+ ELSE
+ LDA = LDASRC
+ END IF
+ VALPTR = APTR + IPOST + N * LDA
+ IF( VERB .GT. 1 ) THEN
+ IF( IAM .EQ. 0 ) THEN
+ WRITE(OUTNUM, 6000)
+ $ TESTNUM, 'RUNNING', SCOPE, TOP, M, N,
+ $ LDASRC, LDADST, LDI, RDEST2, CDEST2,
+ $ NPROW, NPCOL
+ END IF
+ END IF
+*
+* If I am in scope
+*
+ TESTOK = .TRUE.
+ IF( INGRID ) THEN
+ IF( (MYROW.EQ.RDEST .AND. SCOPE.EQ.'R') .OR.
+ $ (MYCOL.EQ.CDEST .AND. SCOPE.EQ.'C') .OR.
+ $ (SCOPE .EQ. 'A') ) THEN
+*
+ K = NERR
+ DO 40 ITR = ITR1, ITR2
+ CALL BLACS_SET(CONTEXT, 15, ITR)
+ DO 35 ITC = ITC1, ITC2
+ CALL BLACS_SET(CONTEXT, 16, ITC)
+ DO 30 J = ISTART, ISTOP
+ IF( J.EQ.0) GOTO 30
+ IF( SETWHAT.NE.0 )
+ $ CALL BLACS_SET(CONTEXT, SETWHAT, J)
+*
+*
+* generate and pad matrix A
+*
+ CALL ZINITMAT('G','-', M, N, MEM(PREAPTR),
+ $ LDA, IPRE, IPOST,
+ $ CHECKVAL, TESTNUM,
+ $ MYROW, MYCOL )
+*
+* If they exist, pad RA and CA arrays
+*
+ IF( LDI .NE. -1 ) THEN
+ DO 15 I = 1, N*LDI + IPRE + IPOST
+ RMEM(I) = ICHECKVAL
+ CMEM(I) = ICHECKVAL
+ 15 CONTINUE
+ RAPTR = 1 + IPRE
+ CAPTR = 1 + IPRE
+ ELSE
+ DO 20 I = 1, IPRE+IPOST
+ RMEM(I) = ICHECKVAL
+ CMEM(I) = ICHECKVAL
+ 20 CONTINUE
+ RAPTR = 1
+ CAPTR = 1
+ END IF
+*
+ CALL ZGAMX2D(CONTEXT, SCOPE, TOP, M, N,
+ $ MEM(APTR), LDA, RMEM(RAPTR),
+ $ CMEM(CAPTR), LDI,
+ $ RDEST2, CDEST2)
+*
+* If I've got the answer, check for errors in
+* matrix or padding
+*
+ IF( (MYROW.EQ.RDEST .AND. MYCOL.EQ.CDEST)
+ $ .OR. ALLRCV ) THEN
+ CALL ZCHKPAD('G','-', M, N,
+ $ MEM(PREAPTR), LDA, RDEST,
+ $ CDEST, MYROW, MYCOL,
+ $ IPRE, IPOST, CHECKVAL,
+ $ TESTNUM, MAXERR, NERR,
+ $ MEM(ERRIPTR),MEM(ERRDPTR))
+ CALL ZCHKAMX(SCOPE, CONTEXT, M, N,
+ $ MEM(APTR), LDA,
+ $ RMEM(RAPTR), CMEM(CAPTR),
+ $ LDI, TESTNUM, MAXERR,NERR,
+ $ MEM(ERRIPTR),MEM(ERRDPTR),
+ $ ISEED, MEM(VALPTR))
+ CALL ZRCCHK(IPRE, IPOST, ICHECKVAL,
+ $ M, N, RMEM, CMEM, LDI,
+ $ MYROW, MYCOL, TESTNUM,
+ $ MAXERR, NERR,
+ $ MEM(ERRIPTR), MEM(ERRDPTR))
+ END IF
+ 30 CONTINUE
+ CALL BLACS_SET(CONTEXT, 16, 0)
+ 35 CONTINUE
+ CALL BLACS_SET(CONTEXT, 15, 0)
+ 40 CONTINUE
+ TESTOK = ( K .EQ. NERR )
+ END IF
+ END IF
+*
+ IF( VERB .GT. 1 ) THEN
+ I = NERR
+ CALL ZBTCHECKIN(0, OUTNUM, MAXERR, NERR,
+ $ MEM(ERRIPTR), MEM(ERRDPTR), ISEED)
+ IF( IAM .EQ. 0 ) THEN
+ IF( TESTOK .AND. NERR.EQ.I ) THEN
+ WRITE(OUTNUM,6000)TESTNUM,'PASSED ',
+ $ SCOPE, TOP, M, N, LDASRC,
+ $ LDADST, LDI, RDEST2, CDEST2,
+ $ NPROW, NPCOL
+ ELSE
+ NFAIL = NFAIL + 1
+ WRITE(OUTNUM,6000)TESTNUM,'FAILED ',
+ $ SCOPE, TOP, M, N, LDASRC,
+ $ LDADST, LDI, RDEST2, CDEST2,
+ $ NPROW, NPCOL
+ END IF
+ END IF
+*
+* Once we've printed out errors, can re-use buf space
+*
+ NERR = 0
+ END IF
+ 50 CONTINUE
+ 60 CONTINUE
+ 70 CONTINUE
+ 80 CONTINUE
+ 90 CONTINUE
+*
+ IF( VERB .LT. 2 ) THEN
+ NFAIL = TESTNUM
+ CALL ZBTCHECKIN( NFAIL, OUTNUM, MAXERR, NERR, MEM(ERRIPTR),
+ $ MEM(ERRDPTR), ISEED )
+ END IF
+ IF( IAM .EQ. 0 ) THEN
+ IF( VERB .GT. 1 ) WRITE(OUTNUM,*) ' '
+ IF( NFAIL+NSKIP .EQ. 0 ) THEN
+ WRITE(OUTNUM, 7000 ) TESTNUM
+ ELSE
+ WRITE(OUTNUM, 8000 ) TESTNUM, TESTNUM-NSKIP-NFAIL,
+ $ NSKIP, NFAIL
+ END IF
+ END IF
+*
+* Log whether their were any failures
+*
+ TESTOK = ALLPASS( (NFAIL.EQ.0) )
+*
+ 1000 FORMAT('DOUBLE COMPLEX AMX TESTS: BEGIN.' )
+ 2000 FORMAT(1X,A7,3X,10I6)
+ 3000 FORMAT(1X,A7,3X,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1,
+ $ 5X,A1,5X,A1)
+ 4000 FORMAT(' TEST# STATUS SCOPE TOP M N LDAS LDAD LDI ',
+ $ 'RDEST CDEST P Q')
+ 5000 FORMAT(' ----- ------- ----- --- ----- ----- ----- ----- ----- ',
+ $ '----- ----- ---- ----')
+ 6000 FORMAT(I6,1X,A7,5X,A1,3X,A1,7I6,2I5)
+ 7000 FORMAT('DOUBLE COMPLEX AMX TESTS: PASSED ALL',
+ $ I5, ' TESTS.')
+ 8000 FORMAT('DOUBLE COMPLEX AMX TESTS:',I5,' TESTS;',I5,' PASSED,',
+ $ I5,' SKIPPED,',I5,' FAILED.')
+*
+ RETURN
+*
+* End of ZTESTAMX.
+*
+ END
+*
+ SUBROUTINE ZRCCHK( IPRE, IPOST, PADVAL, M, N, RA, CA, LDI, MYROW,
+ $ MYCOL, TESTNUM, MAXERR, NERR,
+ $ ERRIBUF, ERRDBUF )
+*
+* .. Scalar Arguments ..
+ INTEGER IPRE, IPOST, PADVAL, M, N, LDI, MYROW, MYCOL, TESTNUM
+ INTEGER MAXERR, NERR
+* ..
+* .. Array Arguments ..
+ INTEGER RA(*), CA(*), ERRIBUF(6, MAXERR)
+ DOUBLE COMPLEX ERRDBUF(2, MAXERR)
+* ..
+* .. Parameters ..
+ INTEGER ERR_PRE, ERR_POST, ERR_GAP, ERR_TRI, ERR_MAT
+ PARAMETER( ERR_PRE = 1, ERR_POST = 2, ERR_GAP = 3, ERR_TRI = 4 )
+ PARAMETER( ERR_MAT = 5 )
+* ..
+* .. External Functions ..
+ INTEGER IBTNPROCS
+ EXTERNAL IBTNPROCS
+* ..
+* .. Local Scalars ..
+ INTEGER I, J, K, IAM
+* ..
+* .. Executable Statements ..
+*
+ IAM = MYROW * IBTNPROCS() + MYCOL
+*
+* Check pre padding
+*
+ IF( LDI .NE. -1 ) THEN
+ IF( IPRE .GT. 0 ) THEN
+ DO 10 I = 1, IPRE
+ IF( RA(I) .NE. PADVAL ) THEN
+ NERR = NERR + 1
+ IF( NERR .LE. MAXERR ) THEN
+ ERRIBUF(1, NERR) = TESTNUM
+ ERRIBUF(2, NERR) = LDI
+ ERRIBUF(3, NERR) = IAM
+ ERRIBUF(4, NERR) = I
+ ERRIBUF(5, NERR) = IPRE - I + 1
+ ERRIBUF(6, NERR) = -ERR_PRE
+ ERRDBUF(1, NERR) = DCMPLX( RA(I) )
+ ERRDBUF(2, NERR) = DCMPLX( PADVAL )
+ END IF
+ ENDIF
+ IF( CA(I) .NE. PADVAL ) THEN
+ NERR = NERR + 1
+ IF( NERR .LE. MAXERR ) THEN
+ ERRIBUF(1, NERR) = TESTNUM
+ ERRIBUF(2, NERR) = LDI
+ ERRIBUF(3, NERR) = IAM
+ ERRIBUF(4, NERR) = I
+ ERRIBUF(5, NERR) = IPRE - I + 1
+ ERRIBUF(6, NERR) = -10 - ERR_PRE
+ ERRDBUF(1, NERR) = DCMPLX( CA(I) )
+ ERRDBUF(2, NERR) = DCMPLX( PADVAL )
+ END IF
+ ENDIF
+ 10 CONTINUE
+ END IF
+*
+* Check post padding
+*
+ IF( IPOST .GT. 0 ) THEN
+ K = IPRE + LDI*N
+ DO 20 I = K+1, K+IPOST
+ IF( RA(I) .NE. PADVAL ) THEN
+ NERR = NERR + 1
+ IF( NERR .LE. MAXERR ) THEN
+ ERRIBUF(1, NERR) = TESTNUM
+ ERRIBUF(2, NERR) = LDI
+ ERRIBUF(3, NERR) = IAM
+ ERRIBUF(4, NERR) = I - K
+ ERRIBUF(5, NERR) = I
+ ERRIBUF(6, NERR) = -ERR_POST
+ ERRDBUF(1, NERR) = DCMPLX( RA(I) )
+ ERRDBUF(2, NERR) = DCMPLX( PADVAL )
+ END IF
+ ENDIF
+ IF( CA(I) .NE. PADVAL ) THEN
+ NERR = NERR + 1
+ IF( NERR .LE. MAXERR ) THEN
+ ERRIBUF(1, NERR) = TESTNUM
+ ERRIBUF(2, NERR) = LDI
+ ERRIBUF(3, NERR) = IAM
+ ERRIBUF(4, NERR) = I - K
+ ERRIBUF(5, NERR) = I
+ ERRIBUF(6, NERR) = -10 - ERR_POST
+ ERRDBUF(1, NERR) = DCMPLX( CA(I) )
+ ERRDBUF(2, NERR) = DCMPLX( PADVAL )
+ END IF
+ ENDIF
+ 20 CONTINUE
+ END IF
+*
+* Check all (LDI-M) gaps
+*
+ IF( LDI .GT. M ) THEN
+ K = IPRE + M + 1
+ DO 40 J = 1, N
+ DO 30 I = M+1, LDI
+ K = IPRE + (J-1)*LDI + I
+ IF( RA(K) .NE. PADVAL) THEN
+ NERR = NERR + 1
+ IF( NERR .LE. MAXERR ) THEN
+ ERRIBUF(1, NERR) = TESTNUM
+ ERRIBUF(2, NERR) = LDI
+ ERRIBUF(3, NERR) = IAM
+ ERRIBUF(4, NERR) = I
+ ERRIBUF(5, NERR) = J
+ ERRIBUF(6, NERR) = -ERR_GAP
+ ERRDBUF(1, NERR) = DCMPLX( RA(K) )
+ ERRDBUF(2, NERR) = DCMPLX( PADVAL )
+ END IF
+ END IF
+ IF( CA(K) .NE. PADVAL) THEN
+ NERR = NERR + 1
+ IF( NERR .LE. MAXERR ) THEN
+ ERRIBUF(1, NERR) = TESTNUM
+ ERRIBUF(2, NERR) = LDI
+ ERRIBUF(3, NERR) = IAM
+ ERRIBUF(4, NERR) = I
+ ERRIBUF(5, NERR) = J
+ ERRIBUF(6, NERR) = -10 - ERR_GAP
+ ERRDBUF(1, NERR) = DCMPLX( CA(K) )
+ ERRDBUF(2, NERR) = DCMPLX( PADVAL )
+ END IF
+ END IF
+ 30 CONTINUE
+ 40 CONTINUE
+ END IF
+*
+* if RA and CA don't exist, buffs better be untouched
+*
+ ELSE
+ DO 50 I = 1, IPRE+IPOST
+ IF( RA(I) .NE. PADVAL) THEN
+ NERR = NERR + 1
+ IF( NERR .LE. MAXERR ) THEN
+ ERRIBUF(1, NERR) = TESTNUM
+ ERRIBUF(2, NERR) = LDI
+ ERRIBUF(3, NERR) = IAM
+ ERRIBUF(4, NERR) = I
+ ERRIBUF(5, NERR) = IPRE+IPOST
+ ERRIBUF(6, NERR) = -ERR_PRE
+ ERRDBUF(1, NERR) = DCMPLX( RA(I) )
+ ERRDBUF(2, NERR) = DCMPLX( PADVAL )
+ END IF
+ END IF
+ IF( CA(I) .NE. PADVAL) THEN
+ NERR = NERR + 1
+ IF( NERR .LE. MAXERR ) THEN
+ ERRIBUF(1, NERR) = TESTNUM
+ ERRIBUF(2, NERR) = LDI
+ ERRIBUF(3, NERR) = IAM
+ ERRIBUF(4, NERR) = I
+ ERRIBUF(5, NERR) = IPRE+IPOST
+ ERRIBUF(6, NERR) = -10 - ERR_PRE
+ ERRDBUF(1, NERR) = DCMPLX( CA(I) )
+ ERRDBUF(2, NERR) = DCMPLX( PADVAL )
+ END IF
+ END IF
+ 50 CONTINUE
+ ENDIF
+*
+ RETURN
+ END
+*
+ SUBROUTINE ZCHKAMX( SCOPE, ICTXT, M, N, A, LDA, RA, CA, LDI,
+ $ TESTNUM, MAXERR, NERR, ERRIBUF, ERRDBUF,
+ $ ISEED, VALS )
+*
+* .. Scalar Arguments ..
+ CHARACTER*1 SCOPE
+ INTEGER ICTXT, M, N, LDA, LDI, TESTNUM, MAXERR, NERR
+* ..
+* .. Array Arguments ..
+ INTEGER RA(*), CA(*), ERRIBUF(6, MAXERR), ISEED(*)
+ DOUBLE COMPLEX A(LDA,*), ERRDBUF(2, MAXERR), VALS(*)
+* ..
+* .. External Functions ..
+ INTEGER IBTMYPROC, IBTNPROCS, IBTSPNUM
+ DOUBLE PRECISION DBTEPS, ZBTABS
+ DOUBLE COMPLEX ZBTRAN
+ EXTERNAL IBTMYPROC, IBTNPROCS, IBTSPNUM, ZBTRAN, DBTEPS, ZBTABS
+* ..
+* .. External Subroutines ..
+ EXTERNAL IBTSPCOORD
+* ..
+* .. Local Scalars ..
+ LOGICAL ERROR
+ INTEGER NPROCS, NNODES, NPROW, NPCOL, MYROW, MYCOL, RAMX, CAMX
+ INTEGER IAMX, I, J, K, H, DEST, NODE
+ DOUBLE PRECISION EPS
+* ..
+* .. Executable Statements ..
+*
+ NPROCS = IBTNPROCS()
+ EPS = DBTEPS()
+ CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL )
+ DEST = MYROW*NPROCS + MYCOL
+*
+* Set up seeds to match those used by each proc's genmat call
+*
+ IF( SCOPE .EQ. 'R' ) THEN
+ NNODES = NPCOL
+ DO 10 I = 0, NNODES-1
+ NODE = MYROW * NPROCS + I
+ ISEED(I*4+1) = MOD( 1002 + TESTNUM*5 + NODE*3, 4096 )
+ ISEED(I*4+2) = MOD( 2027 + TESTNUM*7 + NODE, 4096 )
+ ISEED(I*4+3) = MOD( 1234 + TESTNUM + NODE*3, 4096 )
+ ISEED(I*4+4) = MOD( 4311 + TESTNUM*10 + NODE*2, 4096 )
+ 10 CONTINUE
+ ELSE IF( SCOPE .EQ. 'C' ) THEN
+ NNODES = NPROW
+ DO 20 I = 0, NNODES-1
+ NODE = I * NPROCS + MYCOL
+ ISEED(I*4+1) = MOD( 1002 + TESTNUM*5 + NODE*3, 4096 )
+ ISEED(I*4+2) = MOD( 2027 + TESTNUM*7 + NODE, 4096 )
+ ISEED(I*4+3) = MOD( 1234 + TESTNUM + NODE*3, 4096 )
+ ISEED(I*4+4) = MOD( 4311 + TESTNUM*10 + NODE*2, 4096 )
+ 20 CONTINUE
+ ELSE
+ NNODES = NPROW * NPCOL
+ DO 30 I = 0, NNODES-1
+ NODE = (I / NPCOL) * NPROCS + MOD(I, NPCOL)
+ ISEED(I*4+1) = MOD( 1002 + TESTNUM*5 + NODE*3, 4096 )
+ ISEED(I*4+2) = MOD( 2027 + TESTNUM*7 + NODE, 4096 )
+ ISEED(I*4+3) = MOD( 1234 + TESTNUM + NODE*3, 4096 )
+ ISEED(I*4+4) = MOD( 4311 + TESTNUM*10 + NODE*2, 4096 )
+ 30 CONTINUE
+ END IF
+*
+ DO 100 J = 1, N
+ DO 90 I = 1, M
+ H = (J-1)*LDI + I
+ VALS(1) = ZBTRAN( ISEED )
+ IAMX = 1
+ IF( NNODES .GT. 1 ) THEN
+ DO 40 K = 1, NNODES-1
+ VALS(K+1) = ZBTRAN( ISEED(K*4+1) )
+ IF( ZBTABS( VALS(K+1) ) .GT. ZBTABS( VALS(IAMX) ) )
+ $ IAMX = K + 1
+ 40 CONTINUE
+ END IF
+*
+* If BLACS have not returned same value we've chosen
+*
+ IF( A(I,J) .NE. VALS(IAMX) ) THEN
+*
+* If we have RA and CA arrays
+*
+ IF( LDI .NE. -1 ) THEN
+*
+* Any number having the same absolute value is a valid max
+*
+ K = IBTSPNUM( SCOPE, RA(H), CA(H), NPCOL ) + 1
+ IF( K.GT.0 .AND. K.LE.NNODES ) THEN
+ ERROR = ABS( ZBTABS(VALS(K)) - ZBTABS(VALS(IAMX)) )
+ $ .GT. 3*EPS
+ IF( .NOT.ERROR ) IAMX = K
+ ELSE
+ ERROR = .TRUE.
+ END IF
+ ELSE
+*
+* Error if BLACS answer not same absolute value, or if it
+* was not really in the numbers being compared
+*
+ ERROR = ABS( ZBTABS(A(I,J)) - ZBTABS(VALS(IAMX)) )
+ $ .GT. 3*EPS
+ IF( .NOT.ERROR ) THEN
+ DO 50 K = 1, NNODES
+ IF( VALS(K) .EQ. A(I,J) ) GOTO 60
+ 50 CONTINUE
+ ERROR = .TRUE.
+ 60 CONTINUE
+ ENDIF
+ END IF
+*
+* If the value is in error
+*
+ IF( ERROR ) THEN
+ NERR = NERR + 1
+ ERRIBUF(1, NERR) = TESTNUM
+ ERRIBUF(2, NERR) = NNODES
+ ERRIBUF(3, NERR) = DEST
+ ERRIBUF(4, NERR) = I
+ ERRIBUF(5, NERR) = J
+ ERRIBUF(6, NERR) = 5
+ ERRDBUF(1, NERR) = A(I,J)
+ ERRDBUF(2, NERR) = VALS(IAMX)
+ END IF
+ END IF
+*
+* If they are defined, make sure coordinate entries are OK
+*
+ IF( LDI .NE. -1 ) THEN
+ K = IBTSPNUM( SCOPE, RA(H), CA(H), NPCOL ) + 1
+ IF( K.NE.IAMX ) THEN
+*
+* Make sure more than one proc doesn't have exact same value
+* (and therefore there may be more than one valid coordinate
+* for a single value)
+*
+ IF( K.GT.NNODES .OR. K.LT.1 ) THEN
+ ERROR = .TRUE.
+ ELSE
+ ERROR = ( VALS(K) .NE. VALS(IAMX) )
+ END IF
+ IF( ERROR ) THEN
+ CALL IBTSPCOORD( SCOPE, IAMX-1, MYROW, MYCOL,
+ $ NPCOL, RAMX, CAMX )
+ IF( RAMX .NE. RA(H) ) THEN
+ NERR = NERR + 1
+ ERRIBUF(1, NERR) = TESTNUM
+ ERRIBUF(2, NERR) = NNODES
+ ERRIBUF(3, NERR) = DEST
+ ERRIBUF(4, NERR) = I
+ ERRIBUF(5, NERR) = J
+ ERRIBUF(6, NERR) = -5
+ ERRDBUF(1, NERR) = RA(H)
+ ERRDBUF(2, NERR) = RAMX
+ END IF
+ IF( CAMX .NE. CA(H) ) THEN
+ NERR = NERR + 1
+ ERRIBUF(1, NERR) = TESTNUM
+ ERRIBUF(2, NERR) = NNODES
+ ERRIBUF(3, NERR) = DEST
+ ERRIBUF(4, NERR) = I
+ ERRIBUF(5, NERR) = J
+ ERRIBUF(6, NERR) = -15
+ ERRDBUF(1, NERR) = CA(H)
+ ERRDBUF(2, NERR) = CAMX
+ END IF
+ END IF
+ END IF
+ END IF
+ 90 CONTINUE
+ 100 CONTINUE
+*
+ RETURN
+*
+* End of ZCHKAMX
+*
+ END
+*
+*
+ SUBROUTINE IAMNTEST( OUTNUM, VERB, TOPSREPEAT, TOPSCOHRNT, NSCOPE,
+ $ SCOPE0, NTOP, TOP0, NMAT, M0, N0, LDAS0,
+ $ LDAD0, LDI0, NDEST, RDEST0, CDEST0, NGRID,
+ $ CONTEXT0, P0, Q0, ISEED, RMEM, CMEM, RCLEN,
+ $ MEM, MEMLEN )
+*
+* -- BLACS tester (version 1.0) --
+* University of Tennessee
+* December 15, 1994
+*
+*
+* .. Scalar Arguments ..
+ INTEGER MEMLEN, NDEST, NGRID, NMAT, NSCOPE, NTOP, OUTNUM, RCLEN,
+ $ TOPSCOHRNT, TOPSREPEAT, VERB
+* ..
+* .. Array Arguments ..
+ CHARACTER*1 SCOPE0(NSCOPE), TOP0(NTOP)
+ INTEGER M0(NMAT), N0(NMAT), LDAS0(NMAT), LDAD0(NMAT), LDI0(NMAT)
+ INTEGER RDEST0(NDEST), CDEST0(NDEST), CONTEXT0(NGRID)
+ INTEGER P0(NGRID), Q0(NGRID), ISEED(*), RMEM(RCLEN), CMEM(RCLEN)
+ INTEGER MEM(MEMLEN)
+* ..
+*
+* Purpose
+* =======
+* ITESTAMN: Test integer AMN COMBINE
+*
+* Arguments
+* =========
+* OUTNUM (input) INTEGER
+* The device number to write output to.
+*
+* VERB (input) INTEGER
+* The level of verbosity (how much printing to do).
+*
+* NSCOPE (input) INTEGER
+* The number of scopes to be tested.
+*
+* SCOPE0 (input) CHARACTER*1 array of dimension (NSCOPE)
+* Values of the scopes to be tested.
+*
+* NTOP (input) INTEGER
+* The number of topologies to be tested.
+*
+* TOP0 (input) CHARACTER*1 array of dimension (NTOP)
+* Values of the topologies to be tested.
+*
+* NMAT (input) INTEGER
+* The number of matrices to be tested.
+*
+* M0 (input) INTEGER array of dimension (NMAT)
+* Values of M to be tested.
+*
+* M0 (input) INTEGER array of dimension (NMAT)
+* Values of M to be tested.
+*
+* N0 (input) INTEGER array of dimension (NMAT)
+* Values of N to be tested.
+*
+* LDAS0 (input) INTEGER array of dimension (NMAT)
+* Values of LDAS (leading dimension of A on source process)
+* to be tested.
+*
+* LDAD0 (input) INTEGER array of dimension (NMAT)
+* Values of LDAD (leading dimension of A on destination
+* process) to be tested.
+* LDI0 (input) INTEGER array of dimension (NMAT)
+* Values of LDI (leading dimension of RA/CA) to be tested.
+* If LDI == -1, these RA/CA should not be accessed.
+*
+* NDEST (input) INTEGER
+* The number of destinations to be tested.
+*
+* RDEST0 (input) INTEGER array of dimension (NNDEST)
+* Values of RDEST (row coordinate of destination) to be
+* tested.
+*
+* CDEST0 (input) INTEGER array of dimension (NNDEST)
+* Values of CDEST (column coordinate of destination) to be
+* tested.
+*
+* NGRID (input) INTEGER
+* The number of process grids to be tested.
+*
+* CONTEXT0 (input) INTEGER array of dimension (NGRID)
+* The BLACS context handles corresponding to the grids.
+*
+* P0 (input) INTEGER array of dimension (NGRID)
+* Values of P (number of process rows, NPROW).
+*
+* Q0 (input) INTEGER array of dimension (NGRID)
+* Values of Q (number of process columns, NPCOL).
+*
+* ISEED (workspace) INTEGER array of dimension ( MAX(NPROCS, NTESTS) )
+* Workspace used to hold each process's random number SEED.
+* This requires NPROCS (number of processor) elements.
+* If VERB < 2, this workspace also serves to indicate which
+* tests fail. This requires workspace of NTESTS
+* (number of tests performed).
+*
+* RMEM (workspace) INTEGER array of dimension (RCLEN)
+* Used for all RA arrays, and their pre and post padding.
+*
+* CMEM (workspace) INTEGER array of dimension (RCLEN)
+* Used for all CA arrays, and their pre and post padding.
+*
+* RCLEN (input) INTEGER
+* The length, in elements, of RMEM and CMEM.
+*
+* MEM (workspace) INTEGER array of dimension (MEMLEN)
+* Used for all other workspaces, including the matrix A,
+* and its pre and post padding.
+*
+* MEMLEN (input) INTEGER
+* The length, in elements, of MEM.
+*
+* =====================================================================
+*
+* .. External Functions ..
+ LOGICAL ALLPASS, LSAME
+ INTEGER IBTMYPROC, IBTNPROCS, IBTSIZEOF
+ EXTERNAL ALLPASS, LSAME, IBTMYPROC, IBTNPROCS, IBTSIZEOF
+* ..
+* .. External Subroutines ..
+ EXTERNAL BLACS_GRIDINFO, IGAMN2D
+ EXTERNAL IINITMAT, ICHKPAD, IBTCHECKIN
+* ..
+* .. Local Scalars ..
+ CHARACTER*1 SCOPE, TOP
+ LOGICAL INGRID, TESTOK, ALLRCV
+ INTEGER APTR, CAPTR, CDEST, CDEST2, CONTEXT, ERRDPTR, ERRIPTR, I,
+ $ IAM, ICHECKVAL, IDE, IGR, IMA, IPAD, IPOST, IPRE, ISC,
+ $ ISIZE, ISTART, ISTOP, ITC, ITC1, ITC2, ITO, ITR, ITR1,
+ $ ITR2, J, K, LDA, LDADST, LDASRC, LDI, M, MAXERR, MYCOL,
+ $ MYROW, N, NERR, NFAIL, NPCOL, NPROW, NSKIP, PREAPTR,
+ $ RAPTR, RDEST, RDEST2, SETWHAT, TESTNUM, VALPTR
+ INTEGER CHECKVAL
+* ..
+* .. Executable Statements ..
+*
+* Choose padding value, and make it unique
+*
+ CHECKVAL = -911
+ IAM = IBTMYPROC()
+ CHECKVAL = IAM * CHECKVAL
+ ISIZE = IBTSIZEOF('I')
+ ICHECKVAL = -IAM
+*
+* Verify file parameters
+*
+ IF( IAM .EQ. 0 ) THEN
+ WRITE(OUTNUM, *) ' '
+ WRITE(OUTNUM, *) ' '
+ WRITE(OUTNUM, 1000 )
+ IF( VERB .GT. 0 ) THEN
+ WRITE(OUTNUM,*) ' '
+ WRITE(OUTNUM, 2000) 'NSCOPE:', NSCOPE
+ WRITE(OUTNUM, 3000) ' SCOPE:', ( SCOPE0(I), I = 1, NSCOPE )
+ WRITE(OUTNUM, 2000) 'TReps :', TOPSREPEAT
+ WRITE(OUTNUM, 2000) 'TCohr :', TOPSCOHRNT
+ WRITE(OUTNUM, 2000) 'NTOP :', NTOP
+ WRITE(OUTNUM, 3000) ' TOP :', ( TOP0(I), I = 1, NTOP )
+ WRITE(OUTNUM, 2000) 'NMAT :', NMAT
+ WRITE(OUTNUM, 2000) ' M :', ( M0(I), I = 1, NMAT )
+ WRITE(OUTNUM, 2000) ' N :', ( N0(I), I = 1, NMAT )
+ WRITE(OUTNUM, 2000) ' LDAS :', ( LDAS0(I), I = 1, NMAT )
+ WRITE(OUTNUM, 2000) ' LDAD :', ( LDAD0(I), I = 1, NMAT )
+ WRITE(OUTNUM, 2000) ' LDI :', ( LDI0(I), I = 1, NMAT )
+ WRITE(OUTNUM, 2000) 'NDEST :', NDEST
+ WRITE(OUTNUM, 2000) ' RDEST:',( RDEST0(I), I = 1, NDEST )
+ WRITE(OUTNUM, 2000) ' CDEST:',( CDEST0(I), I = 1, NDEST )
+ WRITE(OUTNUM, 2000) 'NGRIDS:', NGRID
+ WRITE(OUTNUM, 2000) ' P :', ( P0(I), I = 1, NGRID )
+ WRITE(OUTNUM, 2000) ' Q :', ( Q0(I), I = 1, NGRID )
+ WRITE(OUTNUM, 2000) 'VERB :', VERB
+ WRITE(OUTNUM,*) ' '
+ END IF
+ IF( VERB .GT. 1 ) THEN
+ WRITE(OUTNUM,4000)
+ WRITE(OUTNUM,5000)
+ END IF
+ END IF
+ IF (TOPSREPEAT.EQ.0) THEN
+ ITR1 = 0
+ ITR2 = 0
+ ELSE IF (TOPSREPEAT.EQ.1) THEN
+ ITR1 = 1
+ ITR2 = 1
+ ELSE
+ ITR1 = 0
+ ITR2 = 1
+ END IF
+*
+* Find biggest matrix, so we know where to stick error info
+*
+ I = 0
+ DO 10 IMA = 1, NMAT
+ IPAD = 4 * M0(IMA)
+ K = N0(IMA) * MAX0( LDAS0(IMA), LDAD0(IMA) ) + IPAD
+ IF( K .GT. I ) I = K
+ 10 CONTINUE
+ I = I + IBTNPROCS()
+ MAXERR = ( ISIZE * (MEMLEN-I) ) / ( ISIZE*2 + ISIZE*6 )
+ IF( MAXERR .LT. 1 ) THEN
+ WRITE(OUTNUM,*) 'ERROR: Not enough memory to run MIN tests.'
+ CALL BLACS_ABORT(-1, 1)
+ END IF
+ ERRDPTR = I + 1
+ ERRIPTR = ERRDPTR + MAXERR
+ NERR = 0
+ TESTNUM = 0
+ NFAIL = 0
+ NSKIP = 0
+*
+* Loop over grids of matrix
+*
+ DO 90 IGR = 1, NGRID
+*
+* allocate process grid for the next batch of tests
+*
+ CONTEXT = CONTEXT0(IGR)
+ CALL BLACS_GRIDINFO( CONTEXT, NPROW, NPCOL, MYROW, MYCOL )
+ INGRID = ( (MYROW.LT.NPROW) .AND. (MYCOL.LT.NPCOL) )
+*
+ DO 80 ISC = 1, NSCOPE
+ SCOPE = SCOPE0(ISC)
+ DO 70 ITO = 1, NTOP
+ TOP = TOP0(ITO)
+*
+* If testing multiring ('M') or general tree ('T'), need to
+* loop over calls to BLACS_SET to do full test
+*
+ IF( LSAME(TOP, 'M') ) THEN
+ SETWHAT = 13
+ IF( SCOPE .EQ. 'R' ) THEN
+ ISTART = -(NPCOL - 1)
+ ISTOP = -ISTART
+ ELSE IF (SCOPE .EQ. 'C') THEN
+ ISTART = -(NPROW - 1)
+ ISTOP = -ISTART
+ ELSE
+ ISTART = -(NPROW*NPCOL - 1)
+ ISTOP = -ISTART
+ ENDIF
+ ELSE IF( LSAME(TOP, 'T') ) THEN
+ SETWHAT = 14
+ ISTART = 1
+ IF( SCOPE .EQ. 'R' ) THEN
+ ISTOP = NPCOL - 1
+ ELSE IF (SCOPE .EQ. 'C') THEN
+ ISTOP = NPROW - 1
+ ELSE
+ ISTOP = NPROW*NPCOL - 1
+ ENDIF
+ ELSE
+ SETWHAT = 0
+ ISTART = 1
+ ISTOP = 1
+ ENDIF
+ DO 60 IMA = 1, NMAT
+ M = M0(IMA)
+ N = N0(IMA)
+ LDASRC = LDAS0(IMA)
+ LDADST = LDAD0(IMA)
+ LDI = LDI0(IMA)
+ IPRE = 2 * M
+ IPOST = IPRE
+ PREAPTR = 1
+ APTR = PREAPTR + IPRE
+*
+ DO 50 IDE = 1, NDEST
+ TESTNUM = TESTNUM + 1
+ RDEST2 = RDEST0(IDE)
+ CDEST2 = CDEST0(IDE)
+*
+* If everyone gets the answer, create some bogus rdest/cdest
+* so IF's are easier
+*
+ ALLRCV = ( (RDEST2.EQ.-1) .OR. (CDEST2.EQ.-1) )
+ IF( ALLRCV ) THEN
+ RDEST = NPROW - 1
+ CDEST = NPCOL - 1
+ IF (TOPSCOHRNT.EQ.0) THEN
+ ITR1 = 0
+ ITR2 = 0
+ ELSE IF (TOPSCOHRNT.EQ.1) THEN
+ ITR1 = 1
+ ITR2 = 1
+ ELSE
+ ITR1 = 0
+ ITR2 = 1
+ END IF
+ ELSE
+ RDEST = RDEST2
+ CDEST = CDEST2
+ ITC1 = 0
+ ITC2 = 0
+ END IF
+ IF( RDEST.GE.P0(IGR) .OR. CDEST.GE.Q0(IGR) ) THEN
+ NSKIP = NSKIP + 1
+ GOTO 50
+ END IF
+*
+ IF( MYROW.EQ.RDEST .AND. MYCOL.EQ.CDEST ) THEN
+ LDA = LDADST
+ ELSE
+ LDA = LDASRC
+ END IF
+ VALPTR = APTR + IPOST + N * LDA
+ IF( VERB .GT. 1 ) THEN
+ IF( IAM .EQ. 0 ) THEN
+ WRITE(OUTNUM, 6000)
+ $ TESTNUM, 'RUNNING', SCOPE, TOP, M, N,
+ $ LDASRC, LDADST, LDI, RDEST2, CDEST2,
+ $ NPROW, NPCOL
+ END IF
+ END IF
+*
+* If I am in scope
+*
+ TESTOK = .TRUE.
+ IF( INGRID ) THEN
+ IF( (MYROW.EQ.RDEST .AND. SCOPE.EQ.'R') .OR.
+ $ (MYCOL.EQ.CDEST .AND. SCOPE.EQ.'C') .OR.
+ $ (SCOPE .EQ. 'A') ) THEN
+*
+ K = NERR
+ DO 40 ITR = ITR1, ITR2
+ CALL BLACS_SET(CONTEXT, 15, ITR)
+ DO 35 ITC = ITC1, ITC2
+ CALL BLACS_SET(CONTEXT, 16, ITC)
+ DO 30 J = ISTART, ISTOP
+ IF( J.EQ.0) GOTO 30
+ IF( SETWHAT.NE.0 )
+ $ CALL BLACS_SET(CONTEXT, SETWHAT, J)
+*
+*
+* generate and pad matrix A
+*
+ CALL IINITMAT('G','-', M, N, MEM(PREAPTR),
+ $ LDA, IPRE, IPOST,
+ $ CHECKVAL, TESTNUM,
+ $ MYROW, MYCOL )
+*
+* If they exist, pad RA and CA arrays
+*
+ IF( LDI .NE. -1 ) THEN
+ DO 15 I = 1, N*LDI + IPRE + IPOST
+ RMEM(I) = ICHECKVAL
+ CMEM(I) = ICHECKVAL
+ 15 CONTINUE
+ RAPTR = 1 + IPRE
+ CAPTR = 1 + IPRE
+ ELSE
+ DO 20 I = 1, IPRE+IPOST
+ RMEM(I) = ICHECKVAL
+ CMEM(I) = ICHECKVAL
+ 20 CONTINUE
+ RAPTR = 1
+ CAPTR = 1
+ END IF
+*
+ CALL IGAMN2D(CONTEXT, SCOPE, TOP, M, N,
+ $ MEM(APTR), LDA, RMEM(RAPTR),
+ $ CMEM(CAPTR), LDI,
+ $ RDEST2, CDEST2)
+*
+* If I've got the answer, check for errors in
+* matrix or padding
+*
+ IF( (MYROW.EQ.RDEST .AND. MYCOL.EQ.CDEST)
+ $ .OR. ALLRCV ) THEN
+ CALL ICHKPAD('G','-', M, N,
+ $ MEM(PREAPTR), LDA, RDEST,
+ $ CDEST, MYROW, MYCOL,
+ $ IPRE, IPOST, CHECKVAL,
+ $ TESTNUM, MAXERR, NERR,
+ $ MEM(ERRIPTR),MEM(ERRDPTR))
+ CALL ICHKAMN(SCOPE, CONTEXT, M, N,
+ $ MEM(APTR), LDA,
+ $ RMEM(RAPTR), CMEM(CAPTR),
+ $ LDI, TESTNUM, MAXERR,NERR,
+ $ MEM(ERRIPTR),MEM(ERRDPTR),
+ $ ISEED, MEM(VALPTR))
+ CALL IRCCHK(IPRE, IPOST, ICHECKVAL,
+ $ M, N, RMEM, CMEM, LDI,
+ $ MYROW, MYCOL, TESTNUM,
+ $ MAXERR, NERR,
+ $ MEM(ERRIPTR), MEM(ERRDPTR))
+ END IF
+ 30 CONTINUE
+ CALL BLACS_SET(CONTEXT, 16, 0)
+ 35 CONTINUE
+ CALL BLACS_SET(CONTEXT, 15, 0)
+ 40 CONTINUE
+ TESTOK = ( K .EQ. NERR )
+ END IF
+ END IF
+*
+ IF( VERB .GT. 1 ) THEN
+ I = NERR
+ CALL IBTCHECKIN(0, OUTNUM, MAXERR, NERR,
+ $ MEM(ERRIPTR), MEM(ERRDPTR), ISEED)
+ IF( IAM .EQ. 0 ) THEN
+ IF( TESTOK .AND. NERR.EQ.I ) THEN
+ WRITE(OUTNUM,6000)TESTNUM,'PASSED ',
+ $ SCOPE, TOP, M, N, LDASRC,
+ $ LDADST, LDI, RDEST2, CDEST2,
+ $ NPROW, NPCOL
+ ELSE
+ NFAIL = NFAIL + 1
+ WRITE(OUTNUM,6000)TESTNUM,'FAILED ',
+ $ SCOPE, TOP, M, N, LDASRC,
+ $ LDADST, LDI, RDEST2, CDEST2,
+ $ NPROW, NPCOL
+ END IF
+ END IF
+*
+* Once we've printed out errors, can re-use buf space
+*
+ NERR = 0
+ END IF
+ 50 CONTINUE
+ 60 CONTINUE
+ 70 CONTINUE
+ 80 CONTINUE
+ 90 CONTINUE
+*
+ IF( VERB .LT. 2 ) THEN
+ NFAIL = TESTNUM
+ CALL IBTCHECKIN( NFAIL, OUTNUM, MAXERR, NERR, MEM(ERRIPTR),
+ $ MEM(ERRDPTR), ISEED )
+ END IF
+ IF( IAM .EQ. 0 ) THEN
+ IF( VERB .GT. 1 ) WRITE(OUTNUM,*) ' '
+ IF( NFAIL+NSKIP .EQ. 0 ) THEN
+ WRITE(OUTNUM, 7000 ) TESTNUM
+ ELSE
+ WRITE(OUTNUM, 8000 ) TESTNUM, TESTNUM-NSKIP-NFAIL,
+ $ NSKIP, NFAIL
+ END IF
+ END IF
+*
+* Log whether their were any failures
+*
+ TESTOK = ALLPASS( (NFAIL.EQ.0) )
+*
+ 1000 FORMAT('INTEGER AMN TESTS: BEGIN.' )
+ 2000 FORMAT(1X,A7,3X,10I6)
+ 3000 FORMAT(1X,A7,3X,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1,
+ $ 5X,A1,5X,A1)
+ 4000 FORMAT(' TEST# STATUS SCOPE TOP M N LDAS LDAD LDI ',
+ $ 'RDEST CDEST P Q')
+ 5000 FORMAT(' ----- ------- ----- --- ----- ----- ----- ----- ----- ',
+ $ '----- ----- ---- ----')
+ 6000 FORMAT(I6,1X,A7,5X,A1,3X,A1,7I6,2I5)
+ 7000 FORMAT('INTEGER AMN TESTS: PASSED ALL',
+ $ I5, ' TESTS.')
+ 8000 FORMAT('INTEGER AMN TESTS:',I5,' TESTS;',I5,' PASSED,',
+ $ I5,' SKIPPED,',I5,' FAILED.')
+*
+ RETURN
+*
+* End of ITESTAMN.
+*
+ END
+*
+ SUBROUTINE ICHKAMN( SCOPE, ICTXT, M, N, A, LDA, RA, CA, LDI,
+ $ TESTNUM, MAXERR, NERR, ERRIBUF, ERRDBUF,
+ $ ISEED, VALS )
+*
+* .. Scalar Arguments ..
+ CHARACTER*1 SCOPE
+ INTEGER ICTXT, M, N, LDA, LDI, TESTNUM, MAXERR, NERR
+* ..
+* .. Array Arguments ..
+ INTEGER RA(*), CA(*), ERRIBUF(6, MAXERR), ISEED(*)
+ INTEGER A(LDA,*), ERRDBUF(2, MAXERR), VALS(*)
+* ..
+* .. External Functions ..
+ INTEGER IBTMYPROC, IBTNPROCS, IBTSPNUM, IBTRAN, IBTABS
+ EXTERNAL IBTMYPROC, IBTNPROCS, IBTSPNUM, IBTRAN
+ EXTERNAL IBTABS
+* ..
+* .. External Subroutines ..
+ EXTERNAL IBTSPCOORD
+* ..
+* .. Local Scalars ..
+ LOGICAL ERROR
+ INTEGER NPROCS, NNODES, NPROW, NPCOL, MYROW, MYCOL, RAMN, CAMN
+ INTEGER IAMN, I, J, K, H, DEST, NODE
+* ..
+* .. Executable Statements ..
+*
+ NPROCS = IBTNPROCS()
+ CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL )
+ DEST = MYROW*NPROCS + MYCOL
+*
+* Set up seeds to match those used by each proc's genmat call
+*
+ IF( SCOPE .EQ. 'R' ) THEN
+ NNODES = NPCOL
+ DO 10 I = 0, NNODES-1
+ NODE = MYROW * NPROCS + I
+ ISEED(I*4+1) = MOD( 1002 + TESTNUM*5 + NODE*3, 4096 )
+ ISEED(I*4+2) = MOD( 2027 + TESTNUM*7 + NODE, 4096 )
+ ISEED(I*4+3) = MOD( 1234 + TESTNUM + NODE*3, 4096 )
+ ISEED(I*4+4) = MOD( 4311 + TESTNUM*10 + NODE*2, 4096 )
+ 10 CONTINUE
+ ELSE IF( SCOPE .EQ. 'C' ) THEN
+ NNODES = NPROW
+ DO 20 I = 0, NNODES-1
+ NODE = I * NPROCS + MYCOL
+ ISEED(I*4+1) = MOD( 1002 + TESTNUM*5 + NODE*3, 4096 )
+ ISEED(I*4+2) = MOD( 2027 + TESTNUM*7 + NODE, 4096 )
+ ISEED(I*4+3) = MOD( 1234 + TESTNUM + NODE*3, 4096 )
+ ISEED(I*4+4) = MOD( 4311 + TESTNUM*10 + NODE*2, 4096 )
+ 20 CONTINUE
+ ELSE
+ NNODES = NPROW * NPCOL
+ DO 30 I = 0, NNODES-1
+ NODE = (I / NPCOL) * NPROCS + MOD(I, NPCOL)
+ ISEED(I*4+1) = MOD( 1002 + TESTNUM*5 + NODE*3, 4096 )
+ ISEED(I*4+2) = MOD( 2027 + TESTNUM*7 + NODE, 4096 )
+ ISEED(I*4+3) = MOD( 1234 + TESTNUM + NODE*3, 4096 )
+ ISEED(I*4+4) = MOD( 4311 + TESTNUM*10 + NODE*2, 4096 )
+ 30 CONTINUE
+ END IF
+*
+ DO 100 J = 1, N
+ DO 90 I = 1, M
+ H = (J-1)*LDI + I
+ VALS(1) = IBTRAN( ISEED )
+ IAMN = 1
+ IF( NNODES .GT. 1 ) THEN
+ DO 40 K = 1, NNODES-1
+ VALS(K+1) = IBTRAN( ISEED(K*4+1) )
+ IF( IBTABS( VALS(K+1) ) .LT. IBTABS( VALS(IAMN) ) )
+ $ IAMN = K + 1
+ 40 CONTINUE
+ END IF
+*
+* If BLACS have not returned same value we've chosen
+*
+ IF( A(I,J) .NE. VALS(IAMN) ) THEN
+*
+* If we have RA and CA arrays
+*
+ IF( LDI .NE. -1 ) THEN
+*
+* Any number having the same absolute value is a valid max
+*
+ K = IBTSPNUM( SCOPE, RA(H), CA(H), NPCOL ) + 1
+ IF( K.GT.0 .AND. K.LE.NNODES ) THEN
+ ERROR = IBTABS( VALS(K) ).NE.IBTABS( VALS(IAMN) )
+ IF( .NOT.ERROR ) IAMN = K
+ ELSE
+ ERROR = .TRUE.
+ END IF
+ ELSE
+*
+* Error if BLACS answer not same absolute value, or if it
+* was not really in the numbers being compared
+*
+ ERROR = ( IBTABS( A(I,J) ) .NE. IBTABS( VALS(IAMN) ) )
+ IF( .NOT.ERROR ) THEN
+ DO 50 K = 1, NNODES
+ IF( VALS(K) .EQ. A(I,J) ) GOTO 60
+ 50 CONTINUE
+ ERROR = .TRUE.
+ 60 CONTINUE
+ ENDIF
+ END IF
+*
+* If the value is in error
+*
+ IF( ERROR ) THEN
+ NERR = NERR + 1
+ ERRIBUF(1, NERR) = TESTNUM
+ ERRIBUF(2, NERR) = NNODES
+ ERRIBUF(3, NERR) = DEST
+ ERRIBUF(4, NERR) = I
+ ERRIBUF(5, NERR) = J
+ ERRIBUF(6, NERR) = 5
+ ERRDBUF(1, NERR) = A(I,J)
+ ERRDBUF(2, NERR) = VALS(IAMN)
+ END IF
+ END IF
+*
+* If they are defined, make sure coordinate entries are OK
+*
+ IF( LDI .NE. -1 ) THEN
+ K = IBTSPNUM( SCOPE, RA(H), CA(H), NPCOL ) + 1
+ IF( K.NE.IAMN ) THEN
+*
+* Make sure more than one proc doesn't have exact same value
+* (and therefore there may be more than one valid coordinate
+* for a single value)
+*
+ IF( K.GT.NNODES .OR. K.LT.1 ) THEN
+ ERROR = .TRUE.
+ ELSE
+ ERROR = ( VALS(K) .NE. VALS(IAMN) )
+ END IF
+ IF( ERROR ) THEN
+ CALL IBTSPCOORD( SCOPE, IAMN-1, MYROW, MYCOL,
+ $ NPCOL, RAMN, CAMN )
+ IF( RAMN .NE. RA(H) ) THEN
+ NERR = NERR + 1
+ ERRIBUF(1, NERR) = TESTNUM
+ ERRIBUF(2, NERR) = NNODES
+ ERRIBUF(3, NERR) = DEST
+ ERRIBUF(4, NERR) = I
+ ERRIBUF(5, NERR) = J
+ ERRIBUF(6, NERR) = -5
+ ERRDBUF(1, NERR) = RA(H)
+ ERRDBUF(2, NERR) = RAMN
+ END IF
+ IF( CAMN .NE. CA(H) ) THEN
+ NERR = NERR + 1
+ ERRIBUF(1, NERR) = TESTNUM
+ ERRIBUF(2, NERR) = NNODES
+ ERRIBUF(3, NERR) = DEST
+ ERRIBUF(4, NERR) = I
+ ERRIBUF(5, NERR) = J
+ ERRIBUF(6, NERR) = -15
+ ERRDBUF(1, NERR) = CA(H)
+ ERRDBUF(2, NERR) = CAMN
+ END IF
+ END IF
+ END IF
+ END IF
+ 90 CONTINUE
+ 100 CONTINUE
+*
+ RETURN
+*
+* End of ICHKAMN
+*
+ END
+*
+*
+ SUBROUTINE SAMNTEST( OUTNUM, VERB, TOPSREPEAT, TOPSCOHRNT, NSCOPE,
+ $ SCOPE0, NTOP, TOP0, NMAT, M0, N0, LDAS0,
+ $ LDAD0, LDI0, NDEST, RDEST0, CDEST0, NGRID,
+ $ CONTEXT0, P0, Q0, ISEED, RMEM, CMEM, RCLEN,
+ $ MEM, MEMLEN )
+*
+* -- BLACS tester (version 1.0) --
+* University of Tennessee
+* December 15, 1994
+*
+*
+* .. Scalar Arguments ..
+ INTEGER MEMLEN, NDEST, NGRID, NMAT, NSCOPE, NTOP, OUTNUM, RCLEN,
+ $ TOPSCOHRNT, TOPSREPEAT, VERB
+* ..
+* .. Array Arguments ..
+ CHARACTER*1 SCOPE0(NSCOPE), TOP0(NTOP)
+ INTEGER M0(NMAT), N0(NMAT), LDAS0(NMAT), LDAD0(NMAT), LDI0(NMAT)
+ INTEGER RDEST0(NDEST), CDEST0(NDEST), CONTEXT0(NGRID)
+ INTEGER P0(NGRID), Q0(NGRID), ISEED(*), RMEM(RCLEN), CMEM(RCLEN)
+ REAL MEM(MEMLEN)
+* ..
+*
+* Purpose
+* =======
+* STESTAMN: Test real AMN COMBINE
+*
+* Arguments
+* =========
+* OUTNUM (input) INTEGER
+* The device number to write output to.
+*
+* VERB (input) INTEGER
+* The level of verbosity (how much printing to do).
+*
+* NSCOPE (input) INTEGER
+* The number of scopes to be tested.
+*
+* SCOPE0 (input) CHARACTER*1 array of dimension (NSCOPE)
+* Values of the scopes to be tested.
+*
+* NTOP (input) INTEGER
+* The number of topologies to be tested.
+*
+* TOP0 (input) CHARACTER*1 array of dimension (NTOP)
+* Values of the topologies to be tested.
+*
+* NMAT (input) INTEGER
+* The number of matrices to be tested.
+*
+* M0 (input) INTEGER array of dimension (NMAT)
+* Values of M to be tested.
+*
+* M0 (input) INTEGER array of dimension (NMAT)
+* Values of M to be tested.
+*
+* N0 (input) INTEGER array of dimension (NMAT)
+* Values of N to be tested.
+*
+* LDAS0 (input) INTEGER array of dimension (NMAT)
+* Values of LDAS (leading dimension of A on source process)
+* to be tested.
+*
+* LDAD0 (input) INTEGER array of dimension (NMAT)
+* Values of LDAD (leading dimension of A on destination
+* process) to be tested.
+* LDI0 (input) INTEGER array of dimension (NMAT)
+* Values of LDI (leading dimension of RA/CA) to be tested.
+* If LDI == -1, these RA/CA should not be accessed.
+*
+* NDEST (input) INTEGER
+* The number of destinations to be tested.
+*
+* RDEST0 (input) INTEGER array of dimension (NNDEST)
+* Values of RDEST (row coordinate of destination) to be
+* tested.
+*
+* CDEST0 (input) INTEGER array of dimension (NNDEST)
+* Values of CDEST (column coordinate of destination) to be
+* tested.
+*
+* NGRID (input) INTEGER
+* The number of process grids to be tested.
+*
+* CONTEXT0 (input) INTEGER array of dimension (NGRID)
+* The BLACS context handles corresponding to the grids.
+*
+* P0 (input) INTEGER array of dimension (NGRID)
+* Values of P (number of process rows, NPROW).
+*
+* Q0 (input) INTEGER array of dimension (NGRID)
+* Values of Q (number of process columns, NPCOL).
+*
+* ISEED (workspace) INTEGER array of dimension ( MAX(NPROCS, NTESTS) )
+* Workspace used to hold each process's random number SEED.
+* This requires NPROCS (number of processor) elements.
+* If VERB < 2, this workspace also serves to indicate which
+* tests fail. This requires workspace of NTESTS
+* (number of tests performed).
+*
+* RMEM (workspace) INTEGER array of dimension (RCLEN)
+* Used for all RA arrays, and their pre and post padding.
+*
+* CMEM (workspace) INTEGER array of dimension (RCLEN)
+* Used for all CA arrays, and their pre and post padding.
+*
+* RCLEN (input) INTEGER
+* The length, in elements, of RMEM and CMEM.
+*
+* MEM (workspace) REAL array of dimension (MEMLEN)
+* Used for all other workspaces, including the matrix A,
+* and its pre and post padding.
+*
+* MEMLEN (input) INTEGER
+* The length, in elements, of MEM.
+*
+* =====================================================================
+*
+* .. External Functions ..
+ LOGICAL ALLPASS, LSAME
+ INTEGER IBTMYPROC, IBTNPROCS, IBTSIZEOF
+ EXTERNAL ALLPASS, LSAME, IBTMYPROC, IBTNPROCS, IBTSIZEOF
+* ..
+* .. External Subroutines ..
+ EXTERNAL BLACS_GRIDINFO, SGAMN2D
+ EXTERNAL SINITMAT, SCHKPAD, SBTCHECKIN
+* ..
+* .. Local Scalars ..
+ CHARACTER*1 SCOPE, TOP
+ LOGICAL INGRID, TESTOK, ALLRCV
+ INTEGER APTR, CAPTR, CDEST, CDEST2, CONTEXT, ERRDPTR, ERRIPTR, I,
+ $ IAM, ICHECKVAL, IDE, IGR, IMA, IPAD, IPOST, IPRE, ISC,
+ $ ISIZE, ISTART, ISTOP, ITC, ITC1, ITC2, ITO, ITR, ITR1,
+ $ ITR2, J, K, LDA, LDADST, LDASRC, LDI, M, MAXERR, MYCOL,
+ $ MYROW, N, NERR, NFAIL, NPCOL, NPROW, NSKIP, PREAPTR,
+ $ RAPTR, RDEST, RDEST2, SETWHAT, SSIZE, TESTNUM, VALPTR
+ REAL CHECKVAL
+* ..
+* .. Executable Statements ..
+*
+* Choose padding value, and make it unique
+*
+ CHECKVAL = -0.61E0
+ IAM = IBTMYPROC()
+ CHECKVAL = IAM * CHECKVAL
+ ISIZE = IBTSIZEOF('I')
+ SSIZE = IBTSIZEOF('S')
+ ICHECKVAL = -IAM
+*
+* Verify file parameters
+*
+ IF( IAM .EQ. 0 ) THEN
+ WRITE(OUTNUM, *) ' '
+ WRITE(OUTNUM, *) ' '
+ WRITE(OUTNUM, 1000 )
+ IF( VERB .GT. 0 ) THEN
+ WRITE(OUTNUM,*) ' '
+ WRITE(OUTNUM, 2000) 'NSCOPE:', NSCOPE
+ WRITE(OUTNUM, 3000) ' SCOPE:', ( SCOPE0(I), I = 1, NSCOPE )
+ WRITE(OUTNUM, 2000) 'TReps :', TOPSREPEAT
+ WRITE(OUTNUM, 2000) 'TCohr :', TOPSCOHRNT
+ WRITE(OUTNUM, 2000) 'NTOP :', NTOP
+ WRITE(OUTNUM, 3000) ' TOP :', ( TOP0(I), I = 1, NTOP )
+ WRITE(OUTNUM, 2000) 'NMAT :', NMAT
+ WRITE(OUTNUM, 2000) ' M :', ( M0(I), I = 1, NMAT )
+ WRITE(OUTNUM, 2000) ' N :', ( N0(I), I = 1, NMAT )
+ WRITE(OUTNUM, 2000) ' LDAS :', ( LDAS0(I), I = 1, NMAT )
+ WRITE(OUTNUM, 2000) ' LDAD :', ( LDAD0(I), I = 1, NMAT )
+ WRITE(OUTNUM, 2000) ' LDI :', ( LDI0(I), I = 1, NMAT )
+ WRITE(OUTNUM, 2000) 'NDEST :', NDEST
+ WRITE(OUTNUM, 2000) ' RDEST:',( RDEST0(I), I = 1, NDEST )
+ WRITE(OUTNUM, 2000) ' CDEST:',( CDEST0(I), I = 1, NDEST )
+ WRITE(OUTNUM, 2000) 'NGRIDS:', NGRID
+ WRITE(OUTNUM, 2000) ' P :', ( P0(I), I = 1, NGRID )
+ WRITE(OUTNUM, 2000) ' Q :', ( Q0(I), I = 1, NGRID )
+ WRITE(OUTNUM, 2000) 'VERB :', VERB
+ WRITE(OUTNUM,*) ' '
+ END IF
+ IF( VERB .GT. 1 ) THEN
+ WRITE(OUTNUM,4000)
+ WRITE(OUTNUM,5000)
+ END IF
+ END IF
+ IF (TOPSREPEAT.EQ.0) THEN
+ ITR1 = 0
+ ITR2 = 0
+ ELSE IF (TOPSREPEAT.EQ.1) THEN
+ ITR1 = 1
+ ITR2 = 1
+ ELSE
+ ITR1 = 0
+ ITR2 = 1
+ END IF
+*
+* Find biggest matrix, so we know where to stick error info
+*
+ I = 0
+ DO 10 IMA = 1, NMAT
+ IPAD = 4 * M0(IMA)
+ K = N0(IMA) * MAX0( LDAS0(IMA), LDAD0(IMA) ) + IPAD
+ IF( K .GT. I ) I = K
+ 10 CONTINUE
+ I = I + IBTNPROCS()
+ MAXERR = ( SSIZE * (MEMLEN-I) ) / ( SSIZE*2 + ISIZE*6 )
+ IF( MAXERR .LT. 1 ) THEN
+ WRITE(OUTNUM,*) 'ERROR: Not enough memory to run MIN tests.'
+ CALL BLACS_ABORT(-1, 1)
+ END IF
+ ERRDPTR = I + 1
+ ERRIPTR = ERRDPTR + MAXERR
+ NERR = 0
+ TESTNUM = 0
+ NFAIL = 0
+ NSKIP = 0
+*
+* Loop over grids of matrix
+*
+ DO 90 IGR = 1, NGRID
+*
+* allocate process grid for the next batch of tests
+*
+ CONTEXT = CONTEXT0(IGR)
+ CALL BLACS_GRIDINFO( CONTEXT, NPROW, NPCOL, MYROW, MYCOL )
+ INGRID = ( (MYROW.LT.NPROW) .AND. (MYCOL.LT.NPCOL) )
+*
+ DO 80 ISC = 1, NSCOPE
+ SCOPE = SCOPE0(ISC)
+ DO 70 ITO = 1, NTOP
+ TOP = TOP0(ITO)
+*
+* If testing multiring ('M') or general tree ('T'), need to
+* loop over calls to BLACS_SET to do full test
+*
+ IF( LSAME(TOP, 'M') ) THEN
+ SETWHAT = 13
+ IF( SCOPE .EQ. 'R' ) THEN
+ ISTART = -(NPCOL - 1)
+ ISTOP = -ISTART
+ ELSE IF (SCOPE .EQ. 'C') THEN
+ ISTART = -(NPROW - 1)
+ ISTOP = -ISTART
+ ELSE
+ ISTART = -(NPROW*NPCOL - 1)
+ ISTOP = -ISTART
+ ENDIF
+ ELSE IF( LSAME(TOP, 'T') ) THEN
+ SETWHAT = 14
+ ISTART = 1
+ IF( SCOPE .EQ. 'R' ) THEN
+ ISTOP = NPCOL - 1
+ ELSE IF (SCOPE .EQ. 'C') THEN
+ ISTOP = NPROW - 1
+ ELSE
+ ISTOP = NPROW*NPCOL - 1
+ ENDIF
+ ELSE
+ SETWHAT = 0
+ ISTART = 1
+ ISTOP = 1
+ ENDIF
+ DO 60 IMA = 1, NMAT
+ M = M0(IMA)
+ N = N0(IMA)
+ LDASRC = LDAS0(IMA)
+ LDADST = LDAD0(IMA)
+ LDI = LDI0(IMA)
+ IPRE = 2 * M
+ IPOST = IPRE
+ PREAPTR = 1
+ APTR = PREAPTR + IPRE
+*
+ DO 50 IDE = 1, NDEST
+ TESTNUM = TESTNUM + 1
+ RDEST2 = RDEST0(IDE)
+ CDEST2 = CDEST0(IDE)
+*
+* If everyone gets the answer, create some bogus rdest/cdest
+* so IF's are easier
+*
+ ALLRCV = ( (RDEST2.EQ.-1) .OR. (CDEST2.EQ.-1) )
+ IF( ALLRCV ) THEN
+ RDEST = NPROW - 1
+ CDEST = NPCOL - 1
+ IF (TOPSCOHRNT.EQ.0) THEN
+ ITR1 = 0
+ ITR2 = 0
+ ELSE IF (TOPSCOHRNT.EQ.1) THEN
+ ITR1 = 1
+ ITR2 = 1
+ ELSE
+ ITR1 = 0
+ ITR2 = 1
+ END IF
+ ELSE
+ RDEST = RDEST2
+ CDEST = CDEST2
+ ITC1 = 0
+ ITC2 = 0
+ END IF
+ IF( RDEST.GE.P0(IGR) .OR. CDEST.GE.Q0(IGR) ) THEN
+ NSKIP = NSKIP + 1
+ GOTO 50
+ END IF
+*
+ IF( MYROW.EQ.RDEST .AND. MYCOL.EQ.CDEST ) THEN
+ LDA = LDADST
+ ELSE
+ LDA = LDASRC
+ END IF
+ VALPTR = APTR + IPOST + N * LDA
+ IF( VERB .GT. 1 ) THEN
+ IF( IAM .EQ. 0 ) THEN
+ WRITE(OUTNUM, 6000)
+ $ TESTNUM, 'RUNNING', SCOPE, TOP, M, N,
+ $ LDASRC, LDADST, LDI, RDEST2, CDEST2,
+ $ NPROW, NPCOL
+ END IF
+ END IF
+*
+* If I am in scope
+*
+ TESTOK = .TRUE.
+ IF( INGRID ) THEN
+ IF( (MYROW.EQ.RDEST .AND. SCOPE.EQ.'R') .OR.
+ $ (MYCOL.EQ.CDEST .AND. SCOPE.EQ.'C') .OR.
+ $ (SCOPE .EQ. 'A') ) THEN
+*
+ K = NERR
+ DO 40 ITR = ITR1, ITR2
+ CALL BLACS_SET(CONTEXT, 15, ITR)
+ DO 35 ITC = ITC1, ITC2
+ CALL BLACS_SET(CONTEXT, 16, ITC)
+ DO 30 J = ISTART, ISTOP
+ IF( J.EQ.0) GOTO 30
+ IF( SETWHAT.NE.0 )
+ $ CALL BLACS_SET(CONTEXT, SETWHAT, J)
+*
+*
+* generate and pad matrix A
+*
+ CALL SINITMAT('G','-', M, N, MEM(PREAPTR),
+ $ LDA, IPRE, IPOST,
+ $ CHECKVAL, TESTNUM,
+ $ MYROW, MYCOL )
+*
+* If they exist, pad RA and CA arrays
+*
+ IF( LDI .NE. -1 ) THEN
+ DO 15 I = 1, N*LDI + IPRE + IPOST
+ RMEM(I) = ICHECKVAL
+ CMEM(I) = ICHECKVAL
+ 15 CONTINUE
+ RAPTR = 1 + IPRE
+ CAPTR = 1 + IPRE
+ ELSE
+ DO 20 I = 1, IPRE+IPOST
+ RMEM(I) = ICHECKVAL
+ CMEM(I) = ICHECKVAL
+ 20 CONTINUE
+ RAPTR = 1
+ CAPTR = 1
+ END IF
+*
+ CALL SGAMN2D(CONTEXT, SCOPE, TOP, M, N,
+ $ MEM(APTR), LDA, RMEM(RAPTR),
+ $ CMEM(CAPTR), LDI,
+ $ RDEST2, CDEST2)
+*
+* If I've got the answer, check for errors in
+* matrix or padding
+*
+ IF( (MYROW.EQ.RDEST .AND. MYCOL.EQ.CDEST)
+ $ .OR. ALLRCV ) THEN
+ CALL SCHKPAD('G','-', M, N,
+ $ MEM(PREAPTR), LDA, RDEST,
+ $ CDEST, MYROW, MYCOL,
+ $ IPRE, IPOST, CHECKVAL,
+ $ TESTNUM, MAXERR, NERR,
+ $ MEM(ERRIPTR),MEM(ERRDPTR))
+ CALL SCHKAMN(SCOPE, CONTEXT, M, N,
+ $ MEM(APTR), LDA,
+ $ RMEM(RAPTR), CMEM(CAPTR),
+ $ LDI, TESTNUM, MAXERR,NERR,
+ $ MEM(ERRIPTR),MEM(ERRDPTR),
+ $ ISEED, MEM(VALPTR))
+ CALL SRCCHK(IPRE, IPOST, ICHECKVAL,
+ $ M, N, RMEM, CMEM, LDI,
+ $ MYROW, MYCOL, TESTNUM,
+ $ MAXERR, NERR,
+ $ MEM(ERRIPTR), MEM(ERRDPTR))
+ END IF
+ 30 CONTINUE
+ CALL BLACS_SET(CONTEXT, 16, 0)
+ 35 CONTINUE
+ CALL BLACS_SET(CONTEXT, 15, 0)
+ 40 CONTINUE
+ TESTOK = ( K .EQ. NERR )
+ END IF
+ END IF
+*
+ IF( VERB .GT. 1 ) THEN
+ I = NERR
+ CALL SBTCHECKIN(0, OUTNUM, MAXERR, NERR,
+ $ MEM(ERRIPTR), MEM(ERRDPTR), ISEED)
+ IF( IAM .EQ. 0 ) THEN
+ IF( TESTOK .AND. NERR.EQ.I ) THEN
+ WRITE(OUTNUM,6000)TESTNUM,'PASSED ',
+ $ SCOPE, TOP, M, N, LDASRC,
+ $ LDADST, LDI, RDEST2, CDEST2,
+ $ NPROW, NPCOL
+ ELSE
+ NFAIL = NFAIL + 1
+ WRITE(OUTNUM,6000)TESTNUM,'FAILED ',
+ $ SCOPE, TOP, M, N, LDASRC,
+ $ LDADST, LDI, RDEST2, CDEST2,
+ $ NPROW, NPCOL
+ END IF
+ END IF
+*
+* Once we've printed out errors, can re-use buf space
+*
+ NERR = 0
+ END IF
+ 50 CONTINUE
+ 60 CONTINUE
+ 70 CONTINUE
+ 80 CONTINUE
+ 90 CONTINUE
+*
+ IF( VERB .LT. 2 ) THEN
+ NFAIL = TESTNUM
+ CALL SBTCHECKIN( NFAIL, OUTNUM, MAXERR, NERR, MEM(ERRIPTR),
+ $ MEM(ERRDPTR), ISEED )
+ END IF
+ IF( IAM .EQ. 0 ) THEN
+ IF( VERB .GT. 1 ) WRITE(OUTNUM,*) ' '
+ IF( NFAIL+NSKIP .EQ. 0 ) THEN
+ WRITE(OUTNUM, 7000 ) TESTNUM
+ ELSE
+ WRITE(OUTNUM, 8000 ) TESTNUM, TESTNUM-NSKIP-NFAIL,
+ $ NSKIP, NFAIL
+ END IF
+ END IF
+*
+* Log whether their were any failures
+*
+ TESTOK = ALLPASS( (NFAIL.EQ.0) )
+*
+ 1000 FORMAT('REAL AMN TESTS: BEGIN.' )
+ 2000 FORMAT(1X,A7,3X,10I6)
+ 3000 FORMAT(1X,A7,3X,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1,
+ $ 5X,A1,5X,A1)
+ 4000 FORMAT(' TEST# STATUS SCOPE TOP M N LDAS LDAD LDI ',
+ $ 'RDEST CDEST P Q')
+ 5000 FORMAT(' ----- ------- ----- --- ----- ----- ----- ----- ----- ',
+ $ '----- ----- ---- ----')
+ 6000 FORMAT(I6,1X,A7,5X,A1,3X,A1,7I6,2I5)
+ 7000 FORMAT('REAL AMN TESTS: PASSED ALL',
+ $ I5, ' TESTS.')
+ 8000 FORMAT('REAL AMN TESTS:',I5,' TESTS;',I5,' PASSED,',
+ $ I5,' SKIPPED,',I5,' FAILED.')
+*
+ RETURN
+*
+* End of STESTAMN.
+*
+ END
+*
+ SUBROUTINE SCHKAMN( SCOPE, ICTXT, M, N, A, LDA, RA, CA, LDI,
+ $ TESTNUM, MAXERR, NERR, ERRIBUF, ERRDBUF,
+ $ ISEED, VALS )
+*
+* .. Scalar Arguments ..
+ CHARACTER*1 SCOPE
+ INTEGER ICTXT, M, N, LDA, LDI, TESTNUM, MAXERR, NERR
+* ..
+* .. Array Arguments ..
+ INTEGER RA(*), CA(*), ERRIBUF(6, MAXERR), ISEED(*)
+ REAL A(LDA,*), ERRDBUF(2, MAXERR), VALS(*)
+* ..
+* .. External Functions ..
+ INTEGER IBTMYPROC, IBTNPROCS, IBTSPNUM
+ REAL SBTEPS, SBTABS
+ REAL SBTRAN
+ EXTERNAL IBTMYPROC, IBTNPROCS, IBTSPNUM, SBTRAN, SBTEPS, SBTABS
+* ..
+* .. External Subroutines ..
+ EXTERNAL IBTSPCOORD
+* ..
+* .. Local Scalars ..
+ LOGICAL ERROR
+ INTEGER NPROCS, NNODES, NPROW, NPCOL, MYROW, MYCOL, RAMN, CAMN
+ INTEGER IAMN, I, J, K, H, DEST, NODE
+ REAL EPS
+* ..
+* .. Executable Statements ..
+*
+ NPROCS = IBTNPROCS()
+ EPS = SBTEPS()
+ CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL )
+ DEST = MYROW*NPROCS + MYCOL
+*
+* Set up seeds to match those used by each proc's genmat call
+*
+ IF( SCOPE .EQ. 'R' ) THEN
+ NNODES = NPCOL
+ DO 10 I = 0, NNODES-1
+ NODE = MYROW * NPROCS + I
+ ISEED(I*4+1) = MOD( 1002 + TESTNUM*5 + NODE*3, 4096 )
+ ISEED(I*4+2) = MOD( 2027 + TESTNUM*7 + NODE, 4096 )
+ ISEED(I*4+3) = MOD( 1234 + TESTNUM + NODE*3, 4096 )
+ ISEED(I*4+4) = MOD( 4311 + TESTNUM*10 + NODE*2, 4096 )
+ 10 CONTINUE
+ ELSE IF( SCOPE .EQ. 'C' ) THEN
+ NNODES = NPROW
+ DO 20 I = 0, NNODES-1
+ NODE = I * NPROCS + MYCOL
+ ISEED(I*4+1) = MOD( 1002 + TESTNUM*5 + NODE*3, 4096 )
+ ISEED(I*4+2) = MOD( 2027 + TESTNUM*7 + NODE, 4096 )
+ ISEED(I*4+3) = MOD( 1234 + TESTNUM + NODE*3, 4096 )
+ ISEED(I*4+4) = MOD( 4311 + TESTNUM*10 + NODE*2, 4096 )
+ 20 CONTINUE
+ ELSE
+ NNODES = NPROW * NPCOL
+ DO 30 I = 0, NNODES-1
+ NODE = (I / NPCOL) * NPROCS + MOD(I, NPCOL)
+ ISEED(I*4+1) = MOD( 1002 + TESTNUM*5 + NODE*3, 4096 )
+ ISEED(I*4+2) = MOD( 2027 + TESTNUM*7 + NODE, 4096 )
+ ISEED(I*4+3) = MOD( 1234 + TESTNUM + NODE*3, 4096 )
+ ISEED(I*4+4) = MOD( 4311 + TESTNUM*10 + NODE*2, 4096 )
+ 30 CONTINUE
+ END IF
+*
+ DO 100 J = 1, N
+ DO 90 I = 1, M
+ H = (J-1)*LDI + I
+ VALS(1) = SBTRAN( ISEED )
+ IAMN = 1
+ IF( NNODES .GT. 1 ) THEN
+ DO 40 K = 1, NNODES-1
+ VALS(K+1) = SBTRAN( ISEED(K*4+1) )
+ IF( SBTABS( VALS(K+1) ) .LT. SBTABS( VALS(IAMN) ) )
+ $ IAMN = K + 1
+ 40 CONTINUE
+ END IF
+*
+* If BLACS have not returned same value we've chosen
+*
+ IF( A(I,J) .NE. VALS(IAMN) ) THEN
+*
+* If we have RA and CA arrays
+*
+ IF( LDI .NE. -1 ) THEN
+*
+* Any number having the same absolute value is a valid max
+*
+ K = IBTSPNUM( SCOPE, RA(H), CA(H), NPCOL ) + 1
+ IF( K.GT.0 .AND. K.LE.NNODES ) THEN
+ ERROR = SBTABS( VALS(K) ).NE.SBTABS( VALS(IAMN) )
+ IF( .NOT.ERROR ) IAMN = K
+ ELSE
+ ERROR = .TRUE.
+ END IF
+ ELSE
+*
+* Error if BLACS answer not same absolute value, or if it
+* was not really in the numbers being compared
+*
+ ERROR = ( SBTABS( A(I,J) ) .NE. SBTABS( VALS(IAMN) ) )
+ IF( .NOT.ERROR ) THEN
+ DO 50 K = 1, NNODES
+ IF( VALS(K) .EQ. A(I,J) ) GOTO 60
+ 50 CONTINUE
+ ERROR = .TRUE.
+ 60 CONTINUE
+ ENDIF
+ END IF
+*
+* If the value is in error
+*
+ IF( ERROR ) THEN
+ NERR = NERR + 1
+ ERRIBUF(1, NERR) = TESTNUM
+ ERRIBUF(2, NERR) = NNODES
+ ERRIBUF(3, NERR) = DEST
+ ERRIBUF(4, NERR) = I
+ ERRIBUF(5, NERR) = J
+ ERRIBUF(6, NERR) = 5
+ ERRDBUF(1, NERR) = A(I,J)
+ ERRDBUF(2, NERR) = VALS(IAMN)
+ END IF
+ END IF
+*
+* If they are defined, make sure coordinate entries are OK
+*
+ IF( LDI .NE. -1 ) THEN
+ K = IBTSPNUM( SCOPE, RA(H), CA(H), NPCOL ) + 1
+ IF( K.NE.IAMN ) THEN
+*
+* Make sure more than one proc doesn't have exact same value
+* (and therefore there may be more than one valid coordinate
+* for a single value)
+*
+ IF( K.GT.NNODES .OR. K.LT.1 ) THEN
+ ERROR = .TRUE.
+ ELSE
+ ERROR = ( VALS(K) .NE. VALS(IAMN) )
+ END IF
+ IF( ERROR ) THEN
+ CALL IBTSPCOORD( SCOPE, IAMN-1, MYROW, MYCOL,
+ $ NPCOL, RAMN, CAMN )
+ IF( RAMN .NE. RA(H) ) THEN
+ NERR = NERR + 1
+ ERRIBUF(1, NERR) = TESTNUM
+ ERRIBUF(2, NERR) = NNODES
+ ERRIBUF(3, NERR) = DEST
+ ERRIBUF(4, NERR) = I
+ ERRIBUF(5, NERR) = J
+ ERRIBUF(6, NERR) = -5
+ ERRDBUF(1, NERR) = RA(H)
+ ERRDBUF(2, NERR) = RAMN
+ END IF
+ IF( CAMN .NE. CA(H) ) THEN
+ NERR = NERR + 1
+ ERRIBUF(1, NERR) = TESTNUM
+ ERRIBUF(2, NERR) = NNODES
+ ERRIBUF(3, NERR) = DEST
+ ERRIBUF(4, NERR) = I
+ ERRIBUF(5, NERR) = J
+ ERRIBUF(6, NERR) = -15
+ ERRDBUF(1, NERR) = CA(H)
+ ERRDBUF(2, NERR) = CAMN
+ END IF
+ END IF
+ END IF
+ END IF
+ 90 CONTINUE
+ 100 CONTINUE
+*
+ RETURN
+*
+* End of SCHKAMN
+*
+ END
+*
+*
+ SUBROUTINE DAMNTEST( OUTNUM, VERB, TOPSREPEAT, TOPSCOHRNT, NSCOPE,
+ $ SCOPE0, NTOP, TOP0, NMAT, M0, N0, LDAS0,
+ $ LDAD0, LDI0, NDEST, RDEST0, CDEST0, NGRID,
+ $ CONTEXT0, P0, Q0, ISEED, RMEM, CMEM, RCLEN,
+ $ MEM, MEMLEN )
+*
+* -- BLACS tester (version 1.0) --
+* University of Tennessee
+* December 15, 1994
+*
+*
+* .. Scalar Arguments ..
+ INTEGER MEMLEN, NDEST, NGRID, NMAT, NSCOPE, NTOP, OUTNUM, RCLEN,
+ $ TOPSCOHRNT, TOPSREPEAT, VERB
+* ..
+* .. Array Arguments ..
+ CHARACTER*1 SCOPE0(NSCOPE), TOP0(NTOP)
+ INTEGER M0(NMAT), N0(NMAT), LDAS0(NMAT), LDAD0(NMAT), LDI0(NMAT)
+ INTEGER RDEST0(NDEST), CDEST0(NDEST), CONTEXT0(NGRID)
+ INTEGER P0(NGRID), Q0(NGRID), ISEED(*), RMEM(RCLEN), CMEM(RCLEN)
+ DOUBLE PRECISION MEM(MEMLEN)
+* ..
+*
+* Purpose
+* =======
+* DTESTAMN: Test double precision AMN COMBINE
+*
+* Arguments
+* =========
+* OUTNUM (input) INTEGER
+* The device number to write output to.
+*
+* VERB (input) INTEGER
+* The level of verbosity (how much printing to do).
+*
+* NSCOPE (input) INTEGER
+* The number of scopes to be tested.
+*
+* SCOPE0 (input) CHARACTER*1 array of dimension (NSCOPE)
+* Values of the scopes to be tested.
+*
+* NTOP (input) INTEGER
+* The number of topologies to be tested.
+*
+* TOP0 (input) CHARACTER*1 array of dimension (NTOP)
+* Values of the topologies to be tested.
+*
+* NMAT (input) INTEGER
+* The number of matrices to be tested.
+*
+* M0 (input) INTEGER array of dimension (NMAT)
+* Values of M to be tested.
+*
+* M0 (input) INTEGER array of dimension (NMAT)
+* Values of M to be tested.
+*
+* N0 (input) INTEGER array of dimension (NMAT)
+* Values of N to be tested.
+*
+* LDAS0 (input) INTEGER array of dimension (NMAT)
+* Values of LDAS (leading dimension of A on source process)
+* to be tested.
+*
+* LDAD0 (input) INTEGER array of dimension (NMAT)
+* Values of LDAD (leading dimension of A on destination
+* process) to be tested.
+* LDI0 (input) INTEGER array of dimension (NMAT)
+* Values of LDI (leading dimension of RA/CA) to be tested.
+* If LDI == -1, these RA/CA should not be accessed.
+*
+* NDEST (input) INTEGER
+* The number of destinations to be tested.
+*
+* RDEST0 (input) INTEGER array of dimension (NNDEST)
+* Values of RDEST (row coordinate of destination) to be
+* tested.
+*
+* CDEST0 (input) INTEGER array of dimension (NNDEST)
+* Values of CDEST (column coordinate of destination) to be
+* tested.
+*
+* NGRID (input) INTEGER
+* The number of process grids to be tested.
+*
+* CONTEXT0 (input) INTEGER array of dimension (NGRID)
+* The BLACS context handles corresponding to the grids.
+*
+* P0 (input) INTEGER array of dimension (NGRID)
+* Values of P (number of process rows, NPROW).
+*
+* Q0 (input) INTEGER array of dimension (NGRID)
+* Values of Q (number of process columns, NPCOL).
+*
+* ISEED (workspace) INTEGER array of dimension ( MAX(NPROCS, NTESTS) )
+* Workspace used to hold each process's random number SEED.
+* This requires NPROCS (number of processor) elements.
+* If VERB < 2, this workspace also serves to indicate which
+* tests fail. This requires workspace of NTESTS
+* (number of tests performed).
+*
+* RMEM (workspace) INTEGER array of dimension (RCLEN)
+* Used for all RA arrays, and their pre and post padding.
+*
+* CMEM (workspace) INTEGER array of dimension (RCLEN)
+* Used for all CA arrays, and their pre and post padding.
+*
+* RCLEN (input) INTEGER
+* The length, in elements, of RMEM and CMEM.
+*
+* MEM (workspace) DOUBLE PRECISION array of dimension (MEMLEN)
+* Used for all other workspaces, including the matrix A,
+* and its pre and post padding.
+*
+* MEMLEN (input) INTEGER
+* The length, in elements, of MEM.
+*
+* =====================================================================
+*
+* .. External Functions ..
+ LOGICAL ALLPASS, LSAME
+ INTEGER IBTMYPROC, IBTNPROCS, IBTSIZEOF
+ EXTERNAL ALLPASS, LSAME, IBTMYPROC, IBTNPROCS, IBTSIZEOF
+* ..
+* .. External Subroutines ..
+ EXTERNAL BLACS_GRIDINFO, DGAMN2D
+ EXTERNAL DINITMAT, DCHKPAD, DBTCHECKIN
+* ..
+* .. Local Scalars ..
+ CHARACTER*1 SCOPE, TOP
+ LOGICAL INGRID, TESTOK, ALLRCV
+ INTEGER APTR, CAPTR, CDEST, CDEST2, CONTEXT, DSIZE, ERRDPTR,
+ $ ERRIPTR, I, IAM, ICHECKVAL, IDE, IGR, IMA, IPAD, IPOST,
+ $ IPRE, ISC, ISIZE, ISTART, ISTOP, ITC, ITC1, ITC2, ITO,
+ $ ITR, ITR1, ITR2, J, K, LDA, LDADST, LDASRC, LDI, M,
+ $ MAXERR, MYCOL, MYROW, N, NERR, NFAIL, NPCOL, NPROW, NSKIP,
+ $ PREAPTR, RAPTR, RDEST, RDEST2, SETWHAT, TESTNUM, VALPTR
+ DOUBLE PRECISION CHECKVAL
+* ..
+* .. Executable Statements ..
+*
+* Choose padding value, and make it unique
+*
+ CHECKVAL = -0.81D0
+ IAM = IBTMYPROC()
+ CHECKVAL = IAM * CHECKVAL
+ ISIZE = IBTSIZEOF('I')
+ DSIZE = IBTSIZEOF('D')
+ ICHECKVAL = -IAM
+*
+* Verify file parameters
+*
+ IF( IAM .EQ. 0 ) THEN
+ WRITE(OUTNUM, *) ' '
+ WRITE(OUTNUM, *) ' '
+ WRITE(OUTNUM, 1000 )
+ IF( VERB .GT. 0 ) THEN
+ WRITE(OUTNUM,*) ' '
+ WRITE(OUTNUM, 2000) 'NSCOPE:', NSCOPE
+ WRITE(OUTNUM, 3000) ' SCOPE:', ( SCOPE0(I), I = 1, NSCOPE )
+ WRITE(OUTNUM, 2000) 'TReps :', TOPSREPEAT
+ WRITE(OUTNUM, 2000) 'TCohr :', TOPSCOHRNT
+ WRITE(OUTNUM, 2000) 'NTOP :', NTOP
+ WRITE(OUTNUM, 3000) ' TOP :', ( TOP0(I), I = 1, NTOP )
+ WRITE(OUTNUM, 2000) 'NMAT :', NMAT
+ WRITE(OUTNUM, 2000) ' M :', ( M0(I), I = 1, NMAT )
+ WRITE(OUTNUM, 2000) ' N :', ( N0(I), I = 1, NMAT )
+ WRITE(OUTNUM, 2000) ' LDAS :', ( LDAS0(I), I = 1, NMAT )
+ WRITE(OUTNUM, 2000) ' LDAD :', ( LDAD0(I), I = 1, NMAT )
+ WRITE(OUTNUM, 2000) ' LDI :', ( LDI0(I), I = 1, NMAT )
+ WRITE(OUTNUM, 2000) 'NDEST :', NDEST
+ WRITE(OUTNUM, 2000) ' RDEST:',( RDEST0(I), I = 1, NDEST )
+ WRITE(OUTNUM, 2000) ' CDEST:',( CDEST0(I), I = 1, NDEST )
+ WRITE(OUTNUM, 2000) 'NGRIDS:', NGRID
+ WRITE(OUTNUM, 2000) ' P :', ( P0(I), I = 1, NGRID )
+ WRITE(OUTNUM, 2000) ' Q :', ( Q0(I), I = 1, NGRID )
+ WRITE(OUTNUM, 2000) 'VERB :', VERB
+ WRITE(OUTNUM,*) ' '
+ END IF
+ IF( VERB .GT. 1 ) THEN
+ WRITE(OUTNUM,4000)
+ WRITE(OUTNUM,5000)
+ END IF
+ END IF
+ IF (TOPSREPEAT.EQ.0) THEN
+ ITR1 = 0
+ ITR2 = 0
+ ELSE IF (TOPSREPEAT.EQ.1) THEN
+ ITR1 = 1
+ ITR2 = 1
+ ELSE
+ ITR1 = 0
+ ITR2 = 1
+ END IF
+*
+* Find biggest matrix, so we know where to stick error info
+*
+ I = 0
+ DO 10 IMA = 1, NMAT
+ IPAD = 4 * M0(IMA)
+ K = N0(IMA) * MAX0( LDAS0(IMA), LDAD0(IMA) ) + IPAD
+ IF( K .GT. I ) I = K
+ 10 CONTINUE
+ I = I + IBTNPROCS()
+ MAXERR = ( DSIZE * (MEMLEN-I) ) / ( DSIZE*2 + ISIZE*6 )
+ IF( MAXERR .LT. 1 ) THEN
+ WRITE(OUTNUM,*) 'ERROR: Not enough memory to run MIN tests.'
+ CALL BLACS_ABORT(-1, 1)
+ END IF
+ ERRDPTR = I + 1
+ ERRIPTR = ERRDPTR + MAXERR
+ NERR = 0
+ TESTNUM = 0
+ NFAIL = 0
+ NSKIP = 0
+*
+* Loop over grids of matrix
+*
+ DO 90 IGR = 1, NGRID
+*
+* allocate process grid for the next batch of tests
+*
+ CONTEXT = CONTEXT0(IGR)
+ CALL BLACS_GRIDINFO( CONTEXT, NPROW, NPCOL, MYROW, MYCOL )
+ INGRID = ( (MYROW.LT.NPROW) .AND. (MYCOL.LT.NPCOL) )
+*
+ DO 80 ISC = 1, NSCOPE
+ SCOPE = SCOPE0(ISC)
+ DO 70 ITO = 1, NTOP
+ TOP = TOP0(ITO)
+*
+* If testing multiring ('M') or general tree ('T'), need to
+* loop over calls to BLACS_SET to do full test
+*
+ IF( LSAME(TOP, 'M') ) THEN
+ SETWHAT = 13
+ IF( SCOPE .EQ. 'R' ) THEN
+ ISTART = -(NPCOL - 1)
+ ISTOP = -ISTART
+ ELSE IF (SCOPE .EQ. 'C') THEN
+ ISTART = -(NPROW - 1)
+ ISTOP = -ISTART
+ ELSE
+ ISTART = -(NPROW*NPCOL - 1)
+ ISTOP = -ISTART
+ ENDIF
+ ELSE IF( LSAME(TOP, 'T') ) THEN
+ SETWHAT = 14
+ ISTART = 1
+ IF( SCOPE .EQ. 'R' ) THEN
+ ISTOP = NPCOL - 1
+ ELSE IF (SCOPE .EQ. 'C') THEN
+ ISTOP = NPROW - 1
+ ELSE
+ ISTOP = NPROW*NPCOL - 1
+ ENDIF
+ ELSE
+ SETWHAT = 0
+ ISTART = 1
+ ISTOP = 1
+ ENDIF
+ DO 60 IMA = 1, NMAT
+ M = M0(IMA)
+ N = N0(IMA)
+ LDASRC = LDAS0(IMA)
+ LDADST = LDAD0(IMA)
+ LDI = LDI0(IMA)
+ IPRE = 2 * M
+ IPOST = IPRE
+ PREAPTR = 1
+ APTR = PREAPTR + IPRE
+*
+ DO 50 IDE = 1, NDEST
+ TESTNUM = TESTNUM + 1
+ RDEST2 = RDEST0(IDE)
+ CDEST2 = CDEST0(IDE)
+*
+* If everyone gets the answer, create some bogus rdest/cdest
+* so IF's are easier
+*
+ ALLRCV = ( (RDEST2.EQ.-1) .OR. (CDEST2.EQ.-1) )
+ IF( ALLRCV ) THEN
+ RDEST = NPROW - 1
+ CDEST = NPCOL - 1
+ IF (TOPSCOHRNT.EQ.0) THEN
+ ITR1 = 0
+ ITR2 = 0
+ ELSE IF (TOPSCOHRNT.EQ.1) THEN
+ ITR1 = 1
+ ITR2 = 1
+ ELSE
+ ITR1 = 0
+ ITR2 = 1
+ END IF
+ ELSE
+ RDEST = RDEST2
+ CDEST = CDEST2
+ ITC1 = 0
+ ITC2 = 0
+ END IF
+ IF( RDEST.GE.P0(IGR) .OR. CDEST.GE.Q0(IGR) ) THEN
+ NSKIP = NSKIP + 1
+ GOTO 50
+ END IF
+*
+ IF( MYROW.EQ.RDEST .AND. MYCOL.EQ.CDEST ) THEN
+ LDA = LDADST
+ ELSE
+ LDA = LDASRC
+ END IF
+ VALPTR = APTR + IPOST + N * LDA
+ IF( VERB .GT. 1 ) THEN
+ IF( IAM .EQ. 0 ) THEN
+ WRITE(OUTNUM, 6000)
+ $ TESTNUM, 'RUNNING', SCOPE, TOP, M, N,
+ $ LDASRC, LDADST, LDI, RDEST2, CDEST2,
+ $ NPROW, NPCOL
+ END IF
+ END IF
+*
+* If I am in scope
+*
+ TESTOK = .TRUE.
+ IF( INGRID ) THEN
+ IF( (MYROW.EQ.RDEST .AND. SCOPE.EQ.'R') .OR.
+ $ (MYCOL.EQ.CDEST .AND. SCOPE.EQ.'C') .OR.
+ $ (SCOPE .EQ. 'A') ) THEN
+*
+ K = NERR
+ DO 40 ITR = ITR1, ITR2
+ CALL BLACS_SET(CONTEXT, 15, ITR)
+ DO 35 ITC = ITC1, ITC2
+ CALL BLACS_SET(CONTEXT, 16, ITC)
+ DO 30 J = ISTART, ISTOP
+ IF( J.EQ.0) GOTO 30
+ IF( SETWHAT.NE.0 )
+ $ CALL BLACS_SET(CONTEXT, SETWHAT, J)
+*
+*
+* generate and pad matrix A
+*
+ CALL DINITMAT('G','-', M, N, MEM(PREAPTR),
+ $ LDA, IPRE, IPOST,
+ $ CHECKVAL, TESTNUM,
+ $ MYROW, MYCOL )
+*
+* If they exist, pad RA and CA arrays
+*
+ IF( LDI .NE. -1 ) THEN
+ DO 15 I = 1, N*LDI + IPRE + IPOST
+ RMEM(I) = ICHECKVAL
+ CMEM(I) = ICHECKVAL
+ 15 CONTINUE
+ RAPTR = 1 + IPRE
+ CAPTR = 1 + IPRE
+ ELSE
+ DO 20 I = 1, IPRE+IPOST
+ RMEM(I) = ICHECKVAL
+ CMEM(I) = ICHECKVAL
+ 20 CONTINUE
+ RAPTR = 1
+ CAPTR = 1
+ END IF
+*
+ CALL DGAMN2D(CONTEXT, SCOPE, TOP, M, N,
+ $ MEM(APTR), LDA, RMEM(RAPTR),
+ $ CMEM(CAPTR), LDI,
+ $ RDEST2, CDEST2)
+*
+* If I've got the answer, check for errors in
+* matrix or padding
+*
+ IF( (MYROW.EQ.RDEST .AND. MYCOL.EQ.CDEST)
+ $ .OR. ALLRCV ) THEN
+ CALL DCHKPAD('G','-', M, N,
+ $ MEM(PREAPTR), LDA, RDEST,
+ $ CDEST, MYROW, MYCOL,
+ $ IPRE, IPOST, CHECKVAL,
+ $ TESTNUM, MAXERR, NERR,
+ $ MEM(ERRIPTR),MEM(ERRDPTR))
+ CALL DCHKAMN(SCOPE, CONTEXT, M, N,
+ $ MEM(APTR), LDA,
+ $ RMEM(RAPTR), CMEM(CAPTR),
+ $ LDI, TESTNUM, MAXERR,NERR,
+ $ MEM(ERRIPTR),MEM(ERRDPTR),
+ $ ISEED, MEM(VALPTR))
+ CALL DRCCHK(IPRE, IPOST, ICHECKVAL,
+ $ M, N, RMEM, CMEM, LDI,
+ $ MYROW, MYCOL, TESTNUM,
+ $ MAXERR, NERR,
+ $ MEM(ERRIPTR), MEM(ERRDPTR))
+ END IF
+ 30 CONTINUE
+ CALL BLACS_SET(CONTEXT, 16, 0)
+ 35 CONTINUE
+ CALL BLACS_SET(CONTEXT, 15, 0)
+ 40 CONTINUE
+ TESTOK = ( K .EQ. NERR )
+ END IF
+ END IF
+*
+ IF( VERB .GT. 1 ) THEN
+ I = NERR
+ CALL DBTCHECKIN(0, OUTNUM, MAXERR, NERR,
+ $ MEM(ERRIPTR), MEM(ERRDPTR), ISEED)
+ IF( IAM .EQ. 0 ) THEN
+ IF( TESTOK .AND. NERR.EQ.I ) THEN
+ WRITE(OUTNUM,6000)TESTNUM,'PASSED ',
+ $ SCOPE, TOP, M, N, LDASRC,
+ $ LDADST, LDI, RDEST2, CDEST2,
+ $ NPROW, NPCOL
+ ELSE
+ NFAIL = NFAIL + 1
+ WRITE(OUTNUM,6000)TESTNUM,'FAILED ',
+ $ SCOPE, TOP, M, N, LDASRC,
+ $ LDADST, LDI, RDEST2, CDEST2,
+ $ NPROW, NPCOL
+ END IF
+ END IF
+*
+* Once we've printed out errors, can re-use buf space
+*
+ NERR = 0
+ END IF
+ 50 CONTINUE
+ 60 CONTINUE
+ 70 CONTINUE
+ 80 CONTINUE
+ 90 CONTINUE
+*
+ IF( VERB .LT. 2 ) THEN
+ NFAIL = TESTNUM
+ CALL DBTCHECKIN( NFAIL, OUTNUM, MAXERR, NERR, MEM(ERRIPTR),
+ $ MEM(ERRDPTR), ISEED )
+ END IF
+ IF( IAM .EQ. 0 ) THEN
+ IF( VERB .GT. 1 ) WRITE(OUTNUM,*) ' '
+ IF( NFAIL+NSKIP .EQ. 0 ) THEN
+ WRITE(OUTNUM, 7000 ) TESTNUM
+ ELSE
+ WRITE(OUTNUM, 8000 ) TESTNUM, TESTNUM-NSKIP-NFAIL,
+ $ NSKIP, NFAIL
+ END IF
+ END IF
+*
+* Log whether their were any failures
+*
+ TESTOK = ALLPASS( (NFAIL.EQ.0) )
+*
+ 1000 FORMAT('DOUBLE PRECISION AMN TESTS: BEGIN.' )
+ 2000 FORMAT(1X,A7,3X,10I6)
+ 3000 FORMAT(1X,A7,3X,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1,
+ $ 5X,A1,5X,A1)
+ 4000 FORMAT(' TEST# STATUS SCOPE TOP M N LDAS LDAD LDI ',
+ $ 'RDEST CDEST P Q')
+ 5000 FORMAT(' ----- ------- ----- --- ----- ----- ----- ----- ----- ',
+ $ '----- ----- ---- ----')
+ 6000 FORMAT(I6,1X,A7,5X,A1,3X,A1,7I6,2I5)
+ 7000 FORMAT('DOUBLE PRECISION AMN TESTS: PASSED ALL',
+ $ I5, ' TESTS.')
+ 8000 FORMAT('DOUBLE PRECISION AMN TESTS:',I5,' TESTS;',I5,' PASSED,',
+ $ I5,' SKIPPED,',I5,' FAILED.')
+*
+ RETURN
+*
+* End of DTESTAMN.
+*
+ END
+*
+ SUBROUTINE DCHKAMN( SCOPE, ICTXT, M, N, A, LDA, RA, CA, LDI,
+ $ TESTNUM, MAXERR, NERR, ERRIBUF, ERRDBUF,
+ $ ISEED, VALS )
+*
+* .. Scalar Arguments ..
+ CHARACTER*1 SCOPE
+ INTEGER ICTXT, M, N, LDA, LDI, TESTNUM, MAXERR, NERR
+* ..
+* .. Array Arguments ..
+ INTEGER RA(*), CA(*), ERRIBUF(6, MAXERR), ISEED(*)
+ DOUBLE PRECISION A(LDA,*), ERRDBUF(2, MAXERR), VALS(*)
+* ..
+* .. External Functions ..
+ INTEGER IBTMYPROC, IBTNPROCS, IBTSPNUM
+ DOUBLE PRECISION DBTEPS, DBTABS
+ DOUBLE PRECISION DBTRAN
+ EXTERNAL IBTMYPROC, IBTNPROCS, IBTSPNUM, DBTRAN, DBTEPS, DBTABS
+* ..
+* .. External Subroutines ..
+ EXTERNAL IBTSPCOORD
+* ..
+* .. Local Scalars ..
+ LOGICAL ERROR
+ INTEGER NPROCS, NNODES, NPROW, NPCOL, MYROW, MYCOL, RAMN, CAMN
+ INTEGER IAMN, I, J, K, H, DEST, NODE
+ DOUBLE PRECISION EPS
+* ..
+* .. Executable Statements ..
+*
+ NPROCS = IBTNPROCS()
+ EPS = DBTEPS()
+ CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL )
+ DEST = MYROW*NPROCS + MYCOL
+*
+* Set up seeds to match those used by each proc's genmat call
+*
+ IF( SCOPE .EQ. 'R' ) THEN
+ NNODES = NPCOL
+ DO 10 I = 0, NNODES-1
+ NODE = MYROW * NPROCS + I
+ ISEED(I*4+1) = MOD( 1002 + TESTNUM*5 + NODE*3, 4096 )
+ ISEED(I*4+2) = MOD( 2027 + TESTNUM*7 + NODE, 4096 )
+ ISEED(I*4+3) = MOD( 1234 + TESTNUM + NODE*3, 4096 )
+ ISEED(I*4+4) = MOD( 4311 + TESTNUM*10 + NODE*2, 4096 )
+ 10 CONTINUE
+ ELSE IF( SCOPE .EQ. 'C' ) THEN
+ NNODES = NPROW
+ DO 20 I = 0, NNODES-1
+ NODE = I * NPROCS + MYCOL
+ ISEED(I*4+1) = MOD( 1002 + TESTNUM*5 + NODE*3, 4096 )
+ ISEED(I*4+2) = MOD( 2027 + TESTNUM*7 + NODE, 4096 )
+ ISEED(I*4+3) = MOD( 1234 + TESTNUM + NODE*3, 4096 )
+ ISEED(I*4+4) = MOD( 4311 + TESTNUM*10 + NODE*2, 4096 )
+ 20 CONTINUE
+ ELSE
+ NNODES = NPROW * NPCOL
+ DO 30 I = 0, NNODES-1
+ NODE = (I / NPCOL) * NPROCS + MOD(I, NPCOL)
+ ISEED(I*4+1) = MOD( 1002 + TESTNUM*5 + NODE*3, 4096 )
+ ISEED(I*4+2) = MOD( 2027 + TESTNUM*7 + NODE, 4096 )
+ ISEED(I*4+3) = MOD( 1234 + TESTNUM + NODE*3, 4096 )
+ ISEED(I*4+4) = MOD( 4311 + TESTNUM*10 + NODE*2, 4096 )
+ 30 CONTINUE
+ END IF
+*
+ DO 100 J = 1, N
+ DO 90 I = 1, M
+ H = (J-1)*LDI + I
+ VALS(1) = DBTRAN( ISEED )
+ IAMN = 1
+ IF( NNODES .GT. 1 ) THEN
+ DO 40 K = 1, NNODES-1
+ VALS(K+1) = DBTRAN( ISEED(K*4+1) )
+ IF( DBTABS( VALS(K+1) ) .LT. DBTABS( VALS(IAMN) ) )
+ $ IAMN = K + 1
+ 40 CONTINUE
+ END IF
+*
+* If BLACS have not returned same value we've chosen
+*
+ IF( A(I,J) .NE. VALS(IAMN) ) THEN
+*
+* If we have RA and CA arrays
+*
+ IF( LDI .NE. -1 ) THEN
+*
+* Any number having the same absolute value is a valid max
+*
+ K = IBTSPNUM( SCOPE, RA(H), CA(H), NPCOL ) + 1
+ IF( K.GT.0 .AND. K.LE.NNODES ) THEN
+ ERROR = DBTABS( VALS(K) ).NE.DBTABS( VALS(IAMN) )
+ IF( .NOT.ERROR ) IAMN = K
+ ELSE
+ ERROR = .TRUE.
+ END IF
+ ELSE
+*
+* Error if BLACS answer not same absolute value, or if it
+* was not really in the numbers being compared
+*
+ ERROR = ( DBTABS( A(I,J) ) .NE. DBTABS( VALS(IAMN) ) )
+ IF( .NOT.ERROR ) THEN
+ DO 50 K = 1, NNODES
+ IF( VALS(K) .EQ. A(I,J) ) GOTO 60
+ 50 CONTINUE
+ ERROR = .TRUE.
+ 60 CONTINUE
+ ENDIF
+ END IF
+*
+* If the value is in error
+*
+ IF( ERROR ) THEN
+ NERR = NERR + 1
+ ERRIBUF(1, NERR) = TESTNUM
+ ERRIBUF(2, NERR) = NNODES
+ ERRIBUF(3, NERR) = DEST
+ ERRIBUF(4, NERR) = I
+ ERRIBUF(5, NERR) = J
+ ERRIBUF(6, NERR) = 5
+ ERRDBUF(1, NERR) = A(I,J)
+ ERRDBUF(2, NERR) = VALS(IAMN)
+ END IF
+ END IF
+*
+* If they are defined, make sure coordinate entries are OK
+*
+ IF( LDI .NE. -1 ) THEN
+ K = IBTSPNUM( SCOPE, RA(H), CA(H), NPCOL ) + 1
+ IF( K.NE.IAMN ) THEN
+*
+* Make sure more than one proc doesn't have exact same value
+* (and therefore there may be more than one valid coordinate
+* for a single value)
+*
+ IF( K.GT.NNODES .OR. K.LT.1 ) THEN
+ ERROR = .TRUE.
+ ELSE
+ ERROR = ( VALS(K) .NE. VALS(IAMN) )
+ END IF
+ IF( ERROR ) THEN
+ CALL IBTSPCOORD( SCOPE, IAMN-1, MYROW, MYCOL,
+ $ NPCOL, RAMN, CAMN )
+ IF( RAMN .NE. RA(H) ) THEN
+ NERR = NERR + 1
+ ERRIBUF(1, NERR) = TESTNUM
+ ERRIBUF(2, NERR) = NNODES
+ ERRIBUF(3, NERR) = DEST
+ ERRIBUF(4, NERR) = I
+ ERRIBUF(5, NERR) = J
+ ERRIBUF(6, NERR) = -5
+ ERRDBUF(1, NERR) = RA(H)
+ ERRDBUF(2, NERR) = RAMN
+ END IF
+ IF( CAMN .NE. CA(H) ) THEN
+ NERR = NERR + 1
+ ERRIBUF(1, NERR) = TESTNUM
+ ERRIBUF(2, NERR) = NNODES
+ ERRIBUF(3, NERR) = DEST
+ ERRIBUF(4, NERR) = I
+ ERRIBUF(5, NERR) = J
+ ERRIBUF(6, NERR) = -15
+ ERRDBUF(1, NERR) = CA(H)
+ ERRDBUF(2, NERR) = CAMN
+ END IF
+ END IF
+ END IF
+ END IF
+ 90 CONTINUE
+ 100 CONTINUE
+*
+ RETURN
+*
+* End of DCHKAMN
+*
+ END
+*
+*
+ SUBROUTINE CAMNTEST( OUTNUM, VERB, TOPSREPEAT, TOPSCOHRNT, NSCOPE,
+ $ SCOPE0, NTOP, TOP0, NMAT, M0, N0, LDAS0,
+ $ LDAD0, LDI0, NDEST, RDEST0, CDEST0, NGRID,
+ $ CONTEXT0, P0, Q0, ISEED, RMEM, CMEM, RCLEN,
+ $ MEM, MEMLEN )
+*
+* -- BLACS tester (version 1.0) --
+* University of Tennessee
+* December 15, 1994
+*
+*
+* .. Scalar Arguments ..
+ INTEGER MEMLEN, NDEST, NGRID, NMAT, NSCOPE, NTOP, OUTNUM, RCLEN,
+ $ TOPSCOHRNT, TOPSREPEAT, VERB
+* ..
+* .. Array Arguments ..
+ CHARACTER*1 SCOPE0(NSCOPE), TOP0(NTOP)
+ INTEGER M0(NMAT), N0(NMAT), LDAS0(NMAT), LDAD0(NMAT), LDI0(NMAT)
+ INTEGER RDEST0(NDEST), CDEST0(NDEST), CONTEXT0(NGRID)
+ INTEGER P0(NGRID), Q0(NGRID), ISEED(*), RMEM(RCLEN), CMEM(RCLEN)
+ COMPLEX MEM(MEMLEN)
+* ..
+*
+* Purpose
+* =======
+* CTESTAMN: Test complex AMN COMBINE
+*
+* Arguments
+* =========
+* OUTNUM (input) INTEGER
+* The device number to write output to.
+*
+* VERB (input) INTEGER
+* The level of verbosity (how much printing to do).
+*
+* NSCOPE (input) INTEGER
+* The number of scopes to be tested.
+*
+* SCOPE0 (input) CHARACTER*1 array of dimension (NSCOPE)
+* Values of the scopes to be tested.
+*
+* NTOP (input) INTEGER
+* The number of topologies to be tested.
+*
+* TOP0 (input) CHARACTER*1 array of dimension (NTOP)
+* Values of the topologies to be tested.
+*
+* NMAT (input) INTEGER
+* The number of matrices to be tested.
+*
+* M0 (input) INTEGER array of dimension (NMAT)
+* Values of M to be tested.
+*
+* M0 (input) INTEGER array of dimension (NMAT)
+* Values of M to be tested.
+*
+* N0 (input) INTEGER array of dimension (NMAT)
+* Values of N to be tested.
+*
+* LDAS0 (input) INTEGER array of dimension (NMAT)
+* Values of LDAS (leading dimension of A on source process)
+* to be tested.
+*
+* LDAD0 (input) INTEGER array of dimension (NMAT)
+* Values of LDAD (leading dimension of A on destination
+* process) to be tested.
+* LDI0 (input) INTEGER array of dimension (NMAT)
+* Values of LDI (leading dimension of RA/CA) to be tested.
+* If LDI == -1, these RA/CA should not be accessed.
+*
+* NDEST (input) INTEGER
+* The number of destinations to be tested.
+*
+* RDEST0 (input) INTEGER array of dimension (NNDEST)
+* Values of RDEST (row coordinate of destination) to be
+* tested.
+*
+* CDEST0 (input) INTEGER array of dimension (NNDEST)
+* Values of CDEST (column coordinate of destination) to be
+* tested.
+*
+* NGRID (input) INTEGER
+* The number of process grids to be tested.
+*
+* CONTEXT0 (input) INTEGER array of dimension (NGRID)
+* The BLACS context handles corresponding to the grids.
+*
+* P0 (input) INTEGER array of dimension (NGRID)
+* Values of P (number of process rows, NPROW).
+*
+* Q0 (input) INTEGER array of dimension (NGRID)
+* Values of Q (number of process columns, NPCOL).
+*
+* ISEED (workspace) INTEGER array of dimension ( MAX(NPROCS, NTESTS) )
+* Workspace used to hold each process's random number SEED.
+* This requires NPROCS (number of processor) elements.
+* If VERB < 2, this workspace also serves to indicate which
+* tests fail. This requires workspace of NTESTS
+* (number of tests performed).
+*
+* RMEM (workspace) INTEGER array of dimension (RCLEN)
+* Used for all RA arrays, and their pre and post padding.
+*
+* CMEM (workspace) INTEGER array of dimension (RCLEN)
+* Used for all CA arrays, and their pre and post padding.
+*
+* RCLEN (input) INTEGER
+* The length, in elements, of RMEM and CMEM.
+*
+* MEM (workspace) COMPLEX array of dimension (MEMLEN)
+* Used for all other workspaces, including the matrix A,
+* and its pre and post padding.
+*
+* MEMLEN (input) INTEGER
+* The length, in elements, of MEM.
+*
+* =====================================================================
+*
+* .. External Functions ..
+ LOGICAL ALLPASS, LSAME
+ INTEGER IBTMYPROC, IBTNPROCS, IBTSIZEOF
+ EXTERNAL ALLPASS, LSAME, IBTMYPROC, IBTNPROCS, IBTSIZEOF
+* ..
+* .. External Subroutines ..
+ EXTERNAL BLACS_GRIDINFO, CGAMN2D
+ EXTERNAL CINITMAT, CCHKPAD, CBTCHECKIN
+* ..
+* .. Local Scalars ..
+ CHARACTER*1 SCOPE, TOP
+ LOGICAL INGRID, TESTOK, ALLRCV
+ INTEGER APTR, CAPTR, CDEST, CDEST2, CONTEXT, CSIZE, ERRDPTR,
+ $ ERRIPTR, I, IAM, ICHECKVAL, IDE, IGR, IMA, IPAD, IPOST,
+ $ IPRE, ISC, ISIZE, ISTART, ISTOP, ITC, ITC1, ITC2, ITO,
+ $ ITR, ITR1, ITR2, J, K, LDA, LDADST, LDASRC, LDI, M,
+ $ MAXERR, MYCOL, MYROW, N, NERR, NFAIL, NPCOL, NPROW, NSKIP,
+ $ PREAPTR, RAPTR, RDEST, RDEST2, SETWHAT, TESTNUM, VALPTR
+ COMPLEX CHECKVAL
+* ..
+* .. Executable Statements ..
+*
+* Choose padding value, and make it unique
+*
+ CHECKVAL = CMPLX( -0.91E0, -0.71E0 )
+ IAM = IBTMYPROC()
+ CHECKVAL = IAM * CHECKVAL
+ ISIZE = IBTSIZEOF('I')
+ CSIZE = IBTSIZEOF('C')
+ ICHECKVAL = -IAM
+*
+* Verify file parameters
+*
+ IF( IAM .EQ. 0 ) THEN
+ WRITE(OUTNUM, *) ' '
+ WRITE(OUTNUM, *) ' '
+ WRITE(OUTNUM, 1000 )
+ IF( VERB .GT. 0 ) THEN
+ WRITE(OUTNUM,*) ' '
+ WRITE(OUTNUM, 2000) 'NSCOPE:', NSCOPE
+ WRITE(OUTNUM, 3000) ' SCOPE:', ( SCOPE0(I), I = 1, NSCOPE )
+ WRITE(OUTNUM, 2000) 'TReps :', TOPSREPEAT
+ WRITE(OUTNUM, 2000) 'TCohr :', TOPSCOHRNT
+ WRITE(OUTNUM, 2000) 'NTOP :', NTOP
+ WRITE(OUTNUM, 3000) ' TOP :', ( TOP0(I), I = 1, NTOP )
+ WRITE(OUTNUM, 2000) 'NMAT :', NMAT
+ WRITE(OUTNUM, 2000) ' M :', ( M0(I), I = 1, NMAT )
+ WRITE(OUTNUM, 2000) ' N :', ( N0(I), I = 1, NMAT )
+ WRITE(OUTNUM, 2000) ' LDAS :', ( LDAS0(I), I = 1, NMAT )
+ WRITE(OUTNUM, 2000) ' LDAD :', ( LDAD0(I), I = 1, NMAT )
+ WRITE(OUTNUM, 2000) ' LDI :', ( LDI0(I), I = 1, NMAT )
+ WRITE(OUTNUM, 2000) 'NDEST :', NDEST
+ WRITE(OUTNUM, 2000) ' RDEST:',( RDEST0(I), I = 1, NDEST )
+ WRITE(OUTNUM, 2000) ' CDEST:',( CDEST0(I), I = 1, NDEST )
+ WRITE(OUTNUM, 2000) 'NGRIDS:', NGRID
+ WRITE(OUTNUM, 2000) ' P :', ( P0(I), I = 1, NGRID )
+ WRITE(OUTNUM, 2000) ' Q :', ( Q0(I), I = 1, NGRID )
+ WRITE(OUTNUM, 2000) 'VERB :', VERB
+ WRITE(OUTNUM,*) ' '
+ END IF
+ IF( VERB .GT. 1 ) THEN
+ WRITE(OUTNUM,4000)
+ WRITE(OUTNUM,5000)
+ END IF
+ END IF
+ IF (TOPSREPEAT.EQ.0) THEN
+ ITR1 = 0
+ ITR2 = 0
+ ELSE IF (TOPSREPEAT.EQ.1) THEN
+ ITR1 = 1
+ ITR2 = 1
+ ELSE
+ ITR1 = 0
+ ITR2 = 1
+ END IF
+*
+* Find biggest matrix, so we know where to stick error info
+*
+ I = 0
+ DO 10 IMA = 1, NMAT
+ IPAD = 4 * M0(IMA)
+ K = N0(IMA) * MAX0( LDAS0(IMA), LDAD0(IMA) ) + IPAD
+ IF( K .GT. I ) I = K
+ 10 CONTINUE
+ I = I + IBTNPROCS()
+ MAXERR = ( CSIZE * (MEMLEN-I) ) / ( CSIZE*2 + ISIZE*6 )
+ IF( MAXERR .LT. 1 ) THEN
+ WRITE(OUTNUM,*) 'ERROR: Not enough memory to run MIN tests.'
+ CALL BLACS_ABORT(-1, 1)
+ END IF
+ ERRDPTR = I + 1
+ ERRIPTR = ERRDPTR + MAXERR
+ NERR = 0
+ TESTNUM = 0
+ NFAIL = 0
+ NSKIP = 0
+*
+* Loop over grids of matrix
+*
+ DO 90 IGR = 1, NGRID
+*
+* allocate process grid for the next batch of tests
+*
+ CONTEXT = CONTEXT0(IGR)
+ CALL BLACS_GRIDINFO( CONTEXT, NPROW, NPCOL, MYROW, MYCOL )
+ INGRID = ( (MYROW.LT.NPROW) .AND. (MYCOL.LT.NPCOL) )
+*
+ DO 80 ISC = 1, NSCOPE
+ SCOPE = SCOPE0(ISC)
+ DO 70 ITO = 1, NTOP
+ TOP = TOP0(ITO)
+*
+* If testing multiring ('M') or general tree ('T'), need to
+* loop over calls to BLACS_SET to do full test
+*
+ IF( LSAME(TOP, 'M') ) THEN
+ SETWHAT = 13
+ IF( SCOPE .EQ. 'R' ) THEN
+ ISTART = -(NPCOL - 1)
+ ISTOP = -ISTART
+ ELSE IF (SCOPE .EQ. 'C') THEN
+ ISTART = -(NPROW - 1)
+ ISTOP = -ISTART
+ ELSE
+ ISTART = -(NPROW*NPCOL - 1)
+ ISTOP = -ISTART
+ ENDIF
+ ELSE IF( LSAME(TOP, 'T') ) THEN
+ SETWHAT = 14
+ ISTART = 1
+ IF( SCOPE .EQ. 'R' ) THEN
+ ISTOP = NPCOL - 1
+ ELSE IF (SCOPE .EQ. 'C') THEN
+ ISTOP = NPROW - 1
+ ELSE
+ ISTOP = NPROW*NPCOL - 1
+ ENDIF
+ ELSE
+ SETWHAT = 0
+ ISTART = 1
+ ISTOP = 1
+ ENDIF
+ DO 60 IMA = 1, NMAT
+ M = M0(IMA)
+ N = N0(IMA)
+ LDASRC = LDAS0(IMA)
+ LDADST = LDAD0(IMA)
+ LDI = LDI0(IMA)
+ IPRE = 2 * M
+ IPOST = IPRE
+ PREAPTR = 1
+ APTR = PREAPTR + IPRE
+*
+ DO 50 IDE = 1, NDEST
+ TESTNUM = TESTNUM + 1
+ RDEST2 = RDEST0(IDE)
+ CDEST2 = CDEST0(IDE)
+*
+* If everyone gets the answer, create some bogus rdest/cdest
+* so IF's are easier
+*
+ ALLRCV = ( (RDEST2.EQ.-1) .OR. (CDEST2.EQ.-1) )
+ IF( ALLRCV ) THEN
+ RDEST = NPROW - 1
+ CDEST = NPCOL - 1
+ IF (TOPSCOHRNT.EQ.0) THEN
+ ITR1 = 0
+ ITR2 = 0
+ ELSE IF (TOPSCOHRNT.EQ.1) THEN
+ ITR1 = 1
+ ITR2 = 1
+ ELSE
+ ITR1 = 0
+ ITR2 = 1
+ END IF
+ ELSE
+ RDEST = RDEST2
+ CDEST = CDEST2
+ ITC1 = 0
+ ITC2 = 0
+ END IF
+ IF( RDEST.GE.P0(IGR) .OR. CDEST.GE.Q0(IGR) ) THEN
+ NSKIP = NSKIP + 1
+ GOTO 50
+ END IF
+*
+ IF( MYROW.EQ.RDEST .AND. MYCOL.EQ.CDEST ) THEN
+ LDA = LDADST
+ ELSE
+ LDA = LDASRC
+ END IF
+ VALPTR = APTR + IPOST + N * LDA
+ IF( VERB .GT. 1 ) THEN
+ IF( IAM .EQ. 0 ) THEN
+ WRITE(OUTNUM, 6000)
+ $ TESTNUM, 'RUNNING', SCOPE, TOP, M, N,
+ $ LDASRC, LDADST, LDI, RDEST2, CDEST2,
+ $ NPROW, NPCOL
+ END IF
+ END IF
+*
+* If I am in scope
+*
+ TESTOK = .TRUE.
+ IF( INGRID ) THEN
+ IF( (MYROW.EQ.RDEST .AND. SCOPE.EQ.'R') .OR.
+ $ (MYCOL.EQ.CDEST .AND. SCOPE.EQ.'C') .OR.
+ $ (SCOPE .EQ. 'A') ) THEN
+*
+ K = NERR
+ DO 40 ITR = ITR1, ITR2
+ CALL BLACS_SET(CONTEXT, 15, ITR)
+ DO 35 ITC = ITC1, ITC2
+ CALL BLACS_SET(CONTEXT, 16, ITC)
+ DO 30 J = ISTART, ISTOP
+ IF( J.EQ.0) GOTO 30
+ IF( SETWHAT.NE.0 )
+ $ CALL BLACS_SET(CONTEXT, SETWHAT, J)
+*
+*
+* generate and pad matrix A
+*
+ CALL CINITMAT('G','-', M, N, MEM(PREAPTR),
+ $ LDA, IPRE, IPOST,
+ $ CHECKVAL, TESTNUM,
+ $ MYROW, MYCOL )
+*
+* If they exist, pad RA and CA arrays
+*
+ IF( LDI .NE. -1 ) THEN
+ DO 15 I = 1, N*LDI + IPRE + IPOST
+ RMEM(I) = ICHECKVAL
+ CMEM(I) = ICHECKVAL
+ 15 CONTINUE
+ RAPTR = 1 + IPRE
+ CAPTR = 1 + IPRE
+ ELSE
+ DO 20 I = 1, IPRE+IPOST
+ RMEM(I) = ICHECKVAL
+ CMEM(I) = ICHECKVAL
+ 20 CONTINUE
+ RAPTR = 1
+ CAPTR = 1
+ END IF
+*
+ CALL CGAMN2D(CONTEXT, SCOPE, TOP, M, N,
+ $ MEM(APTR), LDA, RMEM(RAPTR),
+ $ CMEM(CAPTR), LDI,
+ $ RDEST2, CDEST2)
+*
+* If I've got the answer, check for errors in
+* matrix or padding
+*
+ IF( (MYROW.EQ.RDEST .AND. MYCOL.EQ.CDEST)
+ $ .OR. ALLRCV ) THEN
+ CALL CCHKPAD('G','-', M, N,
+ $ MEM(PREAPTR), LDA, RDEST,
+ $ CDEST, MYROW, MYCOL,
+ $ IPRE, IPOST, CHECKVAL,
+ $ TESTNUM, MAXERR, NERR,
+ $ MEM(ERRIPTR),MEM(ERRDPTR))
+ CALL CCHKAMN(SCOPE, CONTEXT, M, N,
+ $ MEM(APTR), LDA,
+ $ RMEM(RAPTR), CMEM(CAPTR),
+ $ LDI, TESTNUM, MAXERR,NERR,
+ $ MEM(ERRIPTR),MEM(ERRDPTR),
+ $ ISEED, MEM(VALPTR))
+ CALL CRCCHK(IPRE, IPOST, ICHECKVAL,
+ $ M, N, RMEM, CMEM, LDI,
+ $ MYROW, MYCOL, TESTNUM,
+ $ MAXERR, NERR,
+ $ MEM(ERRIPTR), MEM(ERRDPTR))
+ END IF
+ 30 CONTINUE
+ CALL BLACS_SET(CONTEXT, 16, 0)
+ 35 CONTINUE
+ CALL BLACS_SET(CONTEXT, 15, 0)
+ 40 CONTINUE
+ TESTOK = ( K .EQ. NERR )
+ END IF
+ END IF
+*
+ IF( VERB .GT. 1 ) THEN
+ I = NERR
+ CALL CBTCHECKIN(0, OUTNUM, MAXERR, NERR,
+ $ MEM(ERRIPTR), MEM(ERRDPTR), ISEED)
+ IF( IAM .EQ. 0 ) THEN
+ IF( TESTOK .AND. NERR.EQ.I ) THEN
+ WRITE(OUTNUM,6000)TESTNUM,'PASSED ',
+ $ SCOPE, TOP, M, N, LDASRC,
+ $ LDADST, LDI, RDEST2, CDEST2,
+ $ NPROW, NPCOL
+ ELSE
+ NFAIL = NFAIL + 1
+ WRITE(OUTNUM,6000)TESTNUM,'FAILED ',
+ $ SCOPE, TOP, M, N, LDASRC,
+ $ LDADST, LDI, RDEST2, CDEST2,
+ $ NPROW, NPCOL
+ END IF
+ END IF
+*
+* Once we've printed out errors, can re-use buf space
+*
+ NERR = 0
+ END IF
+ 50 CONTINUE
+ 60 CONTINUE
+ 70 CONTINUE
+ 80 CONTINUE
+ 90 CONTINUE
+*
+ IF( VERB .LT. 2 ) THEN
+ NFAIL = TESTNUM
+ CALL CBTCHECKIN( NFAIL, OUTNUM, MAXERR, NERR, MEM(ERRIPTR),
+ $ MEM(ERRDPTR), ISEED )
+ END IF
+ IF( IAM .EQ. 0 ) THEN
+ IF( VERB .GT. 1 ) WRITE(OUTNUM,*) ' '
+ IF( NFAIL+NSKIP .EQ. 0 ) THEN
+ WRITE(OUTNUM, 7000 ) TESTNUM
+ ELSE
+ WRITE(OUTNUM, 8000 ) TESTNUM, TESTNUM-NSKIP-NFAIL,
+ $ NSKIP, NFAIL
+ END IF
+ END IF
+*
+* Log whether their were any failures
+*
+ TESTOK = ALLPASS( (NFAIL.EQ.0) )
+*
+ 1000 FORMAT('COMPLEX AMN TESTS: BEGIN.' )
+ 2000 FORMAT(1X,A7,3X,10I6)
+ 3000 FORMAT(1X,A7,3X,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1,
+ $ 5X,A1,5X,A1)
+ 4000 FORMAT(' TEST# STATUS SCOPE TOP M N LDAS LDAD LDI ',
+ $ 'RDEST CDEST P Q')
+ 5000 FORMAT(' ----- ------- ----- --- ----- ----- ----- ----- ----- ',
+ $ '----- ----- ---- ----')
+ 6000 FORMAT(I6,1X,A7,5X,A1,3X,A1,7I6,2I5)
+ 7000 FORMAT('COMPLEX AMN TESTS: PASSED ALL',
+ $ I5, ' TESTS.')
+ 8000 FORMAT('COMPLEX AMN TESTS:',I5,' TESTS;',I5,' PASSED,',
+ $ I5,' SKIPPED,',I5,' FAILED.')
+*
+ RETURN
+*
+* End of CTESTAMN.
+*
+ END
+*
+ SUBROUTINE CCHKAMN( SCOPE, ICTXT, M, N, A, LDA, RA, CA, LDI,
+ $ TESTNUM, MAXERR, NERR, ERRIBUF, ERRDBUF,
+ $ ISEED, VALS )
+*
+* .. Scalar Arguments ..
+ CHARACTER*1 SCOPE
+ INTEGER ICTXT, M, N, LDA, LDI, TESTNUM, MAXERR, NERR
+* ..
+* .. Array Arguments ..
+ INTEGER RA(*), CA(*), ERRIBUF(6, MAXERR), ISEED(*)
+ COMPLEX A(LDA,*), ERRDBUF(2, MAXERR), VALS(*)
+* ..
+* .. External Functions ..
+ INTEGER IBTMYPROC, IBTNPROCS, IBTSPNUM
+ REAL SBTEPS, CBTABS
+ COMPLEX CBTRAN
+ EXTERNAL IBTMYPROC, IBTNPROCS, IBTSPNUM, CBTRAN, SBTEPS, CBTABS
+* ..
+* .. External Subroutines ..
+ EXTERNAL IBTSPCOORD
+* ..
+* .. Local Scalars ..
+ LOGICAL ERROR
+ INTEGER NPROCS, NNODES, NPROW, NPCOL, MYROW, MYCOL, RAMN, CAMN
+ INTEGER IAMN, I, J, K, H, DEST, NODE
+ REAL EPS
+* ..
+* .. Executable Statements ..
+*
+ NPROCS = IBTNPROCS()
+ EPS = SBTEPS()
+ CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL )
+ DEST = MYROW*NPROCS + MYCOL
+*
+* Set up seeds to match those used by each proc's genmat call
+*
+ IF( SCOPE .EQ. 'R' ) THEN
+ NNODES = NPCOL
+ DO 10 I = 0, NNODES-1
+ NODE = MYROW * NPROCS + I
+ ISEED(I*4+1) = MOD( 1002 + TESTNUM*5 + NODE*3, 4096 )
+ ISEED(I*4+2) = MOD( 2027 + TESTNUM*7 + NODE, 4096 )
+ ISEED(I*4+3) = MOD( 1234 + TESTNUM + NODE*3, 4096 )
+ ISEED(I*4+4) = MOD( 4311 + TESTNUM*10 + NODE*2, 4096 )
+ 10 CONTINUE
+ ELSE IF( SCOPE .EQ. 'C' ) THEN
+ NNODES = NPROW
+ DO 20 I = 0, NNODES-1
+ NODE = I * NPROCS + MYCOL
+ ISEED(I*4+1) = MOD( 1002 + TESTNUM*5 + NODE*3, 4096 )
+ ISEED(I*4+2) = MOD( 2027 + TESTNUM*7 + NODE, 4096 )
+ ISEED(I*4+3) = MOD( 1234 + TESTNUM + NODE*3, 4096 )
+ ISEED(I*4+4) = MOD( 4311 + TESTNUM*10 + NODE*2, 4096 )
+ 20 CONTINUE
+ ELSE
+ NNODES = NPROW * NPCOL
+ DO 30 I = 0, NNODES-1
+ NODE = (I / NPCOL) * NPROCS + MOD(I, NPCOL)
+ ISEED(I*4+1) = MOD( 1002 + TESTNUM*5 + NODE*3, 4096 )
+ ISEED(I*4+2) = MOD( 2027 + TESTNUM*7 + NODE, 4096 )
+ ISEED(I*4+3) = MOD( 1234 + TESTNUM + NODE*3, 4096 )
+ ISEED(I*4+4) = MOD( 4311 + TESTNUM*10 + NODE*2, 4096 )
+ 30 CONTINUE
+ END IF
+*
+ DO 100 J = 1, N
+ DO 90 I = 1, M
+ H = (J-1)*LDI + I
+ VALS(1) = CBTRAN( ISEED )
+ IAMN = 1
+ IF( NNODES .GT. 1 ) THEN
+ DO 40 K = 1, NNODES-1
+ VALS(K+1) = CBTRAN( ISEED(K*4+1) )
+ IF( CBTABS( VALS(K+1) ) .LT. CBTABS( VALS(IAMN) ) )
+ $ IAMN = K + 1
+ 40 CONTINUE
+ END IF
+*
+* If BLACS have not returned same value we've chosen
+*
+ IF( A(I,J) .NE. VALS(IAMN) ) THEN
+*
+* If we have RA and CA arrays
+*
+ IF( LDI .NE. -1 ) THEN
+*
+* Any number having the same absolute value is a valid max
+*
+ K = IBTSPNUM( SCOPE, RA(H), CA(H), NPCOL ) + 1
+ IF( K.GT.0 .AND. K.LE.NNODES ) THEN
+ ERROR = ABS( CBTABS(VALS(K)) - CBTABS(VALS(IAMN)) )
+ $ .GT. 3*EPS
+ IF( .NOT.ERROR ) IAMN = K
+ ELSE
+ ERROR = .TRUE.
+ END IF
+ ELSE
+*
+* Error if BLACS answer not same absolute value, or if it
+* was not really in the numbers being compared
+*
+ ERROR = ABS( CBTABS(A(I,J)) - CBTABS(VALS(IAMN)) )
+ $ .GT. 3*EPS
+ IF( .NOT.ERROR ) THEN
+ DO 50 K = 1, NNODES
+ IF( VALS(K) .EQ. A(I,J) ) GOTO 60
+ 50 CONTINUE
+ ERROR = .TRUE.
+ 60 CONTINUE
+ ENDIF
+ END IF
+*
+* If the value is in error
+*
+ IF( ERROR ) THEN
+ NERR = NERR + 1
+ ERRIBUF(1, NERR) = TESTNUM
+ ERRIBUF(2, NERR) = NNODES
+ ERRIBUF(3, NERR) = DEST
+ ERRIBUF(4, NERR) = I
+ ERRIBUF(5, NERR) = J
+ ERRIBUF(6, NERR) = 5
+ ERRDBUF(1, NERR) = A(I,J)
+ ERRDBUF(2, NERR) = VALS(IAMN)
+ END IF
+ END IF
+*
+* If they are defined, make sure coordinate entries are OK
+*
+ IF( LDI .NE. -1 ) THEN
+ K = IBTSPNUM( SCOPE, RA(H), CA(H), NPCOL ) + 1
+ IF( K.NE.IAMN ) THEN
+*
+* Make sure more than one proc doesn't have exact same value
+* (and therefore there may be more than one valid coordinate
+* for a single value)
+*
+ IF( K.GT.NNODES .OR. K.LT.1 ) THEN
+ ERROR = .TRUE.
+ ELSE
+ ERROR = ( VALS(K) .NE. VALS(IAMN) )
+ END IF
+ IF( ERROR ) THEN
+ CALL IBTSPCOORD( SCOPE, IAMN-1, MYROW, MYCOL,
+ $ NPCOL, RAMN, CAMN )
+ IF( RAMN .NE. RA(H) ) THEN
+ NERR = NERR + 1
+ ERRIBUF(1, NERR) = TESTNUM
+ ERRIBUF(2, NERR) = NNODES
+ ERRIBUF(3, NERR) = DEST
+ ERRIBUF(4, NERR) = I
+ ERRIBUF(5, NERR) = J
+ ERRIBUF(6, NERR) = -5
+ ERRDBUF(1, NERR) = RA(H)
+ ERRDBUF(2, NERR) = RAMN
+ END IF
+ IF( CAMN .NE. CA(H) ) THEN
+ NERR = NERR + 1
+ ERRIBUF(1, NERR) = TESTNUM
+ ERRIBUF(2, NERR) = NNODES
+ ERRIBUF(3, NERR) = DEST
+ ERRIBUF(4, NERR) = I
+ ERRIBUF(5, NERR) = J
+ ERRIBUF(6, NERR) = -15
+ ERRDBUF(1, NERR) = CA(H)
+ ERRDBUF(2, NERR) = CAMN
+ END IF
+ END IF
+ END IF
+ END IF
+ 90 CONTINUE
+ 100 CONTINUE
+*
+ RETURN
+*
+* End of CCHKAMN
+*
+ END
+*
+*
+ SUBROUTINE ZAMNTEST( OUTNUM, VERB, TOPSREPEAT, TOPSCOHRNT, NSCOPE,
+ $ SCOPE0, NTOP, TOP0, NMAT, M0, N0, LDAS0,
+ $ LDAD0, LDI0, NDEST, RDEST0, CDEST0, NGRID,
+ $ CONTEXT0, P0, Q0, ISEED, RMEM, CMEM, RCLEN,
+ $ MEM, MEMLEN )
+*
+* -- BLACS tester (version 1.0) --
+* University of Tennessee
+* December 15, 1994
+*
+*
+* .. Scalar Arguments ..
+ INTEGER MEMLEN, NDEST, NGRID, NMAT, NSCOPE, NTOP, OUTNUM, RCLEN,
+ $ TOPSCOHRNT, TOPSREPEAT, VERB
+* ..
+* .. Array Arguments ..
+ CHARACTER*1 SCOPE0(NSCOPE), TOP0(NTOP)
+ INTEGER M0(NMAT), N0(NMAT), LDAS0(NMAT), LDAD0(NMAT), LDI0(NMAT)
+ INTEGER RDEST0(NDEST), CDEST0(NDEST), CONTEXT0(NGRID)
+ INTEGER P0(NGRID), Q0(NGRID), ISEED(*), RMEM(RCLEN), CMEM(RCLEN)
+ DOUBLE COMPLEX MEM(MEMLEN)
+* ..
+*
+* Purpose
+* =======
+* ZTESTAMN: Test double complex AMN COMBINE
+*
+* Arguments
+* =========
+* OUTNUM (input) INTEGER
+* The device number to write output to.
+*
+* VERB (input) INTEGER
+* The level of verbosity (how much printing to do).
+*
+* NSCOPE (input) INTEGER
+* The number of scopes to be tested.
+*
+* SCOPE0 (input) CHARACTER*1 array of dimension (NSCOPE)
+* Values of the scopes to be tested.
+*
+* NTOP (input) INTEGER
+* The number of topologies to be tested.
+*
+* TOP0 (input) CHARACTER*1 array of dimension (NTOP)
+* Values of the topologies to be tested.
+*
+* NMAT (input) INTEGER
+* The number of matrices to be tested.
+*
+* M0 (input) INTEGER array of dimension (NMAT)
+* Values of M to be tested.
+*
+* M0 (input) INTEGER array of dimension (NMAT)
+* Values of M to be tested.
+*
+* N0 (input) INTEGER array of dimension (NMAT)
+* Values of N to be tested.
+*
+* LDAS0 (input) INTEGER array of dimension (NMAT)
+* Values of LDAS (leading dimension of A on source process)
+* to be tested.
+*
+* LDAD0 (input) INTEGER array of dimension (NMAT)
+* Values of LDAD (leading dimension of A on destination
+* process) to be tested.
+* LDI0 (input) INTEGER array of dimension (NMAT)
+* Values of LDI (leading dimension of RA/CA) to be tested.
+* If LDI == -1, these RA/CA should not be accessed.
+*
+* NDEST (input) INTEGER
+* The number of destinations to be tested.
+*
+* RDEST0 (input) INTEGER array of dimension (NNDEST)
+* Values of RDEST (row coordinate of destination) to be
+* tested.
+*
+* CDEST0 (input) INTEGER array of dimension (NNDEST)
+* Values of CDEST (column coordinate of destination) to be
+* tested.
+*
+* NGRID (input) INTEGER
+* The number of process grids to be tested.
+*
+* CONTEXT0 (input) INTEGER array of dimension (NGRID)
+* The BLACS context handles corresponding to the grids.
+*
+* P0 (input) INTEGER array of dimension (NGRID)
+* Values of P (number of process rows, NPROW).
+*
+* Q0 (input) INTEGER array of dimension (NGRID)
+* Values of Q (number of process columns, NPCOL).
+*
+* ISEED (workspace) INTEGER array of dimension ( MAX(NPROCS, NTESTS) )
+* Workspace used to hold each process's random number SEED.
+* This requires NPROCS (number of processor) elements.
+* If VERB < 2, this workspace also serves to indicate which
+* tests fail. This requires workspace of NTESTS
+* (number of tests performed).
+*
+* RMEM (workspace) INTEGER array of dimension (RCLEN)
+* Used for all RA arrays, and their pre and post padding.
+*
+* CMEM (workspace) INTEGER array of dimension (RCLEN)
+* Used for all CA arrays, and their pre and post padding.
+*
+* RCLEN (input) INTEGER
+* The length, in elements, of RMEM and CMEM.
+*
+* MEM (workspace) DOUBLE COMPLEX array of dimension (MEMLEN)
+* Used for all other workspaces, including the matrix A,
+* and its pre and post padding.
+*
+* MEMLEN (input) INTEGER
+* The length, in elements, of MEM.
+*
+* =====================================================================
+*
+* .. External Functions ..
+ LOGICAL ALLPASS, LSAME
+ INTEGER IBTMYPROC, IBTNPROCS, IBTSIZEOF
+ EXTERNAL ALLPASS, LSAME, IBTMYPROC, IBTNPROCS, IBTSIZEOF
+* ..
+* .. External Subroutines ..
+ EXTERNAL BLACS_GRIDINFO, ZGAMN2D
+ EXTERNAL ZINITMAT, ZCHKPAD, ZBTCHECKIN
+* ..
+* .. Local Scalars ..
+ CHARACTER*1 SCOPE, TOP
+ LOGICAL INGRID, TESTOK, ALLRCV
+ INTEGER APTR, CAPTR, CDEST, CDEST2, CONTEXT, ERRDPTR, ERRIPTR, I,
+ $ IAM, ICHECKVAL, IDE, IGR, IMA, IPAD, IPOST, IPRE, ISC,
+ $ ISIZE, ISTART, ISTOP, ITC, ITC1, ITC2, ITO, ITR, ITR1,
+ $ ITR2, J, K, LDA, LDADST, LDASRC, LDI, M, MAXERR, MYCOL,
+ $ MYROW, N, NERR, NFAIL, NPCOL, NPROW, NSKIP, PREAPTR,
+ $ RAPTR, RDEST, RDEST2, SETWHAT, TESTNUM, VALPTR, ZSIZE
+ DOUBLE COMPLEX CHECKVAL
+* ..
+* .. Executable Statements ..
+*
+* Choose padding value, and make it unique
+*
+ CHECKVAL = DCMPLX( -9.11D0, -9.21D0 )
+ IAM = IBTMYPROC()
+ CHECKVAL = IAM * CHECKVAL
+ ISIZE = IBTSIZEOF('I')
+ ZSIZE = IBTSIZEOF('Z')
+ ICHECKVAL = -IAM
+*
+* Verify file parameters
+*
+ IF( IAM .EQ. 0 ) THEN
+ WRITE(OUTNUM, *) ' '
+ WRITE(OUTNUM, *) ' '
+ WRITE(OUTNUM, 1000 )
+ IF( VERB .GT. 0 ) THEN
+ WRITE(OUTNUM,*) ' '
+ WRITE(OUTNUM, 2000) 'NSCOPE:', NSCOPE
+ WRITE(OUTNUM, 3000) ' SCOPE:', ( SCOPE0(I), I = 1, NSCOPE )
+ WRITE(OUTNUM, 2000) 'TReps :', TOPSREPEAT
+ WRITE(OUTNUM, 2000) 'TCohr :', TOPSCOHRNT
+ WRITE(OUTNUM, 2000) 'NTOP :', NTOP
+ WRITE(OUTNUM, 3000) ' TOP :', ( TOP0(I), I = 1, NTOP )
+ WRITE(OUTNUM, 2000) 'NMAT :', NMAT
+ WRITE(OUTNUM, 2000) ' M :', ( M0(I), I = 1, NMAT )
+ WRITE(OUTNUM, 2000) ' N :', ( N0(I), I = 1, NMAT )
+ WRITE(OUTNUM, 2000) ' LDAS :', ( LDAS0(I), I = 1, NMAT )
+ WRITE(OUTNUM, 2000) ' LDAD :', ( LDAD0(I), I = 1, NMAT )
+ WRITE(OUTNUM, 2000) ' LDI :', ( LDI0(I), I = 1, NMAT )
+ WRITE(OUTNUM, 2000) 'NDEST :', NDEST
+ WRITE(OUTNUM, 2000) ' RDEST:',( RDEST0(I), I = 1, NDEST )
+ WRITE(OUTNUM, 2000) ' CDEST:',( CDEST0(I), I = 1, NDEST )
+ WRITE(OUTNUM, 2000) 'NGRIDS:', NGRID
+ WRITE(OUTNUM, 2000) ' P :', ( P0(I), I = 1, NGRID )
+ WRITE(OUTNUM, 2000) ' Q :', ( Q0(I), I = 1, NGRID )
+ WRITE(OUTNUM, 2000) 'VERB :', VERB
+ WRITE(OUTNUM,*) ' '
+ END IF
+ IF( VERB .GT. 1 ) THEN
+ WRITE(OUTNUM,4000)
+ WRITE(OUTNUM,5000)
+ END IF
+ END IF
+ IF (TOPSREPEAT.EQ.0) THEN
+ ITR1 = 0
+ ITR2 = 0
+ ELSE IF (TOPSREPEAT.EQ.1) THEN
+ ITR1 = 1
+ ITR2 = 1
+ ELSE
+ ITR1 = 0
+ ITR2 = 1
+ END IF
+*
+* Find biggest matrix, so we know where to stick error info
+*
+ I = 0
+ DO 10 IMA = 1, NMAT
+ IPAD = 4 * M0(IMA)
+ K = N0(IMA) * MAX0( LDAS0(IMA), LDAD0(IMA) ) + IPAD
+ IF( K .GT. I ) I = K
+ 10 CONTINUE
+ I = I + IBTNPROCS()
+ MAXERR = ( ZSIZE * (MEMLEN-I) ) / ( ZSIZE*2 + ISIZE*6 )
+ IF( MAXERR .LT. 1 ) THEN
+ WRITE(OUTNUM,*) 'ERROR: Not enough memory to run MIN tests.'
+ CALL BLACS_ABORT(-1, 1)
+ END IF
+ ERRDPTR = I + 1
+ ERRIPTR = ERRDPTR + MAXERR
+ NERR = 0
+ TESTNUM = 0
+ NFAIL = 0
+ NSKIP = 0
+*
+* Loop over grids of matrix
+*
+ DO 90 IGR = 1, NGRID
+*
+* allocate process grid for the next batch of tests
+*
+ CONTEXT = CONTEXT0(IGR)
+ CALL BLACS_GRIDINFO( CONTEXT, NPROW, NPCOL, MYROW, MYCOL )
+ INGRID = ( (MYROW.LT.NPROW) .AND. (MYCOL.LT.NPCOL) )
+*
+ DO 80 ISC = 1, NSCOPE
+ SCOPE = SCOPE0(ISC)
+ DO 70 ITO = 1, NTOP
+ TOP = TOP0(ITO)
+*
+* If testing multiring ('M') or general tree ('T'), need to
+* loop over calls to BLACS_SET to do full test
+*
+ IF( LSAME(TOP, 'M') ) THEN
+ SETWHAT = 13
+ IF( SCOPE .EQ. 'R' ) THEN
+ ISTART = -(NPCOL - 1)
+ ISTOP = -ISTART
+ ELSE IF (SCOPE .EQ. 'C') THEN
+ ISTART = -(NPROW - 1)
+ ISTOP = -ISTART
+ ELSE
+ ISTART = -(NPROW*NPCOL - 1)
+ ISTOP = -ISTART
+ ENDIF
+ ELSE IF( LSAME(TOP, 'T') ) THEN
+ SETWHAT = 14
+ ISTART = 1
+ IF( SCOPE .EQ. 'R' ) THEN
+ ISTOP = NPCOL - 1
+ ELSE IF (SCOPE .EQ. 'C') THEN
+ ISTOP = NPROW - 1
+ ELSE
+ ISTOP = NPROW*NPCOL - 1
+ ENDIF
+ ELSE
+ SETWHAT = 0
+ ISTART = 1
+ ISTOP = 1
+ ENDIF
+ DO 60 IMA = 1, NMAT
+ M = M0(IMA)
+ N = N0(IMA)
+ LDASRC = LDAS0(IMA)
+ LDADST = LDAD0(IMA)
+ LDI = LDI0(IMA)
+ IPRE = 2 * M
+ IPOST = IPRE
+ PREAPTR = 1
+ APTR = PREAPTR + IPRE
+*
+ DO 50 IDE = 1, NDEST
+ TESTNUM = TESTNUM + 1
+ RDEST2 = RDEST0(IDE)
+ CDEST2 = CDEST0(IDE)
+*
+* If everyone gets the answer, create some bogus rdest/cdest
+* so IF's are easier
+*
+ ALLRCV = ( (RDEST2.EQ.-1) .OR. (CDEST2.EQ.-1) )
+ IF( ALLRCV ) THEN
+ RDEST = NPROW - 1
+ CDEST = NPCOL - 1
+ IF (TOPSCOHRNT.EQ.0) THEN
+ ITR1 = 0
+ ITR2 = 0
+ ELSE IF (TOPSCOHRNT.EQ.1) THEN
+ ITR1 = 1
+ ITR2 = 1
+ ELSE
+ ITR1 = 0
+ ITR2 = 1
+ END IF
+ ELSE
+ RDEST = RDEST2
+ CDEST = CDEST2
+ ITC1 = 0
+ ITC2 = 0
+ END IF
+ IF( RDEST.GE.P0(IGR) .OR. CDEST.GE.Q0(IGR) ) THEN
+ NSKIP = NSKIP + 1
+ GOTO 50
+ END IF
+*
+ IF( MYROW.EQ.RDEST .AND. MYCOL.EQ.CDEST ) THEN
+ LDA = LDADST
+ ELSE
+ LDA = LDASRC
+ END IF
+ VALPTR = APTR + IPOST + N * LDA
+ IF( VERB .GT. 1 ) THEN
+ IF( IAM .EQ. 0 ) THEN
+ WRITE(OUTNUM, 6000)
+ $ TESTNUM, 'RUNNING', SCOPE, TOP, M, N,
+ $ LDASRC, LDADST, LDI, RDEST2, CDEST2,
+ $ NPROW, NPCOL
+ END IF
+ END IF
+*
+* If I am in scope
+*
+ TESTOK = .TRUE.
+ IF( INGRID ) THEN
+ IF( (MYROW.EQ.RDEST .AND. SCOPE.EQ.'R') .OR.
+ $ (MYCOL.EQ.CDEST .AND. SCOPE.EQ.'C') .OR.
+ $ (SCOPE .EQ. 'A') ) THEN
+*
+ K = NERR
+ DO 40 ITR = ITR1, ITR2
+ CALL BLACS_SET(CONTEXT, 15, ITR)
+ DO 35 ITC = ITC1, ITC2
+ CALL BLACS_SET(CONTEXT, 16, ITC)
+ DO 30 J = ISTART, ISTOP
+ IF( J.EQ.0) GOTO 30
+ IF( SETWHAT.NE.0 )
+ $ CALL BLACS_SET(CONTEXT, SETWHAT, J)
+*
+*
+* generate and pad matrix A
+*
+ CALL ZINITMAT('G','-', M, N, MEM(PREAPTR),
+ $ LDA, IPRE, IPOST,
+ $ CHECKVAL, TESTNUM,
+ $ MYROW, MYCOL )
+*
+* If they exist, pad RA and CA arrays
+*
+ IF( LDI .NE. -1 ) THEN
+ DO 15 I = 1, N*LDI + IPRE + IPOST
+ RMEM(I) = ICHECKVAL
+ CMEM(I) = ICHECKVAL
+ 15 CONTINUE
+ RAPTR = 1 + IPRE
+ CAPTR = 1 + IPRE
+ ELSE
+ DO 20 I = 1, IPRE+IPOST
+ RMEM(I) = ICHECKVAL
+ CMEM(I) = ICHECKVAL
+ 20 CONTINUE
+ RAPTR = 1
+ CAPTR = 1
+ END IF
+*
+ CALL ZGAMN2D(CONTEXT, SCOPE, TOP, M, N,
+ $ MEM(APTR), LDA, RMEM(RAPTR),
+ $ CMEM(CAPTR), LDI,
+ $ RDEST2, CDEST2)
+*
+* If I've got the answer, check for errors in
+* matrix or padding
+*
+ IF( (MYROW.EQ.RDEST .AND. MYCOL.EQ.CDEST)
+ $ .OR. ALLRCV ) THEN
+ CALL ZCHKPAD('G','-', M, N,
+ $ MEM(PREAPTR), LDA, RDEST,
+ $ CDEST, MYROW, MYCOL,
+ $ IPRE, IPOST, CHECKVAL,
+ $ TESTNUM, MAXERR, NERR,
+ $ MEM(ERRIPTR),MEM(ERRDPTR))
+ CALL ZCHKAMN(SCOPE, CONTEXT, M, N,
+ $ MEM(APTR), LDA,
+ $ RMEM(RAPTR), CMEM(CAPTR),
+ $ LDI, TESTNUM, MAXERR,NERR,
+ $ MEM(ERRIPTR),MEM(ERRDPTR),
+ $ ISEED, MEM(VALPTR))
+ CALL ZRCCHK(IPRE, IPOST, ICHECKVAL,
+ $ M, N, RMEM, CMEM, LDI,
+ $ MYROW, MYCOL, TESTNUM,
+ $ MAXERR, NERR,
+ $ MEM(ERRIPTR), MEM(ERRDPTR))
+ END IF
+ 30 CONTINUE
+ CALL BLACS_SET(CONTEXT, 16, 0)
+ 35 CONTINUE
+ CALL BLACS_SET(CONTEXT, 15, 0)
+ 40 CONTINUE
+ TESTOK = ( K .EQ. NERR )
+ END IF
+ END IF
+*
+ IF( VERB .GT. 1 ) THEN
+ I = NERR
+ CALL ZBTCHECKIN(0, OUTNUM, MAXERR, NERR,
+ $ MEM(ERRIPTR), MEM(ERRDPTR), ISEED)
+ IF( IAM .EQ. 0 ) THEN
+ IF( TESTOK .AND. NERR.EQ.I ) THEN
+ WRITE(OUTNUM,6000)TESTNUM,'PASSED ',
+ $ SCOPE, TOP, M, N, LDASRC,
+ $ LDADST, LDI, RDEST2, CDEST2,
+ $ NPROW, NPCOL
+ ELSE
+ NFAIL = NFAIL + 1
+ WRITE(OUTNUM,6000)TESTNUM,'FAILED ',
+ $ SCOPE, TOP, M, N, LDASRC,
+ $ LDADST, LDI, RDEST2, CDEST2,
+ $ NPROW, NPCOL
+ END IF
+ END IF
+*
+* Once we've printed out errors, can re-use buf space
+*
+ NERR = 0
+ END IF
+ 50 CONTINUE
+ 60 CONTINUE
+ 70 CONTINUE
+ 80 CONTINUE
+ 90 CONTINUE
+*
+ IF( VERB .LT. 2 ) THEN
+ NFAIL = TESTNUM
+ CALL ZBTCHECKIN( NFAIL, OUTNUM, MAXERR, NERR, MEM(ERRIPTR),
+ $ MEM(ERRDPTR), ISEED )
+ END IF
+ IF( IAM .EQ. 0 ) THEN
+ IF( VERB .GT. 1 ) WRITE(OUTNUM,*) ' '
+ IF( NFAIL+NSKIP .EQ. 0 ) THEN
+ WRITE(OUTNUM, 7000 ) TESTNUM
+ ELSE
+ WRITE(OUTNUM, 8000 ) TESTNUM, TESTNUM-NSKIP-NFAIL,
+ $ NSKIP, NFAIL
+ END IF
+ END IF
+*
+* Log whether their were any failures
+*
+ TESTOK = ALLPASS( (NFAIL.EQ.0) )
+*
+ 1000 FORMAT('DOUBLE COMPLEX AMN TESTS: BEGIN.' )
+ 2000 FORMAT(1X,A7,3X,10I6)
+ 3000 FORMAT(1X,A7,3X,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1,5X,A1,
+ $ 5X,A1,5X,A1)
+ 4000 FORMAT(' TEST# STATUS SCOPE TOP M N LDAS LDAD LDI ',
+ $ 'RDEST CDEST P Q')
+ 5000 FORMAT(' ----- ------- ----- --- ----- ----- ----- ----- ----- ',
+ $ '----- ----- ---- ----')
+ 6000 FORMAT(I6,1X,A7,5X,A1,3X,A1,7I6,2I5)
+ 7000 FORMAT('DOUBLE COMPLEX AMN TESTS: PASSED ALL',
+ $ I5, ' TESTS.')
+ 8000 FORMAT('DOUBLE COMPLEX AMN TESTS:',I5,' TESTS;',I5,' PASSED,',
+ $ I5,' SKIPPED,',I5,' FAILED.')
+*
+ RETURN
+*
+* End of ZTESTAMN.
+*
+ END
+*
+ SUBROUTINE ZCHKAMN( SCOPE, ICTXT, M, N, A, LDA, RA, CA, LDI,
+ $ TESTNUM, MAXERR, NERR, ERRIBUF, ERRDBUF,
+ $ ISEED, VALS )
+*
+* .. Scalar Arguments ..
+ CHARACTER*1 SCOPE
+ INTEGER ICTXT, M, N, LDA, LDI, TESTNUM, MAXERR, NERR
+* ..
+* .. Array Arguments ..
+ INTEGER RA(*), CA(*), ERRIBUF(6, MAXERR), ISEED(*)
+ DOUBLE COMPLEX A(LDA,*), ERRDBUF(2, MAXERR), VALS(*)
+* ..
+* .. External Functions ..
+ INTEGER IBTMYPROC, IBTNPROCS, IBTSPNUM
+ DOUBLE PRECISION DBTEPS, ZBTABS
+ DOUBLE COMPLEX ZBTRAN
+ EXTERNAL IBTMYPROC, IBTNPROCS, IBTSPNUM, ZBTRAN, DBTEPS, ZBTABS
+* ..
+* .. External Subroutines ..
+ EXTERNAL IBTSPCOORD
+* ..
+* .. Local Scalars ..
+ LOGICAL ERROR
+ INTEGER NPROCS, NNODES, NPROW, NPCOL, MYROW, MYCOL, RAMN, CAMN
+ INTEGER IAMN, I, J, K, H, DEST, NODE
+ DOUBLE PRECISION EPS
+* ..
+* .. Executable Statements ..
+*
+ NPROCS = IBTNPROCS()
+ EPS = DBTEPS()
+ CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL )
+ DEST = MYROW*NPROCS + MYCOL
+*
+* Set up seeds to match those used by each proc's genmat call
+*
+ IF( SCOPE .EQ. 'R' ) THEN
+ NNODES = NPCOL
+ DO 10 I = 0, NNODES-1
+ NODE = MYROW * NPROCS + I
+ ISEED(I*4+1) = MOD( 1002 + TESTNUM*5 + NODE*3, 4096 )
+ ISEED(I*4+2) = MOD( 2027 + TESTNUM*7 + NODE, 4096 )
+ ISEED(I*4+3) = MOD( 1234 + TESTNUM + NODE*3, 4096 )
+ ISEED(I*4+4) = MOD( 4311 + TESTNUM*10 + NODE*2, 4096 )
+ 10 CONTINUE
+ ELSE IF( SCOPE .EQ. 'C' ) THEN
+ NNODES = NPROW
+ DO 20 I = 0, NNODES-1
+ NODE = I * NPROCS + MYCOL
+ ISEED(I*4+1) = MOD( 1002 + TESTNUM*5 + NODE*3, 4096 )
+ ISEED(I*4+2) = MOD( 2027 + TESTNUM*7 + NODE, 4096 )
+ ISEED(I*4+3) = MOD( 1234 + TESTNUM + NODE*3, 4096 )
+ ISEED(I*4+4) = MOD( 4311 + TESTNUM*10 + NODE*2, 4096 )
+ 20 CONTINUE
+ ELSE
+ NNODES = NPROW * NPCOL
+ DO 30 I = 0, NNODES-1
+ NODE = (I / NPCOL) * NPROCS + MOD(I, NPCOL)
+ ISEED(I*4+1) = MOD( 1002 + TESTNUM*5 + NODE*3, 4096 )
+ ISEED(I*4+2) = MOD( 2027 + TESTNUM*7 + NODE, 4096 )
+ ISEED(I*4+3) = MOD( 1234 + TESTNUM + NODE*3, 4096 )
+ ISEED(I*4+4) = MOD( 4311 + TESTNUM*10 + NODE*2, 4096 )
+ 30 CONTINUE
+ END IF
+*
+ DO 100 J = 1, N
+ DO 90 I = 1, M
+ H = (J-1)*LDI + I
+ VALS(1) = ZBTRAN( ISEED )
+ IAMN = 1
+ IF( NNODES .GT. 1 ) THEN
+ DO 40 K = 1, NNODES-1
+ VALS(K+1) = ZBTRAN( ISEED(K*4+1) )
+ IF( ZBTABS( VALS(K+1) ) .LT. ZBTABS( VALS(IAMN) ) )
+ $ IAMN = K + 1
+ 40 CONTINUE
+ END IF
+*
+* If BLACS have not returned same value we've chosen
+*
+ IF( A(I,J) .NE. VALS(IAMN) ) THEN
+*
+* If we have RA and CA arrays
+*
+ IF( LDI .NE. -1 ) THEN
+*
+* Any number having the same absolute value is a valid max
+*
+ K = IBTSPNUM( SCOPE, RA(H), CA(H), NPCOL ) + 1
+ IF( K.GT.0 .AND. K.LE.NNODES ) THEN
+ ERROR = ABS( ZBTABS(VALS(K)) - ZBTABS(VALS(IAMN)) )
+ $ .GT. 3*EPS
+ IF( .NOT.ERROR ) IAMN = K
+ ELSE
+ ERROR = .TRUE.
+ END IF
+ ELSE
+*
+* Error if BLACS answer not same absolute value, or if it
+* was not really in the numbers being compared
+*
+ ERROR = ABS( ZBTABS(A(I,J)) - ZBTABS(VALS(IAMN)) )
+ $ .GT. 3*EPS
+ IF( .NOT.ERROR ) THEN
+ DO 50 K = 1, NNODES
+ IF( VALS(K) .EQ. A(I,J) ) GOTO 60
+ 50 CONTINUE
+ ERROR = .TRUE.
+ 60 CONTINUE
+ ENDIF
+ END IF
+*
+* If the value is in error
+*
+ IF( ERROR ) THEN
+ NERR = NERR + 1
+ ERRIBUF(1, NERR) = TESTNUM
+ ERRIBUF(2, NERR) = NNODES
+ ERRIBUF(3, NERR) = DEST
+ ERRIBUF(4, NERR) = I
+ ERRIBUF(5, NERR) = J
+ ERRIBUF(6, NERR) = 5
+ ERRDBUF(1, NERR) = A(I,J)
+ ERRDBUF(2, NERR) = VALS(IAMN)
+ END IF
+ END IF
+*
+* If they are defined, make sure coordinate entries are OK
+*
+ IF( LDI .NE. -1 ) THEN
+ K = IBTSPNUM( SCOPE, RA(H), CA(H), NPCOL ) + 1
+ IF( K.NE.IAMN ) THEN
+*
+* Make sure more than one proc doesn't have exact same value
+* (and therefore there may be more than one valid coordinate
+* for a single value)
+*
+ IF( K.GT.NNODES .OR. K.LT.1 ) THEN
+ ERROR = .TRUE.
+ ELSE
+ ERROR = ( VALS(K) .NE. VALS(IAMN) )
+ END IF
+ IF( ERROR ) THEN
+ CALL IBTSPCOORD( SCOPE, IAMN-1, MYROW, MYCOL,
+ $ NPCOL, RAMN, CAMN )
+ IF( RAMN .NE. RA(H) ) THEN
+ NERR = NERR + 1
+ ERRIBUF(1, NERR) = TESTNUM
+ ERRIBUF(2, NERR) = NNODES
+ ERRIBUF(3, NERR) = DEST
+ ERRIBUF(4, NERR) = I
+ ERRIBUF(5, NERR) = J
+ ERRIBUF(6, NERR) = -5
+ ERRDBUF(1, NERR) = RA(H)
+ ERRDBUF(2, NERR) = RAMN
+ END IF
+ IF( CAMN .NE. CA(H) ) THEN
+ NERR = NERR + 1
+ ERRIBUF(1, NERR) = TESTNUM
+ ERRIBUF(2, NERR) = NNODES
+ ERRIBUF(3, NERR) = DEST
+ ERRIBUF(4, NERR) = I
+ ERRIBUF(5, NERR) = J
+ ERRIBUF(6, NERR) = -15
+ ERRDBUF(1, NERR) = CA(H)
+ ERRDBUF(2, NERR) = CAMN
+ END IF
+ END IF
+ END IF
+ END IF
+ 90 CONTINUE
+ 100 CONTINUE
+*
+ RETURN
+*
+* End of ZCHKAMN
+*
+ END
+*
diff --git a/BLACS/TESTING/bsbr.dat b/BLACS/TESTING/bsbr.dat
new file mode 100644
index 0000000..1768c37
--- /dev/null
+++ b/BLACS/TESTING/bsbr.dat
@@ -0,0 +1,18 @@
+3 Number of scopes
+'R' 'C' 'A' values for scopes
+8 Number of topologies
+'I' 'S' '1' 'd' 'm' ' ' 'T' 'H' TOP
+5 Number of shapes
+'G' 'U' 'U' 'L' 'L' UPLO
+'E' 'U' 'N' 'U' 'N' DIAG
+5 Number of matrices
+2 1 25 13 0 M
+2 7 19 32 0 N
+3 3 25 14 1 LDASRC
+2 2 25 22 1 LDADEST
+4 Number of src/dest pairs
+0 1 3 2 RSRC
+0 0 1 1 CSRC
+4 Number of grids
+2 4 1 1 7 1 4 NPROW
+2 1 3 4 1 8 2 NPCOL
diff --git a/BLACS/TESTING/bt.dat b/BLACS/TESTING/bt.dat
new file mode 100644
index 0000000..82db3b3
--- /dev/null
+++ b/BLACS/TESTING/bt.dat
@@ -0,0 +1,10 @@
+'Sample BLACS tester run' Comment line
+6 device out
+'blacstest.out' output fname
+'T' Run SDRV?
+'T' Run BSBR?
+'T' Run COMB?
+'T' Run AUX?
+5 Number of precisions
+'I' 'S' 'D' 'C' 'Z' Values for precision
+0 Verbosity level
diff --git a/BLACS/TESTING/btprim.f b/BLACS/TESTING/btprim.f
new file mode 100644
index 0000000..e73c0b5
--- /dev/null
+++ b/BLACS/TESTING/btprim.f
@@ -0,0 +1,377 @@
+ SUBROUTINE BTSETUP( MEM, MEMLEN, CMEM, CMEMLEN, OUTNUM,
+ $ TESTSDRV, TESTBSBR, TESTCOMB, TESTAUX,
+ $ IAM, NNODES )
+*
+* -- BLACS tester (version 1.0) --
+* University of Tennessee
+* December 15, 1994
+*
+* .. Scalar Arguments ..
+ LOGICAL TESTSDRV, TESTBSBR, TESTCOMB, TESTAUX
+ INTEGER MEMLEN, CMEMLEN, OUTNUM, IAM, NNODES
+* ..
+* .. Array Arguments ..
+ INTEGER MEM(MEMLEN)
+ CHARACTER*1 CMEM(CMEMLEN)
+* ..
+*
+* Purpose
+* =======
+* BTSETUP: Sets up communicator and initiliazes MPI if needed.
+*
+* ====================================================================
+*
+* ..
+* .. Local Scalars
+ LOGICAL INIT
+* ..
+* .. Include Files ..
+ INCLUDE 'mpif.h'
+* ..
+* .. Common Blocks ..
+ COMMON /BTMPI/ BTCOMM, IERR
+ INTEGER BTCOMM, IERR
+* ..
+* .. Executable Statements ..
+*
+ IERR = 0
+ CALL MPI_INITIALIZED(INIT, IERR)
+ IF (.NOT.INIT) CALL MPI_INIT(IERR)
+ IF (IERR.NE.0) CALL BTMPIERR("mpi_init", IERR)
+ CALL MPI_COMM_DUP(MPI_COMM_WORLD, BTCOMM, IERR)
+ IF (IERR.NE.0) CALL BTMPIERR("MPI_COMM_DUP", IERR)
+*
+ RETURN
+ END
+ INTEGER FUNCTION IBTMYPROC()
+*
+* -- BLACS tester (version 1.0) --
+* University of Tennessee
+* December 15, 1994
+*
+* Purpose
+* =======
+* IBTMYPROC: returns a process number between 0 .. NPROCS-1. On
+* systems not natively in this numbering scheme, translates to it.
+*
+* ====================================================================
+* ..
+* .. Include Files ..
+ INCLUDE 'mpif.h'
+* ..
+* .. Local Scalars ..
+ INTEGER RANK
+* ..
+* .. Common Blocks ..
+ COMMON /BTMPI/ BTCOMM, IERR
+ INTEGER BTCOMM, IERR
+* ..
+* .. Executable Statements ..
+*
+ CALL MPI_COMM_RANK(BTCOMM, RANK, IERR)
+ IF (IERR.NE.0) CALL BTMPIERR("MPI_COMM_RANK", IERR)
+ IBTMYPROC = RANK
+ RETURN
+*
+* End of IBTMYPROC
+*
+ END
+*
+ INTEGER FUNCTION IBTNPROCS()
+*
+* -- BLACS tester (version 1.0) --
+* University of Tennessee
+* December 15, 1994
+*
+* Purpose
+* =======
+* IBTNPROCS: returns the number of processes in the machine.
+*
+* ====================================================================
+* ..
+* .. Include Files ..
+ INCLUDE 'mpif.h'
+* ..
+* .. Local Scalars ..
+ INTEGER NPROC
+* ..
+* .. Common Blocks ..
+ COMMON /BTMPI/ BTCOMM, IERR
+ INTEGER BTCOMM, IERR
+* ..
+* .. Executable Statements ..
+*
+ CALL MPI_COMM_SIZE(BTCOMM, NPROC, IERR)
+ IF (IERR.NE.0) CALL BTMPIERR("MPI_COMM_SIZE", IERR)
+ IBTNPROCS = NPROC
+*
+ RETURN
+*
+* End of IBTNPROCS
+*
+ END
+*
+ SUBROUTINE BTSEND(DTYPE, N, BUFF, DEST, MSGID)
+*
+* -- BLACS tester (version 1.0) --
+* University of Tennessee
+* December 15, 1994
+*
+* .. Scalar Arguments ..
+ INTEGER N, DTYPE, DEST, MSGID
+* ..
+* .. Array Arguments ..
+ REAL BUFF(*)
+* ..
+*
+* PURPOSE
+* =======
+* BTSEND: Communication primitive used to send messages independent
+* of the BLACS. May safely be either locally or globally blocking.
+*
+* Arguments
+* =========
+* DTYPE (input) INTEGER
+* Indicates what data type BUFF is (same as PVM):
+* 1 = RAW BYTES
+* 3 = INTEGER
+* 4 = SINGLE PRECISION REAL
+* 6 = DOUBLE PRECISION REAL
+* 5 = SINGLE PRECISION COMPLEX
+* 7 = DOUBLE PRECISION COMPLEX
+*
+* N (input) INTEGER
+* The number of elements of type DTYPE in BUFF.
+*
+* BUFF (input) accepted as INTEGER array
+* The array to be communicated. Its true data type is
+* indicated by DTYPE.
+*
+* DEST (input) INTEGER
+* The destination of the message.
+*
+* MSGID (input) INTEGER
+* The message ID (AKA message tag or type).
+*
+* =====================================================================
+* .. External Functions ..
+ INTEGER IBTMYPROC, IBTNPROCS, IBTSIZEOF
+ EXTERNAL IBTMYPROC, IBTNPROCS, IBTSIZEOF
+* ..
+* .. Local Scalars ..
+ INTEGER I, IAM, MPIDTYPE
+* ..
+* .. Include Files ..
+ INCLUDE 'mpif.h'
+* ..
+* .. Common Blocks ..
+ COMMON /BTMPI/ BTCOMM, IERR
+ INTEGER BTCOMM, IERR
+*
+ IF( DTYPE .EQ. 1 ) THEN
+ MPIDTYPE = MPI_BYTE
+ ELSE IF( DTYPE .EQ. 3 ) THEN
+ MPIDTYPE = MPI_INTEGER
+ ELSE IF( DTYPE .EQ. 4 ) THEN
+ MPIDTYPE = MPI_REAL
+ ELSE IF( DTYPE .EQ. 5 ) THEN
+ MPIDTYPE = MPI_COMPLEX
+ ELSE IF( DTYPE .EQ. 6 ) THEN
+ MPIDTYPE = MPI_DOUBLE_PRECISION
+ ELSE IF( DTYPE .EQ. 7 ) THEN
+ MPIDTYPE = MPI_DOUBLE_COMPLEX
+ END IF
+*
+* Send the message
+*
+ IF( DEST .EQ. -1 ) THEN
+ IAM = IBTMYPROC()
+ DO 10 I = 0, IBTNPROCS()-1
+ IF( I .NE. IAM ) THEN
+ CALL MPI_SEND(BUFF, N, MPIDTYPE, I, 0, BTCOMM, IERR)
+ IF (IERR.NE.0) CALL BTMPIERR("MPI_SEND", IERR)
+ END IF
+ 10 CONTINUE
+ ELSE
+ CALL MPI_SEND(BUFF, N, MPIDTYPE, DEST, 0, BTCOMM, IERR)
+ IF (IERR.NE.0) CALL BTMPIERR("MPI_SEND", IERR)
+ END IF
+*
+ RETURN
+*
+* End BTSEND
+*
+ END
+*
+ SUBROUTINE BTRECV(DTYPE, N, BUFF, SRC, MSGID)
+*
+* -- BLACS tester (version 1.0) --
+* University of Tennessee
+* December 15, 1994
+*
+*
+* .. Scalar Arguments ..
+ INTEGER N, DTYPE, SRC, MSGID
+* ..
+* .. Array Arguments ..
+ REAL BUFF(*)
+* ..
+*
+* PURPOSE
+* =======
+* BTRECV: Globally blocking receive.
+*
+* Arguments
+* =========
+* DTYPE (input) INTEGER
+* Indicates what data type BUFF is:
+* 1 = RAW BYTES
+* 3 = INTEGER
+* 4 = SINGLE PRECISION REAL
+* 6 = DOUBLE PRECISION REAL
+* 5 = SINGLE PRECISION COMPLEX
+* 7 = DOUBLE PRECISION COMPLEX
+*
+* N (input) INTEGER
+* The number of elements of type DTYPE in BUFF.
+*
+* BUFF (output) INTEGER
+* The buffer to receive into.
+*
+* SRC (input) INTEGER
+* The source of the message.
+*
+* MSGID (input) INTEGER
+* The message ID.
+*
+* =====================================================================
+* ..
+* .. Local Scalars ..
+ INTEGER MPIDTYPE
+* ..
+* .. Include Files ..
+ INCLUDE 'mpif.h'
+* ..
+* .. Local Arrays ..
+ INTEGER STAT(MPI_STATUS_SIZE)
+* ..
+* .. Common Blocks ..
+ COMMON /BTMPI/ BTCOMM, IERR
+ INTEGER BTCOMM, IERR
+*
+ IF( DTYPE .EQ. 1 ) THEN
+ MPIDTYPE = MPI_BYTE
+ ELSE IF( DTYPE .EQ. 3 ) THEN
+ MPIDTYPE = MPI_INTEGER
+ ELSE IF( DTYPE .EQ. 4 ) THEN
+ MPIDTYPE = MPI_REAL
+ ELSE IF( DTYPE .EQ. 5 ) THEN
+ MPIDTYPE = MPI_COMPLEX
+ ELSE IF( DTYPE .EQ. 6 ) THEN
+ MPIDTYPE = MPI_DOUBLE_PRECISION
+ ELSE IF( DTYPE .EQ. 7 ) THEN
+ MPIDTYPE = MPI_DOUBLE_COMPLEX
+ END IF
+*
+ CALL MPI_RECV( BUFF, N, MPIDTYPE, SRC, 0, BTCOMM, STAT, IERR )
+ IF (IERR.NE.0) CALL BTMPIERR("MPI_RECV", IERR)
+*
+ RETURN
+*
+* End of BTRECV
+*
+ END
+*
+ INTEGER FUNCTION IBTSIZEOF(TYPE)
+*
+* -- BLACS tester (version 1.0) --
+* University of Tennessee
+* December 15, 1994
+*
+* .. Scalar Arguments ..
+ CHARACTER*1 TYPE
+* ..
+*
+* Purpose
+* =======
+* IBTSIZEOF: Returns the size, in bytes, of the 5 data types.
+* If your platform has a different size for DOUBLE PRECISION, you must
+* change the parameter statement in BLACSTEST as well.
+*
+* Arguments
+* =========
+* TYPE (input) CHARACTER*1
+* The data type who's size is to be determined:
+* 'I' : INTEGER
+* 'S' : SINGLE PRECISION REAL
+* 'D' : DOUBLE PRECISION REAL
+* 'C' : SINGLE PRECISION COMPLEX
+* 'Z' : DOUBLE PRECISION COMPLEX
+*
+* =====================================================================
+*
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. Include Files ..
+ INCLUDE 'mpif.h'
+* ..
+* .. Common Blocks ..
+ COMMON /BTMPI/ BTCOMM, IERR
+ INTEGER BTCOMM, IERR
+* ..
+* .. Local Scalars ..
+ INTEGER LENGTH
+ LOGICAL INIT
+ DATA INIT /.FALSE./
+* ..
+* .. Executable Statements ..
+*
+*
+* Initialize MPI, if necessary
+*
+ IF (.NOT.INIT) THEN
+ CALL MPI_INITIALIZED(INIT, IERR)
+ IF (.NOT.INIT) CALL MPI_INIT(IERR)
+ IF (IERR.NE.0) CALL BTMPIERR("mpi_init", IERR)
+ INIT = .TRUE.
+ END IF
+*
+ IF( LSAME(TYPE, 'I') ) THEN
+ CALL MPI_TYPE_SIZE( MPI_INTEGER, LENGTH, IERR )
+ IF (IERR.NE.0) CALL BTMPIERR("MPI_TYPE_SIZE", IERR)
+ ELSE IF( LSAME(TYPE, 'S') ) THEN
+ CALL MPI_TYPE_SIZE( MPI_REAL, LENGTH, IERR )
+ IF (IERR.NE.0) CALL BTMPIERR("MPI_TYPE_SIZE", IERR)
+ ELSE IF( LSAME(TYPE, 'D') ) THEN
+ CALL MPI_TYPE_SIZE( MPI_DOUBLE_PRECISION, LENGTH, IERR )
+ IF (IERR.NE.0) CALL BTMPIERR("MPI_TYPE_SIZE", IERR)
+ ELSE IF( LSAME(TYPE, 'C') ) THEN
+ CALL MPI_TYPE_SIZE( MPI_COMPLEX, LENGTH, IERR )
+ IF (IERR.NE.0) CALL BTMPIERR("MPI_TYPE_SIZE", IERR)
+ ELSE IF( LSAME(TYPE, 'Z') ) THEN
+ CALL MPI_TYPE_SIZE( MPI_DOUBLE_COMPLEX, LENGTH, IERR )
+ IF (IERR.NE.0) CALL BTMPIERR("MPI_TYPE_SIZE", IERR)
+ END IF
+ IBTSIZEOF = LENGTH
+*
+ RETURN
+ END
+ SUBROUTINE BTMPIERR(ROUT, IERR0)
+ CHARACTER*(*) ROUT
+ INTEGER IERR0
+* ..
+* .. Include Files ..
+ INCLUDE 'mpif.h'
+* ..
+* .. Common Blocks ..
+ COMMON /BTMPI/ BTCOMM, IERR
+ INTEGER BTCOMM, IERR
+*
+ WRITE(*,1000) ROUT, IERR
+ CALL MPI_ABORT(BTCOMM, IERR0, IERR)
+*
+ 1000 FORMAT('Error #',I20,' from routine ',A)
+ RETURN
+ END
diff --git a/BLACS/TESTING/comb.dat b/BLACS/TESTING/comb.dat
new file mode 100644
index 0000000..5a3a511
--- /dev/null
+++ b/BLACS/TESTING/comb.dat
@@ -0,0 +1,20 @@
+3 Number of OPs
+'+' '>' '<' Combine operations to perform
+3 Number of scopes
+'R' 'C' 'A' values for scopes
+2 Repeatability flag (0=no-rep, 1=rep, 2=both)
+2 Coherence flag (0=no-coh, 1=coh, 2=both)
+4 Number of topologies
+' ' 'T' 'H' 'f' 'M' TOP
+6 Number of matrices
+3 1 2 25 13 0 M
+5 1 3 19 32 0 N
+5 1 4 25 14 1 LDASRC
+9 1 5 25 22 1 LDADEST
+4 1 -1 25 22 1 LDI
+4 Number of dests
+0 -1 0 2 RDEST
+0 -1 1 0 CDEST
+4 Number of grids
+2 1 4 1 1 8 3 NPROW
+2 4 1 3 7 1 2 NPCOL
diff --git a/BLACS/TESTING/runtest.cmake b/BLACS/TESTING/runtest.cmake
new file mode 100644
index 0000000..58c4420
--- /dev/null
+++ b/BLACS/TESTING/runtest.cmake
@@ -0,0 +1,24 @@
+message("Running BLACS TESTS")
+message(STATUS "${MPIEXEC} ${MPIEXEC_NUMPROC_FLAG} 4 ./${TEST_PROG}")
+message(STATUS "Output out_${TEST_PROG}.txt")
+file(COPY ${RUNTIMEDIR}/${TEST_PROG} DESTINATION ${OUTPUTDIR})
+
+execute_process(COMMAND ${MPIEXEC} ${MPIEXEC_NUMPROC_FLAG} 4 ./${TEST_PROG}
+ OUTPUT_FILE "out_${TEST_PROG}.txt"
+ ERROR_FILE "error_${TEST_PROG}.txt"
+ RESULT_VARIABLE HAD_ERROR)
+
+if(HAD_ERROR)
+ # This is normal to exit in Error (good behaviour)
+ # So we are going to check that the output have the last line of the testing : DONE BLACS_GRIDEXIT
+ file(READ "out_${TEST_PROG}.txt" TESTSTRING)
+
+ STRING(REPLACE "DONE BLACS_GRIDEXIT" "BLACS OK" tmp ${TESTSTRING})
+
+if("${tmp}" STREQUAL "${TESTSTRING}")
+ message( STATUS "Error in error_${TEST_PROG}.txt")
+ message(FATAL_ERROR "Test failed - Test did not reach DONE BLACS_GRIDEXIT")
+else()
+ message( STATUS "Test Passed")
+ endif()
+endif()
diff --git a/BLACS/TESTING/sdrv.dat b/BLACS/TESTING/sdrv.dat
new file mode 100644
index 0000000..2a3383d
--- /dev/null
+++ b/BLACS/TESTING/sdrv.dat
@@ -0,0 +1,16 @@
+5 Number of shapes
+'G' 'U' 'U' 'L' 'L' UPLO
+'E' 'U' 'N' 'U' 'N' DIAG
+5 Number of matrices
+2 1 25 13 0 M
+2 7 19 32 0 N
+2 3 25 14 1 LDASRC
+3 2 25 22 1 LDADEST
+1 Number of src/dest pairs
+0 1 3 0 RSRC
+0 0 0 2 CSRC
+0 1 2 0 RDEST
+1 1 0 0 CDEST
+3 Number of grids
+2 4 1 NPROW
+2 1 4 NPCOL
diff --git a/BLACS/TESTING/tools.f b/BLACS/TESTING/tools.f
new file mode 100644
index 0000000..7b14f23
--- /dev/null
+++ b/BLACS/TESTING/tools.f
@@ -0,0 +1,2087 @@
+* ================================================================
+* This file contains the following LAPACK routines, for use by the
+* BLACS tester: LSAME, SLAMCH, DLAMCH, DLARND, ZLARND, DLARAN,
+* and ZLARAN. If you have ScaLAPACK or LAPACK, all of these files
+* are present in your library, and you may discard this file and
+* point to the appropriate archive instead.
+* ================================================================
+
+ DOUBLE PRECISION FUNCTION DLAMCH( CMACH )
+*
+* -- LAPACK auxiliary routine (version 2.0) --
+* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
+* Courant Institute, Argonne National Lab, and Rice University
+* October 31, 1992
+*
+* .. Scalar Arguments ..
+ CHARACTER CMACH
+* ..
+*
+* Purpose
+* =======
+*
+* DLAMCH determines double precision machine parameters.
+*
+* Arguments
+* =========
+*
+* CMACH (input) CHARACTER*1
+* Specifies the value to be returned by DLAMCH:
+* = 'E' or 'e', DLAMCH := eps
+* = 'S' or 's , DLAMCH := sfmin
+* = 'B' or 'b', DLAMCH := base
+* = 'P' or 'p', DLAMCH := eps*base
+* = 'N' or 'n', DLAMCH := t
+* = 'R' or 'r', DLAMCH := rnd
+* = 'M' or 'm', DLAMCH := emin
+* = 'U' or 'u', DLAMCH := rmin
+* = 'L' or 'l', DLAMCH := emax
+* = 'O' or 'o', DLAMCH := rmax
+*
+* where
+*
+* eps = relative machine precision
+* sfmin = safe minimum, such that 1/sfmin does not overflow
+* base = base of the machine
+* prec = eps*base
+* t = number of (base) digits in the mantissa
+* rnd = 1.0 when rounding occurs in addition, 0.0 otherwise
+* emin = minimum exponent before (gradual) underflow
+* rmin = underflow threshold - base**(emin-1)
+* emax = largest exponent before overflow
+* rmax = overflow threshold - (base**emax)*(1-eps)
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ONE, ZERO
+ PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL FIRST, LRND
+ INTEGER BETA, IMAX, IMIN, IT
+ DOUBLE PRECISION BASE, EMAX, EMIN, EPS, PREC, RMACH, RMAX, RMIN,
+ $ RND, SFMIN, SMALL, T
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL DLAMC2
+* ..
+* .. Save statement ..
+ SAVE FIRST, EPS, SFMIN, BASE, T, RND, EMIN, RMIN,
+ $ EMAX, RMAX, PREC
+* ..
+* .. Data statements ..
+ DATA FIRST / .TRUE. /
+* ..
+* .. Executable Statements ..
+*
+ IF( FIRST ) THEN
+ FIRST = .FALSE.
+ CALL DLAMC2( BETA, IT, LRND, EPS, IMIN, RMIN, IMAX, RMAX )
+ BASE = BETA
+ T = IT
+ IF( LRND ) THEN
+ RND = ONE
+ EPS = ( BASE**( 1-IT ) ) / 2
+ ELSE
+ RND = ZERO
+ EPS = BASE**( 1-IT )
+ END IF
+ PREC = EPS*BASE
+ EMIN = IMIN
+ EMAX = IMAX
+ SFMIN = RMIN
+ SMALL = ONE / RMAX
+ IF( SMALL.GE.SFMIN ) THEN
+*
+* Use SMALL plus a bit, to avoid the possibility of rounding
+* causing overflow when computing 1/sfmin.
+*
+ SFMIN = SMALL*( ONE+EPS )
+ END IF
+ END IF
+*
+ IF( LSAME( CMACH, 'E' ) ) THEN
+ RMACH = EPS
+ ELSE IF( LSAME( CMACH, 'S' ) ) THEN
+ RMACH = SFMIN
+ ELSE IF( LSAME( CMACH, 'B' ) ) THEN
+ RMACH = BASE
+ ELSE IF( LSAME( CMACH, 'P' ) ) THEN
+ RMACH = PREC
+ ELSE IF( LSAME( CMACH, 'N' ) ) THEN
+ RMACH = T
+ ELSE IF( LSAME( CMACH, 'R' ) ) THEN
+ RMACH = RND
+ ELSE IF( LSAME( CMACH, 'M' ) ) THEN
+ RMACH = EMIN
+ ELSE IF( LSAME( CMACH, 'U' ) ) THEN
+ RMACH = RMIN
+ ELSE IF( LSAME( CMACH, 'L' ) ) THEN
+ RMACH = EMAX
+ ELSE IF( LSAME( CMACH, 'O' ) ) THEN
+ RMACH = RMAX
+ END IF
+*
+ DLAMCH = RMACH
+ RETURN
+*
+* End of DLAMCH
+*
+ END
+*
+************************************************************************
+*
+ SUBROUTINE DLAMC1( BETA, T, RND, IEEE1 )
+*
+* -- LAPACK auxiliary routine (version 2.0) --
+* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
+* Courant Institute, Argonne National Lab, and Rice University
+* October 31, 1992
+*
+* .. Scalar Arguments ..
+ LOGICAL IEEE1, RND
+ INTEGER BETA, T
+* ..
+*
+* Purpose
+* =======
+*
+* DLAMC1 determines the machine parameters given by BETA, T, RND, and
+* IEEE1.
+*
+* Arguments
+* =========
+*
+* BETA (output) INTEGER
+* The base of the machine.
+*
+* T (output) INTEGER
+* The number of ( BETA ) digits in the mantissa.
+*
+* RND (output) LOGICAL
+* Specifies whether proper rounding ( RND = .TRUE. ) or
+* chopping ( RND = .FALSE. ) occurs in addition. This may not
+* be a reliable guide to the way in which the machine performs
+* its arithmetic.
+*
+* IEEE1 (output) LOGICAL
+* Specifies whether rounding appears to be done in the IEEE
+* 'round to nearest' style.
+*
+* Further Details
+* ===============
+*
+* The routine is based on the routine ENVRON by Malcolm and
+* incorporates suggestions by Gentleman and Marovich. See
+*
+* Malcolm M. A. (1972) Algorithms to reveal properties of
+* floating-point arithmetic. Comms. of the ACM, 15, 949-951.
+*
+* Gentleman W. M. and Marovich S. B. (1974) More on algorithms
+* that reveal properties of floating point arithmetic units.
+* Comms. of the ACM, 17, 276-277.
+*
+* =====================================================================
+*
+* .. Local Scalars ..
+ LOGICAL FIRST, LIEEE1, LRND
+ INTEGER LBETA, LT
+ DOUBLE PRECISION A, B, C, F, ONE, QTR, SAVEC, T1, T2
+* ..
+* .. External Functions ..
+ DOUBLE PRECISION DLAMC3
+ EXTERNAL DLAMC3
+* ..
+* .. Save statement ..
+ SAVE FIRST, LIEEE1, LBETA, LRND, LT
+* ..
+* .. Data statements ..
+ DATA FIRST / .TRUE. /
+* ..
+* .. Executable Statements ..
+*
+ IF( FIRST ) THEN
+ FIRST = .FALSE.
+ ONE = 1
+*
+* LBETA, LIEEE1, LT and LRND are the local values of BETA,
+* IEEE1, T and RND.
+*
+* Throughout this routine we use the function DLAMC3 to ensure
+* that relevant values are stored and not held in registers, or
+* are not affected by optimizers.
+*
+* Compute a = 2.0**m with the smallest positive integer m such
+* that
+*
+* fl( a + 1.0 ) = a.
+*
+ A = 1
+ C = 1
+*
+*+ WHILE( C.EQ.ONE )LOOP
+ 10 CONTINUE
+ IF( C.EQ.ONE ) THEN
+ A = 2*A
+ C = DLAMC3( A, ONE )
+ C = DLAMC3( C, -A )
+ GO TO 10
+ END IF
+*+ END WHILE
+*
+* Now compute b = 2.0**m with the smallest positive integer m
+* such that
+*
+* fl( a + b ) .gt. a.
+*
+ B = 1
+ C = DLAMC3( A, B )
+*
+*+ WHILE( C.EQ.A )LOOP
+ 20 CONTINUE
+ IF( C.EQ.A ) THEN
+ B = 2*B
+ C = DLAMC3( A, B )
+ GO TO 20
+ END IF
+*+ END WHILE
+*
+* Now compute the base. a and c are neighbouring floating point
+* numbers in the interval ( beta**t, beta**( t + 1 ) ) and so
+* their difference is beta. Adding 0.25 to c is to ensure that it
+* is truncated to beta and not ( beta - 1 ).
+*
+ QTR = ONE / 4
+ SAVEC = C
+ C = DLAMC3( C, -A )
+ LBETA = C + QTR
+*
+* Now determine whether rounding or chopping occurs, by adding a
+* bit less than beta/2 and a bit more than beta/2 to a.
+*
+ B = LBETA
+ F = DLAMC3( B / 2, -B / 100 )
+ C = DLAMC3( F, A )
+ IF( C.EQ.A ) THEN
+ LRND = .TRUE.
+ ELSE
+ LRND = .FALSE.
+ END IF
+ F = DLAMC3( B / 2, B / 100 )
+ C = DLAMC3( F, A )
+ IF( ( LRND ) .AND. ( C.EQ.A ) )
+ $ LRND = .FALSE.
+*
+* Try and decide whether rounding is done in the IEEE 'round to
+* nearest' style. B/2 is half a unit in the last place of the two
+* numbers A and SAVEC. Furthermore, A is even, i.e. has last bit
+* zero, and SAVEC is odd. Thus adding B/2 to A should not change
+* A, but adding B/2 to SAVEC should change SAVEC.
+*
+ T1 = DLAMC3( B / 2, A )
+ T2 = DLAMC3( B / 2, SAVEC )
+ LIEEE1 = ( T1.EQ.A ) .AND. ( T2.GT.SAVEC ) .AND. LRND
+*
+* Now find the mantissa, t. It should be the integer part of
+* log to the base beta of a, however it is safer to determine t
+* by powering. So we find t as the smallest positive integer for
+* which
+*
+* fl( beta**t + 1.0 ) = 1.0.
+*
+ LT = 0
+ A = 1
+ C = 1
+*
+*+ WHILE( C.EQ.ONE )LOOP
+ 30 CONTINUE
+ IF( C.EQ.ONE ) THEN
+ LT = LT + 1
+ A = A*LBETA
+ C = DLAMC3( A, ONE )
+ C = DLAMC3( C, -A )
+ GO TO 30
+ END IF
+*+ END WHILE
+*
+ END IF
+*
+ BETA = LBETA
+ T = LT
+ RND = LRND
+ IEEE1 = LIEEE1
+ RETURN
+*
+* End of DLAMC1
+*
+ END
+*
+************************************************************************
+*
+ SUBROUTINE DLAMC2( BETA, T, RND, EPS, EMIN, RMIN, EMAX, RMAX )
+*
+* -- LAPACK auxiliary routine (version 2.0) --
+* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
+* Courant Institute, Argonne National Lab, and Rice University
+* October 31, 1992
+*
+* .. Scalar Arguments ..
+ LOGICAL RND
+ INTEGER BETA, EMAX, EMIN, T
+ DOUBLE PRECISION EPS, RMAX, RMIN
+* ..
+*
+* Purpose
+* =======
+*
+* DLAMC2 determines the machine parameters specified in its argument
+* list.
+*
+* Arguments
+* =========
+*
+* BETA (output) INTEGER
+* The base of the machine.
+*
+* T (output) INTEGER
+* The number of ( BETA ) digits in the mantissa.
+*
+* RND (output) LOGICAL
+* Specifies whether proper rounding ( RND = .TRUE. ) or
+* chopping ( RND = .FALSE. ) occurs in addition. This may not
+* be a reliable guide to the way in which the machine performs
+* its arithmetic.
+*
+* EPS (output) DOUBLE PRECISION
+* The smallest positive number such that
+*
+* fl( 1.0 - EPS ) .LT. 1.0,
+*
+* where fl denotes the computed value.
+*
+* EMIN (output) INTEGER
+* The minimum exponent before (gradual) underflow occurs.
+*
+* RMIN (output) DOUBLE PRECISION
+* The smallest normalized number for the machine, given by
+* BASE**( EMIN - 1 ), where BASE is the floating point value
+* of BETA.
+*
+* EMAX (output) INTEGER
+* The maximum exponent before overflow occurs.
+*
+* RMAX (output) DOUBLE PRECISION
+* The largest positive number for the machine, given by
+* BASE**EMAX * ( 1 - EPS ), where BASE is the floating point
+* value of BETA.
+*
+* Further Details
+* ===============
+*
+* The computation of EPS is based on a routine PARANOIA by
+* W. Kahan of the University of California at Berkeley.
+*
+* =====================================================================
+*
+* .. Local Scalars ..
+ LOGICAL FIRST, IEEE, IWARN, LIEEE1, LRND
+ INTEGER GNMIN, GPMIN, I, LBETA, LEMAX, LEMIN, LT,
+ $ NGNMIN, NGPMIN
+ DOUBLE PRECISION A, B, C, HALF, LEPS, LRMAX, LRMIN, ONE, RBASE,
+ $ SIXTH, SMALL, THIRD, TWO, ZERO
+* ..
+* .. External Functions ..
+ DOUBLE PRECISION DLAMC3
+ EXTERNAL DLAMC3
+* ..
+* .. External Subroutines ..
+ EXTERNAL DLAMC1, DLAMC4, DLAMC5
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX, MIN
+* ..
+* .. Save statement ..
+ SAVE FIRST, IWARN, LBETA, LEMAX, LEMIN, LEPS, LRMAX,
+ $ LRMIN, LT
+* ..
+* .. Data statements ..
+ DATA FIRST / .TRUE. / , IWARN / .FALSE. /
+* ..
+* .. Executable Statements ..
+*
+ IF( FIRST ) THEN
+ FIRST = .FALSE.
+ ZERO = 0
+ ONE = 1
+ TWO = 2
+*
+* LBETA, LT, LRND, LEPS, LEMIN and LRMIN are the local values of
+* BETA, T, RND, EPS, EMIN and RMIN.
+*
+* Throughout this routine we use the function DLAMC3 to ensure
+* that relevant values are stored and not held in registers, or
+* are not affected by optimizers.
+*
+* DLAMC1 returns the parameters LBETA, LT, LRND and LIEEE1.
+*
+ CALL DLAMC1( LBETA, LT, LRND, LIEEE1 )
+*
+* Start to find EPS.
+*
+ B = LBETA
+ A = B**( -LT )
+ LEPS = A
+*
+* Try some tricks to see whether or not this is the correct EPS.
+*
+ B = TWO / 3
+ HALF = ONE / 2
+ SIXTH = DLAMC3( B, -HALF )
+ THIRD = DLAMC3( SIXTH, SIXTH )
+ B = DLAMC3( THIRD, -HALF )
+ B = DLAMC3( B, SIXTH )
+ B = ABS( B )
+ IF( B.LT.LEPS )
+ $ B = LEPS
+*
+ LEPS = 1
+*
+*+ WHILE( ( LEPS.GT.B ).AND.( B.GT.ZERO ) )LOOP
+ 10 CONTINUE
+ IF( ( LEPS.GT.B ) .AND. ( B.GT.ZERO ) ) THEN
+ LEPS = B
+ C = DLAMC3( HALF*LEPS, ( TWO**5 )*( LEPS**2 ) )
+ C = DLAMC3( HALF, -C )
+ B = DLAMC3( HALF, C )
+ C = DLAMC3( HALF, -B )
+ B = DLAMC3( HALF, C )
+ GO TO 10
+ END IF
+*+ END WHILE
+*
+ IF( A.LT.LEPS )
+ $ LEPS = A
+*
+* Computation of EPS complete.
+*
+* Now find EMIN. Let A = + or - 1, and + or - (1 + BASE**(-3)).
+* Keep dividing A by BETA until (gradual) underflow occurs. This
+* is detected when we cannot recover the previous A.
+*
+ RBASE = ONE / LBETA
+ SMALL = ONE
+ DO 20 I = 1, 3
+ SMALL = DLAMC3( SMALL*RBASE, ZERO )
+ 20 CONTINUE
+ A = DLAMC3( ONE, SMALL )
+ CALL DLAMC4( NGPMIN, ONE, LBETA )
+ CALL DLAMC4( NGNMIN, -ONE, LBETA )
+ CALL DLAMC4( GPMIN, A, LBETA )
+ CALL DLAMC4( GNMIN, -A, LBETA )
+ IEEE = .FALSE.
+*
+ IF( ( NGPMIN.EQ.NGNMIN ) .AND. ( GPMIN.EQ.GNMIN ) ) THEN
+ IF( NGPMIN.EQ.GPMIN ) THEN
+ LEMIN = NGPMIN
+* ( Non twos-complement machines, no gradual underflow;
+* e.g., VAX )
+ ELSE IF( ( GPMIN-NGPMIN ).EQ.3 ) THEN
+ LEMIN = NGPMIN - 1 + LT
+ IEEE = .TRUE.
+* ( Non twos-complement machines, with gradual underflow;
+* e.g., IEEE standard followers )
+ ELSE
+ LEMIN = MIN( NGPMIN, GPMIN )
+* ( A guess; no known machine )
+ IWARN = .TRUE.
+ END IF
+*
+ ELSE IF( ( NGPMIN.EQ.GPMIN ) .AND. ( NGNMIN.EQ.GNMIN ) ) THEN
+ IF( ABS( NGPMIN-NGNMIN ).EQ.1 ) THEN
+ LEMIN = MAX( NGPMIN, NGNMIN )
+* ( Twos-complement machines, no gradual underflow;
+* e.g., CYBER 205 )
+ ELSE
+ LEMIN = MIN( NGPMIN, NGNMIN )
+* ( A guess; no known machine )
+ IWARN = .TRUE.
+ END IF
+*
+ ELSE IF( ( ABS( NGPMIN-NGNMIN ).EQ.1 ) .AND.
+ $ ( GPMIN.EQ.GNMIN ) ) THEN
+ IF( ( GPMIN-MIN( NGPMIN, NGNMIN ) ).EQ.3 ) THEN
+ LEMIN = MAX( NGPMIN, NGNMIN ) - 1 + LT
+* ( Twos-complement machines with gradual underflow;
+* no known machine )
+ ELSE
+ LEMIN = MIN( NGPMIN, NGNMIN )
+* ( A guess; no known machine )
+ IWARN = .TRUE.
+ END IF
+*
+ ELSE
+ LEMIN = MIN( NGPMIN, NGNMIN, GPMIN, GNMIN )
+* ( A guess; no known machine )
+ IWARN = .TRUE.
+ END IF
+***
+* Comment out this if block if EMIN is ok
+ IF( IWARN ) THEN
+ FIRST = .TRUE.
+ WRITE( 6, FMT = 9999 )LEMIN
+ END IF
+***
+*
+* Assume IEEE arithmetic if we found denormalised numbers above,
+* or if arithmetic seems to round in the IEEE style, determined
+* in routine DLAMC1. A true IEEE machine should have both things
+* true; however, faulty machines may have one or the other.
+*
+ IEEE = IEEE .OR. LIEEE1
+*
+* Compute RMIN by successive division by BETA. We could compute
+* RMIN as BASE**( EMIN - 1 ), but some machines underflow during
+* this computation.
+*
+ LRMIN = 1
+ DO 30 I = 1, 1 - LEMIN
+ LRMIN = DLAMC3( LRMIN*RBASE, ZERO )
+ 30 CONTINUE
+*
+* Finally, call DLAMC5 to compute EMAX and RMAX.
+*
+ CALL DLAMC5( LBETA, LT, LEMIN, IEEE, LEMAX, LRMAX )
+ END IF
+*
+ BETA = LBETA
+ T = LT
+ RND = LRND
+ EPS = LEPS
+ EMIN = LEMIN
+ RMIN = LRMIN
+ EMAX = LEMAX
+ RMAX = LRMAX
+*
+ RETURN
+*
+ 9999 FORMAT( / / ' WARNING. The value EMIN may be incorrect:-',
+ $ ' EMIN = ', I8, /
+ $ ' If, after inspection, the value EMIN looks',
+ $ ' acceptable please comment out ',
+ $ / ' the IF block as marked within the code of routine',
+ $ ' DLAMC2,', / ' otherwise supply EMIN explicitly.', / )
+*
+* End of DLAMC2
+*
+ END
+*
+************************************************************************
+*
+ DOUBLE PRECISION FUNCTION DLAMC3( A, B )
+*
+* -- LAPACK auxiliary routine (version 2.0) --
+* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
+* Courant Institute, Argonne National Lab, and Rice University
+* October 31, 1992
+*
+* .. Scalar Arguments ..
+ DOUBLE PRECISION A, B
+* ..
+*
+* Purpose
+* =======
+*
+* DLAMC3 is intended to force A and B to be stored prior to doing
+* the addition of A and B , for use in situations where optimizers
+* might hold one of these in a register.
+*
+* Arguments
+* =========
+*
+* A, B (input) DOUBLE PRECISION
+* The values A and B.
+*
+* =====================================================================
+*
+* .. Executable Statements ..
+*
+ DLAMC3 = A + B
+*
+ RETURN
+*
+* End of DLAMC3
+*
+ END
+*
+************************************************************************
+*
+ SUBROUTINE DLAMC4( EMIN, START, BASE )
+*
+* -- LAPACK auxiliary routine (version 2.0) --
+* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
+* Courant Institute, Argonne National Lab, and Rice University
+* October 31, 1992
+*
+* .. Scalar Arguments ..
+ INTEGER BASE, EMIN
+ DOUBLE PRECISION START
+* ..
+*
+* Purpose
+* =======
+*
+* DLAMC4 is a service routine for DLAMC2.
+*
+* Arguments
+* =========
+*
+* EMIN (output) EMIN
+* The minimum exponent before (gradual) underflow, computed by
+* setting A = START and dividing by BASE until the previous A
+* can not be recovered.
+*
+* START (input) DOUBLE PRECISION
+* The starting point for determining EMIN.
+*
+* BASE (input) INTEGER
+* The base of the machine.
+*
+* =====================================================================
+*
+* .. Local Scalars ..
+ INTEGER I
+ DOUBLE PRECISION A, B1, B2, C1, C2, D1, D2, ONE, RBASE, ZERO
+* ..
+* .. External Functions ..
+ DOUBLE PRECISION DLAMC3
+ EXTERNAL DLAMC3
+* ..
+* .. Executable Statements ..
+*
+ A = START
+ ONE = 1
+ RBASE = ONE / BASE
+ ZERO = 0
+ EMIN = 1
+ B1 = DLAMC3( A*RBASE, ZERO )
+ C1 = A
+ C2 = A
+ D1 = A
+ D2 = A
+*+ WHILE( ( C1.EQ.A ).AND.( C2.EQ.A ).AND.
+* $ ( D1.EQ.A ).AND.( D2.EQ.A ) )LOOP
+ 10 CONTINUE
+ IF( ( C1.EQ.A ) .AND. ( C2.EQ.A ) .AND. ( D1.EQ.A ) .AND.
+ $ ( D2.EQ.A ) ) THEN
+ EMIN = EMIN - 1
+ A = B1
+ B1 = DLAMC3( A / BASE, ZERO )
+ C1 = DLAMC3( B1*BASE, ZERO )
+ D1 = ZERO
+ DO 20 I = 1, BASE
+ D1 = D1 + B1
+ 20 CONTINUE
+ B2 = DLAMC3( A*RBASE, ZERO )
+ C2 = DLAMC3( B2 / RBASE, ZERO )
+ D2 = ZERO
+ DO 30 I = 1, BASE
+ D2 = D2 + B2
+ 30 CONTINUE
+ GO TO 10
+ END IF
+*+ END WHILE
+*
+ RETURN
+*
+* End of DLAMC4
+*
+ END
+*
+************************************************************************
+*
+ SUBROUTINE DLAMC5( BETA, P, EMIN, IEEE, EMAX, RMAX )
+*
+* -- LAPACK auxiliary routine (version 2.0) --
+* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
+* Courant Institute, Argonne National Lab, and Rice University
+* October 31, 1992
+*
+* .. Scalar Arguments ..
+ LOGICAL IEEE
+ INTEGER BETA, EMAX, EMIN, P
+ DOUBLE PRECISION RMAX
+* ..
+*
+* Purpose
+* =======
+*
+* DLAMC5 attempts to compute RMAX, the largest machine floating-point
+* number, without overflow. It assumes that EMAX + abs(EMIN) sum
+* approximately to a power of 2. It will fail on machines where this
+* assumption does not hold, for example, the Cyber 205 (EMIN = -28625,
+* EMAX = 28718). It will also fail if the value supplied for EMIN is
+* too large (i.e. too close to zero), probably with overflow.
+*
+* Arguments
+* =========
+*
+* BETA (input) INTEGER
+* The base of floating-point arithmetic.
+*
+* P (input) INTEGER
+* The number of base BETA digits in the mantissa of a
+* floating-point value.
+*
+* EMIN (input) INTEGER
+* The minimum exponent before (gradual) underflow.
+*
+* IEEE (input) LOGICAL
+* A logical flag specifying whether or not the arithmetic
+* system is thought to comply with the IEEE standard.
+*
+* EMAX (output) INTEGER
+* The largest exponent before overflow
+*
+* RMAX (output) DOUBLE PRECISION
+* The largest machine floating-point number.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, ONE
+ PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 )
+* ..
+* .. Local Scalars ..
+ INTEGER EXBITS, EXPSUM, I, LEXP, NBITS, TRY, UEXP
+ DOUBLE PRECISION OLDY, RECBAS, Y, Z
+* ..
+* .. External Functions ..
+ DOUBLE PRECISION DLAMC3
+ EXTERNAL DLAMC3
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MOD
+* ..
+* .. Executable Statements ..
+*
+* First compute LEXP and UEXP, two powers of 2 that bound
+* abs(EMIN). We then assume that EMAX + abs(EMIN) will sum
+* approximately to the bound that is closest to abs(EMIN).
+* (EMAX is the exponent of the required number RMAX).
+*
+ LEXP = 1
+ EXBITS = 1
+ 10 CONTINUE
+ TRY = LEXP*2
+ IF( TRY.LE.( -EMIN ) ) THEN
+ LEXP = TRY
+ EXBITS = EXBITS + 1
+ GO TO 10
+ END IF
+ IF( LEXP.EQ.-EMIN ) THEN
+ UEXP = LEXP
+ ELSE
+ UEXP = TRY
+ EXBITS = EXBITS + 1
+ END IF
+*
+* Now -LEXP is less than or equal to EMIN, and -UEXP is greater
+* than or equal to EMIN. EXBITS is the number of bits needed to
+* store the exponent.
+*
+ IF( ( UEXP+EMIN ).GT.( -LEXP-EMIN ) ) THEN
+ EXPSUM = 2*LEXP
+ ELSE
+ EXPSUM = 2*UEXP
+ END IF
+*
+* EXPSUM is the exponent range, approximately equal to
+* EMAX - EMIN + 1 .
+*
+ EMAX = EXPSUM + EMIN - 1
+ NBITS = 1 + EXBITS + P
+*
+* NBITS is the total number of bits needed to store a
+* floating-point number.
+*
+ IF( ( MOD( NBITS, 2 ).EQ.1 ) .AND. ( BETA.EQ.2 ) ) THEN
+*
+* Either there are an odd number of bits used to store a
+* floating-point number, which is unlikely, or some bits are
+* not used in the representation of numbers, which is possible,
+* (e.g. Cray machines) or the mantissa has an implicit bit,
+* (e.g. IEEE machines, Dec Vax machines), which is perhaps the
+* most likely. We have to assume the last alternative.
+* If this is true, then we need to reduce EMAX by one because
+* there must be some way of representing zero in an implicit-bit
+* system. On machines like Cray, we are reducing EMAX by one
+* unnecessarily.
+*
+ EMAX = EMAX - 1
+ END IF
+*
+ IF( IEEE ) THEN
+*
+* Assume we are on an IEEE machine which reserves one exponent
+* for infinity and NaN.
+*
+ EMAX = EMAX - 1
+ END IF
+*
+* Now create RMAX, the largest machine number, which should
+* be equal to (1.0 - BETA**(-P)) * BETA**EMAX .
+*
+* First compute 1.0 - BETA**(-P), being careful that the
+* result is less than 1.0 .
+*
+ RECBAS = ONE / BETA
+ Z = BETA - ONE
+ Y = ZERO
+ DO 20 I = 1, P
+ Z = Z*RECBAS
+ IF( Y.LT.ONE )
+ $ OLDY = Y
+ Y = DLAMC3( Y, Z )
+ 20 CONTINUE
+ IF( Y.GE.ONE )
+ $ Y = OLDY
+*
+* Now multiply by BETA**EMAX to get RMAX.
+*
+ DO 30 I = 1, EMAX
+ Y = DLAMC3( Y*BETA, ZERO )
+ 30 CONTINUE
+*
+ RMAX = Y
+ RETURN
+*
+* End of DLAMC5
+*
+ END
+ REAL FUNCTION SLAMCH( CMACH )
+*
+* -- LAPACK auxiliary routine (version 2.0) --
+* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
+* Courant Institute, Argonne National Lab, and Rice University
+* October 31, 1992
+*
+* .. Scalar Arguments ..
+ CHARACTER CMACH
+* ..
+*
+* Purpose
+* =======
+*
+* SLAMCH determines single precision machine parameters.
+*
+* Arguments
+* =========
+*
+* CMACH (input) CHARACTER*1
+* Specifies the value to be returned by SLAMCH:
+* = 'E' or 'e', SLAMCH := eps
+* = 'S' or 's , SLAMCH := sfmin
+* = 'B' or 'b', SLAMCH := base
+* = 'P' or 'p', SLAMCH := eps*base
+* = 'N' or 'n', SLAMCH := t
+* = 'R' or 'r', SLAMCH := rnd
+* = 'M' or 'm', SLAMCH := emin
+* = 'U' or 'u', SLAMCH := rmin
+* = 'L' or 'l', SLAMCH := emax
+* = 'O' or 'o', SLAMCH := rmax
+*
+* where
+*
+* eps = relative machine precision
+* sfmin = safe minimum, such that 1/sfmin does not overflow
+* base = base of the machine
+* prec = eps*base
+* t = number of (base) digits in the mantissa
+* rnd = 1.0 when rounding occurs in addition, 0.0 otherwise
+* emin = minimum exponent before (gradual) underflow
+* rmin = underflow threshold - base**(emin-1)
+* emax = largest exponent before overflow
+* rmax = overflow threshold - (base**emax)*(1-eps)
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ONE, ZERO
+ PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL FIRST, LRND
+ INTEGER BETA, IMAX, IMIN, IT
+ REAL BASE, EMAX, EMIN, EPS, PREC, RMACH, RMAX, RMIN,
+ $ RND, SFMIN, SMALL, T
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL SLAMC2
+* ..
+* .. Save statement ..
+ SAVE FIRST, EPS, SFMIN, BASE, T, RND, EMIN, RMIN,
+ $ EMAX, RMAX, PREC
+* ..
+* .. Data statements ..
+ DATA FIRST / .TRUE. /
+* ..
+* .. Executable Statements ..
+*
+ IF( FIRST ) THEN
+ FIRST = .FALSE.
+ CALL SLAMC2( BETA, IT, LRND, EPS, IMIN, RMIN, IMAX, RMAX )
+ BASE = BETA
+ T = IT
+ IF( LRND ) THEN
+ RND = ONE
+ EPS = ( BASE**( 1-IT ) ) / 2
+ ELSE
+ RND = ZERO
+ EPS = BASE**( 1-IT )
+ END IF
+ PREC = EPS*BASE
+ EMIN = IMIN
+ EMAX = IMAX
+ SFMIN = RMIN
+ SMALL = ONE / RMAX
+ IF( SMALL.GE.SFMIN ) THEN
+*
+* Use SMALL plus a bit, to avoid the possibility of rounding
+* causing overflow when computing 1/sfmin.
+*
+ SFMIN = SMALL*( ONE+EPS )
+ END IF
+ END IF
+*
+ IF( LSAME( CMACH, 'E' ) ) THEN
+ RMACH = EPS
+ ELSE IF( LSAME( CMACH, 'S' ) ) THEN
+ RMACH = SFMIN
+ ELSE IF( LSAME( CMACH, 'B' ) ) THEN
+ RMACH = BASE
+ ELSE IF( LSAME( CMACH, 'P' ) ) THEN
+ RMACH = PREC
+ ELSE IF( LSAME( CMACH, 'N' ) ) THEN
+ RMACH = T
+ ELSE IF( LSAME( CMACH, 'R' ) ) THEN
+ RMACH = RND
+ ELSE IF( LSAME( CMACH, 'M' ) ) THEN
+ RMACH = EMIN
+ ELSE IF( LSAME( CMACH, 'U' ) ) THEN
+ RMACH = RMIN
+ ELSE IF( LSAME( CMACH, 'L' ) ) THEN
+ RMACH = EMAX
+ ELSE IF( LSAME( CMACH, 'O' ) ) THEN
+ RMACH = RMAX
+ END IF
+*
+ SLAMCH = RMACH
+ RETURN
+*
+* End of SLAMCH
+*
+ END
+*
+************************************************************************
+*
+ SUBROUTINE SLAMC1( BETA, T, RND, IEEE1 )
+*
+* -- LAPACK auxiliary routine (version 2.0) --
+* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
+* Courant Institute, Argonne National Lab, and Rice University
+* October 31, 1992
+*
+* .. Scalar Arguments ..
+ LOGICAL IEEE1, RND
+ INTEGER BETA, T
+* ..
+*
+* Purpose
+* =======
+*
+* SLAMC1 determines the machine parameters given by BETA, T, RND, and
+* IEEE1.
+*
+* Arguments
+* =========
+*
+* BETA (output) INTEGER
+* The base of the machine.
+*
+* T (output) INTEGER
+* The number of ( BETA ) digits in the mantissa.
+*
+* RND (output) LOGICAL
+* Specifies whether proper rounding ( RND = .TRUE. ) or
+* chopping ( RND = .FALSE. ) occurs in addition. This may not
+* be a reliable guide to the way in which the machine performs
+* its arithmetic.
+*
+* IEEE1 (output) LOGICAL
+* Specifies whether rounding appears to be done in the IEEE
+* 'round to nearest' style.
+*
+* Further Details
+* ===============
+*
+* The routine is based on the routine ENVRON by Malcolm and
+* incorporates suggestions by Gentleman and Marovich. See
+*
+* Malcolm M. A. (1972) Algorithms to reveal properties of
+* floating-point arithmetic. Comms. of the ACM, 15, 949-951.
+*
+* Gentleman W. M. and Marovich S. B. (1974) More on algorithms
+* that reveal properties of floating point arithmetic units.
+* Comms. of the ACM, 17, 276-277.
+*
+* =====================================================================
+*
+* .. Local Scalars ..
+ LOGICAL FIRST, LIEEE1, LRND
+ INTEGER LBETA, LT
+ REAL A, B, C, F, ONE, QTR, SAVEC, T1, T2
+* ..
+* .. External Functions ..
+ REAL SLAMC3
+ EXTERNAL SLAMC3
+* ..
+* .. Save statement ..
+ SAVE FIRST, LIEEE1, LBETA, LRND, LT
+* ..
+* .. Data statements ..
+ DATA FIRST / .TRUE. /
+* ..
+* .. Executable Statements ..
+*
+ IF( FIRST ) THEN
+ FIRST = .FALSE.
+ ONE = 1
+*
+* LBETA, LIEEE1, LT and LRND are the local values of BETA,
+* IEEE1, T and RND.
+*
+* Throughout this routine we use the function SLAMC3 to ensure
+* that relevant values are stored and not held in registers, or
+* are not affected by optimizers.
+*
+* Compute a = 2.0**m with the smallest positive integer m such
+* that
+*
+* fl( a + 1.0 ) = a.
+*
+ A = 1
+ C = 1
+*
+*+ WHILE( C.EQ.ONE )LOOP
+ 10 CONTINUE
+ IF( C.EQ.ONE ) THEN
+ A = 2*A
+ C = SLAMC3( A, ONE )
+ C = SLAMC3( C, -A )
+ GO TO 10
+ END IF
+*+ END WHILE
+*
+* Now compute b = 2.0**m with the smallest positive integer m
+* such that
+*
+* fl( a + b ) .gt. a.
+*
+ B = 1
+ C = SLAMC3( A, B )
+*
+*+ WHILE( C.EQ.A )LOOP
+ 20 CONTINUE
+ IF( C.EQ.A ) THEN
+ B = 2*B
+ C = SLAMC3( A, B )
+ GO TO 20
+ END IF
+*+ END WHILE
+*
+* Now compute the base. a and c are neighbouring floating point
+* numbers in the interval ( beta**t, beta**( t + 1 ) ) and so
+* their difference is beta. Adding 0.25 to c is to ensure that it
+* is truncated to beta and not ( beta - 1 ).
+*
+ QTR = ONE / 4
+ SAVEC = C
+ C = SLAMC3( C, -A )
+ LBETA = C + QTR
+*
+* Now determine whether rounding or chopping occurs, by adding a
+* bit less than beta/2 and a bit more than beta/2 to a.
+*
+ B = LBETA
+ F = SLAMC3( B / 2, -B / 100 )
+ C = SLAMC3( F, A )
+ IF( C.EQ.A ) THEN
+ LRND = .TRUE.
+ ELSE
+ LRND = .FALSE.
+ END IF
+ F = SLAMC3( B / 2, B / 100 )
+ C = SLAMC3( F, A )
+ IF( ( LRND ) .AND. ( C.EQ.A ) )
+ $ LRND = .FALSE.
+*
+* Try and decide whether rounding is done in the IEEE 'round to
+* nearest' style. B/2 is half a unit in the last place of the two
+* numbers A and SAVEC. Furthermore, A is even, i.e. has last bit
+* zero, and SAVEC is odd. Thus adding B/2 to A should not change
+* A, but adding B/2 to SAVEC should change SAVEC.
+*
+ T1 = SLAMC3( B / 2, A )
+ T2 = SLAMC3( B / 2, SAVEC )
+ LIEEE1 = ( T1.EQ.A ) .AND. ( T2.GT.SAVEC ) .AND. LRND
+*
+* Now find the mantissa, t. It should be the integer part of
+* log to the base beta of a, however it is safer to determine t
+* by powering. So we find t as the smallest positive integer for
+* which
+*
+* fl( beta**t + 1.0 ) = 1.0.
+*
+ LT = 0
+ A = 1
+ C = 1
+*
+*+ WHILE( C.EQ.ONE )LOOP
+ 30 CONTINUE
+ IF( C.EQ.ONE ) THEN
+ LT = LT + 1
+ A = A*LBETA
+ C = SLAMC3( A, ONE )
+ C = SLAMC3( C, -A )
+ GO TO 30
+ END IF
+*+ END WHILE
+*
+ END IF
+*
+ BETA = LBETA
+ T = LT
+ RND = LRND
+ IEEE1 = LIEEE1
+ RETURN
+*
+* End of SLAMC1
+*
+ END
+*
+************************************************************************
+*
+ SUBROUTINE SLAMC2( BETA, T, RND, EPS, EMIN, RMIN, EMAX, RMAX )
+*
+* -- LAPACK auxiliary routine (version 2.0) --
+* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
+* Courant Institute, Argonne National Lab, and Rice University
+* October 31, 1992
+*
+* .. Scalar Arguments ..
+ LOGICAL RND
+ INTEGER BETA, EMAX, EMIN, T
+ REAL EPS, RMAX, RMIN
+* ..
+*
+* Purpose
+* =======
+*
+* SLAMC2 determines the machine parameters specified in its argument
+* list.
+*
+* Arguments
+* =========
+*
+* BETA (output) INTEGER
+* The base of the machine.
+*
+* T (output) INTEGER
+* The number of ( BETA ) digits in the mantissa.
+*
+* RND (output) LOGICAL
+* Specifies whether proper rounding ( RND = .TRUE. ) or
+* chopping ( RND = .FALSE. ) occurs in addition. This may not
+* be a reliable guide to the way in which the machine performs
+* its arithmetic.
+*
+* EPS (output) REAL
+* The smallest positive number such that
+*
+* fl( 1.0 - EPS ) .LT. 1.0,
+*
+* where fl denotes the computed value.
+*
+* EMIN (output) INTEGER
+* The minimum exponent before (gradual) underflow occurs.
+*
+* RMIN (output) REAL
+* The smallest normalized number for the machine, given by
+* BASE**( EMIN - 1 ), where BASE is the floating point value
+* of BETA.
+*
+* EMAX (output) INTEGER
+* The maximum exponent before overflow occurs.
+*
+* RMAX (output) REAL
+* The largest positive number for the machine, given by
+* BASE**EMAX * ( 1 - EPS ), where BASE is the floating point
+* value of BETA.
+*
+* Further Details
+* ===============
+*
+* The computation of EPS is based on a routine PARANOIA by
+* W. Kahan of the University of California at Berkeley.
+*
+* =====================================================================
+*
+* .. Local Scalars ..
+ LOGICAL FIRST, IEEE, IWARN, LIEEE1, LRND
+ INTEGER GNMIN, GPMIN, I, LBETA, LEMAX, LEMIN, LT,
+ $ NGNMIN, NGPMIN
+ REAL A, B, C, HALF, LEPS, LRMAX, LRMIN, ONE, RBASE,
+ $ SIXTH, SMALL, THIRD, TWO, ZERO
+* ..
+* .. External Functions ..
+ REAL SLAMC3
+ EXTERNAL SLAMC3
+* ..
+* .. External Subroutines ..
+ EXTERNAL SLAMC1, SLAMC4, SLAMC5
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX, MIN
+* ..
+* .. Save statement ..
+ SAVE FIRST, IWARN, LBETA, LEMAX, LEMIN, LEPS, LRMAX,
+ $ LRMIN, LT
+* ..
+* .. Data statements ..
+ DATA FIRST / .TRUE. / , IWARN / .FALSE. /
+* ..
+* .. Executable Statements ..
+*
+ IF( FIRST ) THEN
+ FIRST = .FALSE.
+ ZERO = 0
+ ONE = 1
+ TWO = 2
+*
+* LBETA, LT, LRND, LEPS, LEMIN and LRMIN are the local values of
+* BETA, T, RND, EPS, EMIN and RMIN.
+*
+* Throughout this routine we use the function SLAMC3 to ensure
+* that relevant values are stored and not held in registers, or
+* are not affected by optimizers.
+*
+* SLAMC1 returns the parameters LBETA, LT, LRND and LIEEE1.
+*
+ CALL SLAMC1( LBETA, LT, LRND, LIEEE1 )
+*
+* Start to find EPS.
+*
+ B = LBETA
+ A = B**( -LT )
+ LEPS = A
+*
+* Try some tricks to see whether or not this is the correct EPS.
+*
+ B = TWO / 3
+ HALF = ONE / 2
+ SIXTH = SLAMC3( B, -HALF )
+ THIRD = SLAMC3( SIXTH, SIXTH )
+ B = SLAMC3( THIRD, -HALF )
+ B = SLAMC3( B, SIXTH )
+ B = ABS( B )
+ IF( B.LT.LEPS )
+ $ B = LEPS
+*
+ LEPS = 1
+*
+*+ WHILE( ( LEPS.GT.B ).AND.( B.GT.ZERO ) )LOOP
+ 10 CONTINUE
+ IF( ( LEPS.GT.B ) .AND. ( B.GT.ZERO ) ) THEN
+ LEPS = B
+ C = SLAMC3( HALF*LEPS, ( TWO**5 )*( LEPS**2 ) )
+ C = SLAMC3( HALF, -C )
+ B = SLAMC3( HALF, C )
+ C = SLAMC3( HALF, -B )
+ B = SLAMC3( HALF, C )
+ GO TO 10
+ END IF
+*+ END WHILE
+*
+ IF( A.LT.LEPS )
+ $ LEPS = A
+*
+* Computation of EPS complete.
+*
+* Now find EMIN. Let A = + or - 1, and + or - (1 + BASE**(-3)).
+* Keep dividing A by BETA until (gradual) underflow occurs. This
+* is detected when we cannot recover the previous A.
+*
+ RBASE = ONE / LBETA
+ SMALL = ONE
+ DO 20 I = 1, 3
+ SMALL = SLAMC3( SMALL*RBASE, ZERO )
+ 20 CONTINUE
+ A = SLAMC3( ONE, SMALL )
+ CALL SLAMC4( NGPMIN, ONE, LBETA )
+ CALL SLAMC4( NGNMIN, -ONE, LBETA )
+ CALL SLAMC4( GPMIN, A, LBETA )
+ CALL SLAMC4( GNMIN, -A, LBETA )
+ IEEE = .FALSE.
+*
+ IF( ( NGPMIN.EQ.NGNMIN ) .AND. ( GPMIN.EQ.GNMIN ) ) THEN
+ IF( NGPMIN.EQ.GPMIN ) THEN
+ LEMIN = NGPMIN
+* ( Non twos-complement machines, no gradual underflow;
+* e.g., VAX )
+ ELSE IF( ( GPMIN-NGPMIN ).EQ.3 ) THEN
+ LEMIN = NGPMIN - 1 + LT
+ IEEE = .TRUE.
+* ( Non twos-complement machines, with gradual underflow;
+* e.g., IEEE standard followers )
+ ELSE
+ LEMIN = MIN( NGPMIN, GPMIN )
+* ( A guess; no known machine )
+ IWARN = .TRUE.
+ END IF
+*
+ ELSE IF( ( NGPMIN.EQ.GPMIN ) .AND. ( NGNMIN.EQ.GNMIN ) ) THEN
+ IF( ABS( NGPMIN-NGNMIN ).EQ.1 ) THEN
+ LEMIN = MAX( NGPMIN, NGNMIN )
+* ( Twos-complement machines, no gradual underflow;
+* e.g., CYBER 205 )
+ ELSE
+ LEMIN = MIN( NGPMIN, NGNMIN )
+* ( A guess; no known machine )
+ IWARN = .TRUE.
+ END IF
+*
+ ELSE IF( ( ABS( NGPMIN-NGNMIN ).EQ.1 ) .AND.
+ $ ( GPMIN.EQ.GNMIN ) ) THEN
+ IF( ( GPMIN-MIN( NGPMIN, NGNMIN ) ).EQ.3 ) THEN
+ LEMIN = MAX( NGPMIN, NGNMIN ) - 1 + LT
+* ( Twos-complement machines with gradual underflow;
+* no known machine )
+ ELSE
+ LEMIN = MIN( NGPMIN, NGNMIN )
+* ( A guess; no known machine )
+ IWARN = .TRUE.
+ END IF
+*
+ ELSE
+ LEMIN = MIN( NGPMIN, NGNMIN, GPMIN, GNMIN )
+* ( A guess; no known machine )
+ IWARN = .TRUE.
+ END IF
+***
+* Comment out this if block if EMIN is ok
+ IF( IWARN ) THEN
+ FIRST = .TRUE.
+ WRITE( 6, FMT = 9999 )LEMIN
+ END IF
+***
+*
+* Assume IEEE arithmetic if we found denormalised numbers above,
+* or if arithmetic seems to round in the IEEE style, determined
+* in routine SLAMC1. A true IEEE machine should have both things
+* true; however, faulty machines may have one or the other.
+*
+ IEEE = IEEE .OR. LIEEE1
+*
+* Compute RMIN by successive division by BETA. We could compute
+* RMIN as BASE**( EMIN - 1 ), but some machines underflow during
+* this computation.
+*
+ LRMIN = 1
+ DO 30 I = 1, 1 - LEMIN
+ LRMIN = SLAMC3( LRMIN*RBASE, ZERO )
+ 30 CONTINUE
+*
+* Finally, call SLAMC5 to compute EMAX and RMAX.
+*
+ CALL SLAMC5( LBETA, LT, LEMIN, IEEE, LEMAX, LRMAX )
+ END IF
+*
+ BETA = LBETA
+ T = LT
+ RND = LRND
+ EPS = LEPS
+ EMIN = LEMIN
+ RMIN = LRMIN
+ EMAX = LEMAX
+ RMAX = LRMAX
+*
+ RETURN
+*
+ 9999 FORMAT( / / ' WARNING. The value EMIN may be incorrect:-',
+ $ ' EMIN = ', I8, /
+ $ ' If, after inspection, the value EMIN looks',
+ $ ' acceptable please comment out ',
+ $ / ' the IF block as marked within the code of routine',
+ $ ' SLAMC2,', / ' otherwise supply EMIN explicitly.', / )
+*
+* End of SLAMC2
+*
+ END
+*
+************************************************************************
+*
+ REAL FUNCTION SLAMC3( A, B )
+*
+* -- LAPACK auxiliary routine (version 2.0) --
+* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
+* Courant Institute, Argonne National Lab, and Rice University
+* October 31, 1992
+*
+* .. Scalar Arguments ..
+ REAL A, B
+* ..
+*
+* Purpose
+* =======
+*
+* SLAMC3 is intended to force A and B to be stored prior to doing
+* the addition of A and B , for use in situations where optimizers
+* might hold one of these in a register.
+*
+* Arguments
+* =========
+*
+* A, B (input) REAL
+* The values A and B.
+*
+* =====================================================================
+*
+* .. Executable Statements ..
+*
+ SLAMC3 = A + B
+*
+ RETURN
+*
+* End of SLAMC3
+*
+ END
+*
+************************************************************************
+*
+ SUBROUTINE SLAMC4( EMIN, START, BASE )
+*
+* -- LAPACK auxiliary routine (version 2.0) --
+* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
+* Courant Institute, Argonne National Lab, and Rice University
+* October 31, 1992
+*
+* .. Scalar Arguments ..
+ INTEGER BASE, EMIN
+ REAL START
+* ..
+*
+* Purpose
+* =======
+*
+* SLAMC4 is a service routine for SLAMC2.
+*
+* Arguments
+* =========
+*
+* EMIN (output) EMIN
+* The minimum exponent before (gradual) underflow, computed by
+* setting A = START and dividing by BASE until the previous A
+* can not be recovered.
+*
+* START (input) REAL
+* The starting point for determining EMIN.
+*
+* BASE (input) INTEGER
+* The base of the machine.
+*
+* =====================================================================
+*
+* .. Local Scalars ..
+ INTEGER I
+ REAL A, B1, B2, C1, C2, D1, D2, ONE, RBASE, ZERO
+* ..
+* .. External Functions ..
+ REAL SLAMC3
+ EXTERNAL SLAMC3
+* ..
+* .. Executable Statements ..
+*
+ A = START
+ ONE = 1
+ RBASE = ONE / BASE
+ ZERO = 0
+ EMIN = 1
+ B1 = SLAMC3( A*RBASE, ZERO )
+ C1 = A
+ C2 = A
+ D1 = A
+ D2 = A
+*+ WHILE( ( C1.EQ.A ).AND.( C2.EQ.A ).AND.
+* $ ( D1.EQ.A ).AND.( D2.EQ.A ) )LOOP
+ 10 CONTINUE
+ IF( ( C1.EQ.A ) .AND. ( C2.EQ.A ) .AND. ( D1.EQ.A ) .AND.
+ $ ( D2.EQ.A ) ) THEN
+ EMIN = EMIN - 1
+ A = B1
+ B1 = SLAMC3( A / BASE, ZERO )
+ C1 = SLAMC3( B1*BASE, ZERO )
+ D1 = ZERO
+ DO 20 I = 1, BASE
+ D1 = D1 + B1
+ 20 CONTINUE
+ B2 = SLAMC3( A*RBASE, ZERO )
+ C2 = SLAMC3( B2 / RBASE, ZERO )
+ D2 = ZERO
+ DO 30 I = 1, BASE
+ D2 = D2 + B2
+ 30 CONTINUE
+ GO TO 10
+ END IF
+*+ END WHILE
+*
+ RETURN
+*
+* End of SLAMC4
+*
+ END
+*
+************************************************************************
+*
+ SUBROUTINE SLAMC5( BETA, P, EMIN, IEEE, EMAX, RMAX )
+*
+* -- LAPACK auxiliary routine (version 2.0) --
+* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
+* Courant Institute, Argonne National Lab, and Rice University
+* October 31, 1992
+*
+* .. Scalar Arguments ..
+ LOGICAL IEEE
+ INTEGER BETA, EMAX, EMIN, P
+ REAL RMAX
+* ..
+*
+* Purpose
+* =======
+*
+* SLAMC5 attempts to compute RMAX, the largest machine floating-point
+* number, without overflow. It assumes that EMAX + abs(EMIN) sum
+* approximately to a power of 2. It will fail on machines where this
+* assumption does not hold, for example, the Cyber 205 (EMIN = -28625,
+* EMAX = 28718). It will also fail if the value supplied for EMIN is
+* too large (i.e. too close to zero), probably with overflow.
+*
+* Arguments
+* =========
+*
+* BETA (input) INTEGER
+* The base of floating-point arithmetic.
+*
+* P (input) INTEGER
+* The number of base BETA digits in the mantissa of a
+* floating-point value.
+*
+* EMIN (input) INTEGER
+* The minimum exponent before (gradual) underflow.
+*
+* IEEE (input) LOGICAL
+* A logical flag specifying whether or not the arithmetic
+* system is thought to comply with the IEEE standard.
+*
+* EMAX (output) INTEGER
+* The largest exponent before overflow
+*
+* RMAX (output) REAL
+* The largest machine floating-point number.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ZERO, ONE
+ PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0 )
+* ..
+* .. Local Scalars ..
+ INTEGER EXBITS, EXPSUM, I, LEXP, NBITS, TRY, UEXP
+ REAL OLDY, RECBAS, Y, Z
+* ..
+* .. External Functions ..
+ REAL SLAMC3
+ EXTERNAL SLAMC3
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MOD
+* ..
+* .. Executable Statements ..
+*
+* First compute LEXP and UEXP, two powers of 2 that bound
+* abs(EMIN). We then assume that EMAX + abs(EMIN) will sum
+* approximately to the bound that is closest to abs(EMIN).
+* (EMAX is the exponent of the required number RMAX).
+*
+ LEXP = 1
+ EXBITS = 1
+ 10 CONTINUE
+ TRY = LEXP*2
+ IF( TRY.LE.( -EMIN ) ) THEN
+ LEXP = TRY
+ EXBITS = EXBITS + 1
+ GO TO 10
+ END IF
+ IF( LEXP.EQ.-EMIN ) THEN
+ UEXP = LEXP
+ ELSE
+ UEXP = TRY
+ EXBITS = EXBITS + 1
+ END IF
+*
+* Now -LEXP is less than or equal to EMIN, and -UEXP is greater
+* than or equal to EMIN. EXBITS is the number of bits needed to
+* store the exponent.
+*
+ IF( ( UEXP+EMIN ).GT.( -LEXP-EMIN ) ) THEN
+ EXPSUM = 2*LEXP
+ ELSE
+ EXPSUM = 2*UEXP
+ END IF
+*
+* EXPSUM is the exponent range, approximately equal to
+* EMAX - EMIN + 1 .
+*
+ EMAX = EXPSUM + EMIN - 1
+ NBITS = 1 + EXBITS + P
+*
+* NBITS is the total number of bits needed to store a
+* floating-point number.
+*
+ IF( ( MOD( NBITS, 2 ).EQ.1 ) .AND. ( BETA.EQ.2 ) ) THEN
+*
+* Either there are an odd number of bits used to store a
+* floating-point number, which is unlikely, or some bits are
+* not used in the representation of numbers, which is possible,
+* (e.g. Cray machines) or the mantissa has an implicit bit,
+* (e.g. IEEE machines, Dec Vax machines), which is perhaps the
+* most likely. We have to assume the last alternative.
+* If this is true, then we need to reduce EMAX by one because
+* there must be some way of representing zero in an implicit-bit
+* system. On machines like Cray, we are reducing EMAX by one
+* unnecessarily.
+*
+ EMAX = EMAX - 1
+ END IF
+*
+ IF( IEEE ) THEN
+*
+* Assume we are on an IEEE machine which reserves one exponent
+* for infinity and NaN.
+*
+ EMAX = EMAX - 1
+ END IF
+*
+* Now create RMAX, the largest machine number, which should
+* be equal to (1.0 - BETA**(-P)) * BETA**EMAX .
+*
+* First compute 1.0 - BETA**(-P), being careful that the
+* result is less than 1.0 .
+*
+ RECBAS = ONE / BETA
+ Z = BETA - ONE
+ Y = ZERO
+ DO 20 I = 1, P
+ Z = Z*RECBAS
+ IF( Y.LT.ONE )
+ $ OLDY = Y
+ Y = SLAMC3( Y, Z )
+ 20 CONTINUE
+ IF( Y.GE.ONE )
+ $ Y = OLDY
+*
+* Now multiply by BETA**EMAX to get RMAX.
+*
+ DO 30 I = 1, EMAX
+ Y = SLAMC3( Y*BETA, ZERO )
+ 30 CONTINUE
+*
+ RMAX = Y
+ RETURN
+*
+* End of SLAMC5
+*
+ END
+ LOGICAL FUNCTION LSAME( CA, CB )
+*
+* -- LAPACK auxiliary routine (version 2.0) --
+* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
+* Courant Institute, Argonne National Lab, and Rice University
+* June 30, 1994
+*
+* .. Scalar Arguments ..
+ CHARACTER CA, CB
+* ..
+*
+* Purpose
+* =======
+*
+* LSAME returns .TRUE. if CA is the same letter as CB regardless of
+* case.
+*
+* Arguments
+* =========
+*
+* CA (input) CHARACTER*1
+* CB (input) CHARACTER*1
+* CA and CB specify the single characters to be compared.
+*
+* =====================================================================
+*
+* .. Intrinsic Functions ..
+ INTRINSIC ICHAR
+* ..
+* .. Local Scalars ..
+ INTEGER INTA, INTB, ZCODE
+* ..
+* .. Executable Statements ..
+*
+* Test if the characters are equal
+*
+ LSAME = CA.EQ.CB
+ IF( LSAME )
+ $ RETURN
+*
+* Now test for equivalence if both characters are alphabetic.
+*
+ ZCODE = ICHAR( 'Z' )
+*
+* Use 'Z' rather than 'A' so that ASCII can be detected on Prime
+* machines, on which ICHAR returns a value with bit 8 set.
+* ICHAR('A') on Prime machines returns 193 which is the same as
+* ICHAR('A') on an EBCDIC machine.
+*
+ INTA = ICHAR( CA )
+ INTB = ICHAR( CB )
+*
+ IF( ZCODE.EQ.90 .OR. ZCODE.EQ.122 ) THEN
+*
+* ASCII is assumed - ZCODE is the ASCII code of either lower or
+* upper case 'Z'.
+*
+ IF( INTA.GE.97 .AND. INTA.LE.122 ) INTA = INTA - 32
+ IF( INTB.GE.97 .AND. INTB.LE.122 ) INTB = INTB - 32
+*
+ ELSE IF( ZCODE.EQ.233 .OR. ZCODE.EQ.169 ) THEN
+*
+* EBCDIC is assumed - ZCODE is the EBCDIC code of either lower or
+* upper case 'Z'.
+*
+ IF( INTA.GE.129 .AND. INTA.LE.137 .OR.
+ $ INTA.GE.145 .AND. INTA.LE.153 .OR.
+ $ INTA.GE.162 .AND. INTA.LE.169 ) INTA = INTA + 64
+ IF( INTB.GE.129 .AND. INTB.LE.137 .OR.
+ $ INTB.GE.145 .AND. INTB.LE.153 .OR.
+ $ INTB.GE.162 .AND. INTB.LE.169 ) INTB = INTB + 64
+*
+ ELSE IF( ZCODE.EQ.218 .OR. ZCODE.EQ.250 ) THEN
+*
+* ASCII is assumed, on Prime machines - ZCODE is the ASCII code
+* plus 128 of either lower or upper case 'Z'.
+*
+ IF( INTA.GE.225 .AND. INTA.LE.250 ) INTA = INTA - 32
+ IF( INTB.GE.225 .AND. INTB.LE.250 ) INTB = INTB - 32
+ END IF
+ LSAME = INTA.EQ.INTB
+*
+* RETURN
+*
+* End of LSAME
+*
+ END
+ DOUBLE PRECISION FUNCTION DLARND( IDIST, ISEED )
+*
+* -- LAPACK auxiliary routine (version 2.0) --
+* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
+* Courant Institute, Argonne National Lab, and Rice University
+* June 30, 1994
+*
+* .. Scalar Arguments ..
+ INTEGER IDIST
+* ..
+* .. Array Arguments ..
+ INTEGER ISEED( 4 )
+* ..
+*
+* Purpose
+* =======
+*
+* DLARND returns a random real number from a uniform or normal
+* distribution.
+*
+* Arguments
+* =========
+*
+* IDIST (input) INTEGER
+* Specifies the distribution of the random numbers:
+* = 1: uniform (0,1)
+* = 2: uniform (-1,1)
+* = 3: normal (0,1)
+*
+* ISEED (input/output) INTEGER array, dimension (4)
+* On entry, the seed of the random number generator; the array
+* elements must be between 0 and 4095, and ISEED(4) must be
+* odd.
+* On exit, the seed is updated.
+*
+* Further Details
+* ===============
+*
+* This routine calls the auxiliary routine DLARAN to generate a random
+* real number from a uniform (0,1) distribution. The Box-Muller method
+* is used to transform numbers from a uniform to a normal distribution.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ONE, TWO
+ PARAMETER ( ONE = 1.0D+0, TWO = 2.0D+0 )
+ DOUBLE PRECISION TWOPI
+ PARAMETER ( TWOPI = 6.2831853071795864769252867663D+0 )
+* ..
+* .. Local Scalars ..
+ DOUBLE PRECISION T1, T2
+* ..
+* .. External Functions ..
+ DOUBLE PRECISION DLARAN
+ EXTERNAL DLARAN
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC COS, LOG, SQRT
+* ..
+* .. Executable Statements ..
+*
+* Generate a real random number from a uniform (0,1) distribution
+*
+ T1 = DLARAN( ISEED )
+*
+ IF( IDIST.EQ.1 ) THEN
+*
+* uniform (0,1)
+*
+ DLARND = T1
+ ELSE IF( IDIST.EQ.2 ) THEN
+*
+* uniform (-1,1)
+*
+ DLARND = TWO*T1 - ONE
+ ELSE IF( IDIST.EQ.3 ) THEN
+*
+* normal (0,1)
+*
+ T2 = DLARAN( ISEED )
+ DLARND = SQRT( -TWO*LOG( T1 ) )*COS( TWOPI*T2 )
+ END IF
+ RETURN
+*
+* End of DLARND
+*
+ END
+ DOUBLE COMPLEX FUNCTION ZLARND( IDIST, ISEED )
+*
+* -- LAPACK auxiliary routine (version 2.0) --
+* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
+* Courant Institute, Argonne National Lab, and Rice University
+* June 30, 1994
+*
+* .. Scalar Arguments ..
+ INTEGER IDIST
+* ..
+* .. Array Arguments ..
+ INTEGER ISEED( 4 )
+* ..
+*
+* Purpose
+* =======
+*
+* ZLARND returns a random complex number from a uniform or normal
+* distribution.
+*
+* Arguments
+* =========
+*
+* IDIST (input) INTEGER
+* Specifies the distribution of the random numbers:
+* = 1: real and imaginary parts each uniform (0,1)
+* = 2: real and imaginary parts each uniform (-1,1)
+* = 3: real and imaginary parts each normal (0,1)
+* = 4: uniformly distributed on the disc abs(z) <= 1
+* = 5: uniformly distributed on the circle abs(z) = 1
+*
+* ISEED (input/output) INTEGER array, dimension (4)
+* On entry, the seed of the random number generator; the array
+* elements must be between 0 and 4095, and ISEED(4) must be
+* odd.
+* On exit, the seed is updated.
+*
+* Further Details
+* ===============
+*
+* This routine calls the auxiliary routine DLARAN to generate a random
+* real number from a uniform (0,1) distribution. The Box-Muller method
+* is used to transform numbers from a uniform to a normal distribution.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, ONE, TWO
+ PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0 )
+ DOUBLE PRECISION TWOPI
+ PARAMETER ( TWOPI = 6.2831853071795864769252867663D+0 )
+* ..
+* .. Local Scalars ..
+ DOUBLE PRECISION T1, T2
+* ..
+* .. External Functions ..
+ DOUBLE PRECISION DLARAN
+ EXTERNAL DLARAN
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC DCMPLX, EXP, LOG, SQRT
+* ..
+* .. Executable Statements ..
+*
+* Generate a pair of real random numbers from a uniform (0,1)
+* distribution
+*
+ T1 = DLARAN( ISEED )
+ T2 = DLARAN( ISEED )
+*
+ IF( IDIST.EQ.1 ) THEN
+*
+* real and imaginary parts each uniform (0,1)
+*
+ ZLARND = DCMPLX( T1, T2 )
+ ELSE IF( IDIST.EQ.2 ) THEN
+*
+* real and imaginary parts each uniform (-1,1)
+*
+ ZLARND = DCMPLX( TWO*T1-ONE, TWO*T2-ONE )
+ ELSE IF( IDIST.EQ.3 ) THEN
+*
+* real and imaginary parts each normal (0,1)
+*
+ ZLARND = SQRT( -TWO*LOG( T1 ) )*EXP( DCMPLX( ZERO, TWOPI*T2 ) )
+ ELSE IF( IDIST.EQ.4 ) THEN
+*
+* uniform distribution on the unit disc abs(z) <= 1
+*
+ ZLARND = SQRT( T1 )*EXP( DCMPLX( ZERO, TWOPI*T2 ) )
+ ELSE IF( IDIST.EQ.5 ) THEN
+*
+* uniform distribution on the unit circle abs(z) = 1
+*
+ ZLARND = EXP( DCMPLX( ZERO, TWOPI*T2 ) )
+ END IF
+ RETURN
+*
+* End of ZLARND
+*
+ END
+ DOUBLE PRECISION FUNCTION DLARAN( ISEED )
+*
+* -- LAPACK auxiliary routine (version 2.0) --
+* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
+* Courant Institute, Argonne National Lab, and Rice University
+* February 29, 1992
+*
+* .. Array Arguments ..
+ INTEGER ISEED( 4 )
+* ..
+*
+* Purpose
+* =======
+*
+* DLARAN returns a random real number from a uniform (0,1)
+* distribution.
+*
+* Arguments
+* =========
+*
+* ISEED (input/output) INTEGER array, dimension (4)
+* On entry, the seed of the random number generator; the array
+* elements must be between 0 and 4095, and ISEED(4) must be
+* odd.
+* On exit, the seed is updated.
+*
+* Further Details
+* ===============
+*
+* This routine uses a multiplicative congruential method with modulus
+* 2**48 and multiplier 33952834046453 (see G.S.Fishman,
+* 'Multiplicative congruential random number generators with modulus
+* 2**b: an exhaustive analysis for b = 32 and a partial analysis for
+* b = 48', Math. Comp. 189, pp 331-344, 1990).
+*
+* 48-bit integers are stored in 4 integer array elements with 12 bits
+* per element. Hence the routine is portable across machines with
+* integers of 32 bits or more.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ INTEGER M1, M2, M3, M4
+ PARAMETER ( M1 = 494, M2 = 322, M3 = 2508, M4 = 2549 )
+ DOUBLE PRECISION ONE
+ PARAMETER ( ONE = 1.0D+0 )
+ INTEGER IPW2
+ DOUBLE PRECISION R
+ PARAMETER ( IPW2 = 4096, R = ONE / IPW2 )
+* ..
+* .. Local Scalars ..
+ INTEGER IT1, IT2, IT3, IT4
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC DBLE, MOD
+* ..
+* .. Executable Statements ..
+*
+* multiply the seed by the multiplier modulo 2**48
+*
+ IT4 = ISEED( 4 )*M4
+ IT3 = IT4 / IPW2
+ IT4 = IT4 - IPW2*IT3
+ IT3 = IT3 + ISEED( 3 )*M4 + ISEED( 4 )*M3
+ IT2 = IT3 / IPW2
+ IT3 = IT3 - IPW2*IT2
+ IT2 = IT2 + ISEED( 2 )*M4 + ISEED( 3 )*M3 + ISEED( 4 )*M2
+ IT1 = IT2 / IPW2
+ IT2 = IT2 - IPW2*IT1
+ IT1 = IT1 + ISEED( 1 )*M4 + ISEED( 2 )*M3 + ISEED( 3 )*M2 +
+ $ ISEED( 4 )*M1
+ IT1 = MOD( IT1, IPW2 )
+*
+* return updated seed
+*
+ ISEED( 1 ) = IT1
+ ISEED( 2 ) = IT2
+ ISEED( 3 ) = IT3
+ ISEED( 4 ) = IT4
+*
+* convert 48-bit integer to a real number in the interval (0,1)
+*
+ DLARAN = R*( DBLE( IT1 )+R*( DBLE( IT2 )+R*( DBLE( IT3 )+R*
+ $ ( DBLE( IT4 ) ) ) ) )
+ RETURN
+*
+* End of DLARAN
+*
+ END
diff --git a/CMAKE/CTestCustom.cmake.in b/CMAKE/CTestCustom.cmake.in
new file mode 100644
index 0000000..ab940fa
--- /dev/null
+++ b/CMAKE/CTestCustom.cmake.in
@@ -0,0 +1,42 @@
+#
+# For further details regarding this file,
+# see http://www.vtk.org/Wiki/CMake_Testing_With_CTest#Customizing_CTest
+#
+
+SET(CTEST_CUSTOM_MAXIMUM_PASSED_TEST_OUTPUT_SIZE 0)
+SET(CTEST_CUSTOM_MAXIMUM_FAILED_TEST_OUTPUT_SIZE 0)
+SET(CTEST_CUSTOM_MAXIMUM_NUMBER_OF_ERRORS 500)
+SET(CTEST_CUSTOM_MAXIMUM_NUMBER_OF_WARNINGS 500)
+
+# Files to explicitly exclude from code coverage
+SET(CTEST_CUSTOM_COVERAGE_EXCLUDE
+ ${CTEST_CUSTOM_COVERAGE_EXCLUDE}
+
+ # Exclude the testing code itself from code coverage
+ "/TESTING/"
+)
+
+# Warnings to explicitly ignore
+SET(CTEST_CUSTOM_WARNING_EXCEPTION
+ ${CTEST_CUSTOM_WARNING_EXCEPTION}
+
+ # Common warning when linking ATLAS built with GNU Fortran 4.1 and building
+ # with GNU Fortran 4.4. It can be safely ignored.
+ "libgfortran.*may conflict with libgfortran"
+
+ # Harmless warning often seen on IRIX
+ "WARNING 84 : .*libm.* is not used for resolving any symbol"
+
+ # Warnings caused by sun compilers when building code to only run on your
+ # native platform
+ "xarch=native on this architecture implies -xarch=.*which generates code that does not run"
+
+ # Harmless warnings from the Intel compiler on Windows
+ "ipo: warning #11010: file format not recognized for .*\\.exe\\.embed\\.manifest\\.res"
+ "LINK : warning LNK4224: /INCREMENTAL:YES is no longer supported; ignored"
+
+ # Warnings caused by string truncation in the test code. The truncation is
+ # intentional
+ "Character string truncated to length 1 on assignment"
+)
+
diff --git a/CMAKE/CheckBLACSCompilerFlags.cmake b/CMAKE/CheckBLACSCompilerFlags.cmake
new file mode 100644
index 0000000..6bdfc4a
--- /dev/null
+++ b/CMAKE/CheckBLACSCompilerFlags.cmake
@@ -0,0 +1,90 @@
+# This module checks against various known compilers and thier respective
+# flags to determine any specific flags needing to be set.
+#
+# 1. If FPE traps are enabled either abort or disable them
+# 2. Specify fixed form if needed
+# 3. Ensure that Release builds use O2 instead of O3
+#
+#=============================================================================
+# Author: Chuck Atkins
+# Copyright 2011
+#=============================================================================
+
+macro( CheckBLACSCompilerFlags )
+
+set( FPE_EXIT FALSE )
+
+# GNU Fortran
+if( CMAKE_Fortran_COMPILER_ID STREQUAL "GNU" )
+ if( "${CMAKE_Fortran_FLAGS}" MATCHES "-ffpe-trap=[izoupd]")
+ set( FPE_EXIT TRUE )
+ endif()
+
+# Intel Fortran
+elseif( CMAKE_Fortran_COMPILER_ID STREQUAL "Intel" )
+ if( "${CMAKE_Fortran_FLAGS}" MATCHES "[-/]fpe(-all=|)0" )
+ set( FPE_EXIT TRUE )
+ endif()
+
+# SunPro F95
+elseif( CMAKE_Fortran_COMPILER_ID STREQUAL "SunPro" )
+ if( ("${CMAKE_Fortran_FLAGS}" MATCHES "-ftrap=") AND
+ NOT ("${CMAKE_Fortran_FLAGS}" MATCHES "-ftrap=(%|)none") )
+ set( FPE_EXIT TRUE )
+ elseif( NOT (CMAKE_Fortran_FLAGS MATCHES "-ftrap=") )
+ message( STATUS "Disabling FPE trap handlers with -ftrap=%none" )
+ set( CMAKE_Fortran_FLAGS "${CMAKE_Fortran_FLAGS} -ftrap=%none"
+ CACHE STRING "Flags for Fortran compiler." FORCE )
+ endif()
+
+# IBM XL Fortran
+elseif( (CMAKE_Fortran_COMPILER_ID STREQUAL "VisualAge" ) OR # CMake 2.6
+ (CMAKE_Fortran_COMPILER_ID STREQUAL "XL" ) ) # CMake 2.8
+ if( "${CMAKE_Fortran_FLAGS}" MATCHES "-qflttrap=[a-zA-Z:]:enable" )
+ set( FPE_EXIT TRUE )
+ endif()
+
+ if( NOT ("${CMAKE_Fortran_FLAGS}" MATCHES "-qfixed") )
+ message( STATUS "Enabling fixed format F90/F95 with -qfixed" )
+ set( CMAKE_Fortran_FLAGS "${CMAKE_Fortran_FLAGS} -qfixed"
+ CACHE STRING "Flags for Fortran compiler." FORCE )
+ endif()
+
+# HP Fortran
+elseif( CMAKE_Fortran_COMPILER_ID STREQUAL "HP" )
+ if( "${CMAKE_Fortran_FLAGS}" MATCHES "\\+fp_exception" )
+ set( FPE_EXIT TRUE )
+ endif()
+
+ if( NOT ("${CMAKE_Fortran_FLAGS}" MATCHES "\\+fltconst_strict") )
+ message( STATUS "Enabling strict float conversion with +fltconst_strict" )
+ set( CMAKE_Fortran_FLAGS "${CMAKE_Fortran_FLAGS} +fltconst_strict"
+ CACHE STRING "Flags for Fortran compiler." FORCE )
+ endif()
+
+ # Most versions of cmake don't have good default options for the HP compiler
+ set( CMAKE_Fortran_FLAGS_DEBUG "${CMAKE_Fortran_FLAGS_DEBUG} -g"
+ CACHE STRING "Flags used by the compiler during debug builds" FORCE )
+ set( CMAKE_Fortran_FLAGS_DEBUG "${CMAKE_Fortran_FLAGS_MINSIZEREL} +Osize"
+ CACHE STRING "Flags used by the compiler during release minsize builds" FORCE )
+ set( CMAKE_Fortran_FLAGS_DEBUG "${CMAKE_Fortran_FLAGS_RELEASE} +O2"
+ CACHE STRING "Flags used by the compiler during release builds" FORCE )
+ set( CMAKE_Fortran_FLAGS_DEBUG "${CMAKE_Fortran_FLAGS_RELWITHDEBINFO} +O2 -g"
+ CACHE STRING "Flags used by the compiler during release with debug info builds" FORCE )
+else()
+endif()
+
+if( "${CMAKE_Fortran_FLAGS_RELEASE}" MATCHES "O[3-9]" )
+ message( STATUS "Reducing RELEASE optimization level to O2" )
+ string( REGEX REPLACE "O[3-9]" "O2" CMAKE_Fortran_FLAGS_RELEASE
+ "${CMAKE_Fortran_FLAGS_RELEASE}" )
+ set( CMAKE_Fortran_FLAGS_RELEASE "${CMAKE_Fortran_FLAGS_RELEASE}"
+ CACHE STRING "Flags used by the compiler during release builds" FORCE )
+endif()
+
+
+if( FPE_EXIT )
+ message( FATAL_ERROR "Floating Point Exception (FPE) trap handlers are currently explicitly enabled in the compiler flags. BLACS is designed to check for and handle these cases internally and enabling these traps will likely cause BLACS to crash. Please re-configure with floating point exception trapping disabled." )
+endif()
+
+endmacro()
diff --git a/CMAKE/FortranMangling.cmake b/CMAKE/FortranMangling.cmake
new file mode 100644
index 0000000..e9642ed
--- /dev/null
+++ b/CMAKE/FortranMangling.cmake
@@ -0,0 +1,67 @@
+# Macro that defines variables describing the Fortran name mangling
+# convention
+#
+# Sets the following outputs on success:
+#
+# INTFACE
+# Add_
+# NoChange
+# f77IsF2C
+# UpCase
+#
+
+FUNCTION(COMPILE RESULT)
+ MESSAGE(STATUS "=========")
+ MESSAGE(STATUS "Compiling and Building BLACS INSTALL Testing to set correct variables")
+
+ # Configure:
+ EXECUTE_PROCESS(COMMAND ${CMAKE_COMMAND}
+ "-DCMAKE_Fortran_COMPILER=${CMAKE_Fortran_COMPILER}"
+ "-DCMAKE_C_COMPILER=${CMAKE_C_COMPILER}"
+ WORKING_DIRECTORY ${PROJECT_SOURCE_DIR}/BLACS/INSTALL/
+ RESULT_VARIABLE RESVAR OUTPUT_VARIABLE LOG1 ERROR_VARIABLE LOG1
+ )
+ if(RESVAR EQUAL 0)
+ MESSAGE(STATUS "Configure in the INSTALL directory successful")
+ else()
+ MESSAGE(FATAL_ERROR " Configure in the BLACS INSTALL directory FAILED")
+ MESSAGE(FATAL_ERROR " Output Build:\n ${LOG1}")
+ endif()
+
+ # Build:
+ EXECUTE_PROCESS(COMMAND ${CMAKE_COMMAND} --build
+ ${PROJECT_SOURCE_DIR}/BLACS/INSTALL/
+ RESULT_VARIABLE RESVAR OUTPUT_VARIABLE LOG2 ERROR_VARIABLE LOG2
+ )
+ if(RESVAR EQUAL 0)
+ MESSAGE(STATUS "Build in the BLACS INSTALL directory successful")
+ else()
+ MESSAGE(FATAL_ERROR " Build in the BLACS INSTALL directory FAILED")
+ MESSAGE(FATAL_ERROR " Output Build:\n ${LOG2}")
+ endif()
+ # Clean up:
+ FILE(REMOVE_RECURSE ${PROJECT_SOURCE_DIR}/BLACS/INSTALL/CMakeCache.txt)
+ FILE(REMOVE_RECURSE ${PROJECT_SOURCE_DIR}/BLACS/INSTALL/CMakeFiles )
+ENDFUNCTION()
+
+
+macro(FORTRAN_MANGLING CDEFS)
+MESSAGE(STATUS "=========")
+MESSAGE(STATUS "Testing FORTRAN_MANGLING")
+
+ execute_process ( COMMAND ${PROJECT_SOURCE_DIR}/BLACS/INSTALL/xintface
+ RESULT_VARIABLE xintface_RES
+ OUTPUT_VARIABLE xintface_OUT
+ ERROR_VARIABLE xintface_ERR)
+
+
+# MESSAGE(STATUS "FORTRAN MANGLING:RUN \n${xintface_OUT}")
+
+ if (xintface_RES EQUAL 0)
+ STRING(REPLACE "\n" "" xintface_OUT "${xintface_OUT}")
+ MESSAGE(STATUS "CDEFS set to ${xintface_OUT}")
+ SET(CDEFS ${xintface_OUT} CACHE STRING "Fortran Mangling" FORCE)
+ else()
+ MESSAGE(FATAL_ERROR "FORTRAN_MANGLING:ERROR ${xintface_ERR}")
+ endif()
+endmacro(FORTRAN_MANGLING)
diff --git a/CMAKE/scalapack-config-build.cmake.in b/CMAKE/scalapack-config-build.cmake.in
new file mode 100644
index 0000000..4afc273
--- /dev/null
+++ b/CMAKE/scalapack-config-build.cmake.in
@@ -0,0 +1 @@
+include("@SCALAPACK_BINARY_DIR@/scalapack-targets.cmake")
diff --git a/CMAKE/scalapack-config-install.cmake.in b/CMAKE/scalapack-config-install.cmake.in
new file mode 100644
index 0000000..560cf62
--- /dev/null
+++ b/CMAKE/scalapack-config-install.cmake.in
@@ -0,0 +1,2 @@
+get_filename_component(_SELF_DIR "${CMAKE_CURRENT_LIST_FILE}" PATH)
+include(${_SELF_DIR}/scalapack-targets.cmake)
diff --git a/CMAKE/scalapack-config-version.cmake.in b/CMAKE/scalapack-config-version.cmake.in
new file mode 100644
index 0000000..afba17e
--- /dev/null
+++ b/CMAKE/scalapack-config-version.cmake.in
@@ -0,0 +1,8 @@
+set(PACKAGE_VERSION "@SCALAPACK_VERSION@")
+if(NOT ${PACKAGE_FIND_VERSION} VERSION_GREATER ${PACKAGE_VERSION})
+ set(PACKAGE_VERSION_COMPATIBLE 1)
+ if(${PACKAGE_FIND_VERSION} VERSION_EQUAL ${PACKAGE_VERSION})
+ set(PACKAGE_VERSION_EXACT 1)
+ endif()
+endif()
+
diff --git a/CMakeLists.txt b/CMakeLists.txt
new file mode 100644
index 0000000..91c32c1
--- /dev/null
+++ b/CMakeLists.txt
@@ -0,0 +1,311 @@
+cmake_minimum_required(VERSION 2.8)
+project(SCALAPACK C Fortran)
+# Configure the warning and code coverage suppression file
+configure_file(
+ "${SCALAPACK_SOURCE_DIR}/CMAKE/CTestCustom.cmake.in"
+ "${SCALAPACK_BINARY_DIR}/CTestCustom.cmake"
+ COPYONLY
+)
+
+# Add the CMake directory for custon CMake modules
+set(CMAKE_MODULE_PATH "${SCALAPACK_SOURCE_DIR}/CMAKE" ${CMAKE_MODULE_PATH})
+
+if (UNIX)
+ if ( "${CMAKE_Fortran_COMPILER}" MATCHES "ifort" )
+ set( CMAKE_Fortran_FLAGS "${CMAKE_Fortran_FLAGS} -fltconsistency -fp_port" )
+ endif ()
+endif ()
+
+#
+# MPI
+#
+#set(MPI_BASE_DIR "/Users/julie/opt/openmpi/" CACHE PATH "MPI Path")
+#set(MPI_BASE_DIR "/Users/julie/opt/mpich2/" CACHE PATH "MPI Path")
+set(CMAKE_PREFIX_PATH "${MPI_BASE_DIR};${CMAKE_PREFIX_PATH}")
+#set(MPI_COMPILER ${MPI_BASE_DIR}/bin/mpicc)
+
+find_package(MPI)
+if (MPI_FOUND)
+ message(STATUS "Found MPI_LIBRARY : ${MPI_FOUND} ")
+ INCLUDE_DIRECTORIES(${MPI_INCLUDE_PATH})
+
+ find_program(MPI_C_COMPILER
+ NAMES mpicc
+ HINTS "${MPI_BASE_DIR}"
+ PATH_SUFFIXES bin
+ DOC "MPI C compiler.")
+ MARK_AS_ADVANCED(MPI_C_COMPILER)
+ if ("${MPI_C_COMPILER}" STREQUAL "MPI_C_COMPILER-NOTFOUND")
+ message(ERROR "--> MPI C Compiler NOT FOUND (please set MPI_BASE_DIR accordingly")
+ else()
+ message(STATUS "--> MPI C Compiler : ${MPI_C_COMPILER}")
+ SET(CMAKE_C_COMPILER "${MPI_C_COMPILER}")
+ message(STATUS "--> C Compiler : ${CMAKE_C_COMPILER}")
+ endif()
+ find_program(MPI_Fortran_COMPILER
+ NAMES mpif77
+ HINTS "${MPI_BASE_DIR}"
+ PATH_SUFFIXES bin
+ DOC "MPI Fortran compiler.")
+ MARK_AS_ADVANCED(MPI_Fortran_COMPILER)
+
+
+
+ if ("${MPI_Fortran_COMPILER}" STREQUAL "MPI_Fortran_COMPILER-NOTFOUND")
+ message(ERROR "--> MPI Fortran Compiler NOT FOUND (please set MPI_BASE_DIR accordingly")
+ else()
+ message(STATUS "--> MPI Fortran Compiler : ${MPI_Fortran_COMPILER}")
+ SET(Fortran_COMPILER "${CMAKE_Fortran_COMPILER}")
+ SET(CMAKE_Fortran_COMPILER "${MPI_Fortran_COMPILER}")
+ message(STATUS "--> Fortran Compiler : ${CMAKE_Fortran_COMPILER}")
+ endif()
+
+else()
+ message(STATUS "Found MPI_LIBRARY : ${MPI_FOUND} ")
+ set(MPI_BASE_DIR ${MPI_BASE_DIR} CACHE PATH "MPI Path")
+ UNSET(MPIEXEC CACHE)
+ UNSET(MPIEXEC_POSTFLAGS CACHE)
+ UNSET(MPIEXEC_PREFLAGS CACHE)
+ UNSET(MPIEXEC_MAX_NUMPROCS CACHE)
+ UNSET(MPIEXEC_NUMPROC_FLAG CACHE)
+ UNSET(MPI_COMPILE_FLAGS CACHE)
+ UNSET(MPI_LINK_FLAGS CACHE)
+ UNSET(MPI_INCLUDE_PATH CACHE)
+ message(FATAL_ERROR "--> MPI Library NOT FOUND -- please set MPI_BASE_DIR accordingly --")
+endif()
+
+
+if (UNIX)
+ if ( "${CMAKE_Fortran_COMPILER}" MATCHES "ifort" )
+ set( CMAKE_Fortran_FLAGS "${CMAKE_Fortran_FLAGS} -fltconsistency -fp_port" )
+ endif ()
+endif ()
+
+macro(SCALAPACK_install_library lib)
+ install(TARGETS ${lib} EXPORT scalapack-targets
+ ARCHIVE DESTINATION lib${LIB_SUFFIX}
+ LIBRARY DESTINATION lib${LIB_SUFFIX}
+ RUNTIME DESTINATION Testing
+ )
+endmacro()
+
+# --------------------------------------------------
+# Testing
+SET(DART_TESTING_TIMEOUT 600)
+
+enable_testing()
+include(CTest)
+enable_testing()
+# --------------------------------------------------
+
+# Organize output files. On Windows this also keeps .dll files next
+# to the .exe files that need them, making tests easy to run.
+set(CMAKE_RUNTIME_OUTPUT_DIRECTORY ${SCALAPACK_BINARY_DIR}/TESTING)
+set(CMAKE_ARCHIVE_OUTPUT_DIRECTORY ${SCALAPACK_BINARY_DIR}/lib)
+set(CMAKE_LIBRARY_OUTPUT_DIRECTORY ${SCALAPACK_BINARY_DIR}/lib)
+
+# --------------------------------------------------
+# Check for any necessary platform specific compiler flags
+include( CheckBLACSCompilerFlags )
+CheckBLACSCompilerFlags()
+
+set(prefix ${CMAKE_INSTALL_PREFIX})
+set(libdir ${CMAKE_INSTALL_PREFIX}/lib${LIB_SUFFIX})
+set(PKG_CONFIG_DIR ${libdir}/pkgconfig)
+
+# --------------------------------------------------
+# BLACS Internal variables
+#
+# Fortran Mangling, MPI Tests and BLACS settings
+#
+include(FortranMangling)
+COMPILE(install_COMPILED)
+
+FORTRAN_MANGLING(CDEFS)
+#MESSAGE(STATUS "Setting CDEFS = ${CDEFS}")
+#set(CDEFS ${CDEFS} CACHE STRING "Fortran Mangling" FORCE)
+MESSAGE(STATUS "=========")
+
+# --------------------------------------------------
+# Compiler Flags
+ADD_DEFINITIONS( "-D${CDEFS}")
+
+# --------------------------------------------------
+# ScaLAPACK needs BLAS and LAPACK
+
+option(USE_OPTIMIZED_LAPACK_BLAS "Whether or not to search for optimized LAPACK and BLAS libraries on your machine (if not found, Reference LAPACK and BLAS will be downloaded and installed)" ON)
+
+message(STATUS "CHECKING BLAS AND LAPACK LIBRARIES")
+
+IF(LAPACK_LIBRARIES)
+ include(CheckFortranFunctionExists)
+ message(STATUS "--> LAPACK supplied by user is ${LAPACK_LIBRARIES}.")
+ set(CMAKE_REQUIRED_LIBRARIES ${LAPACK_LIBRARIES})
+ CHECK_FORTRAN_FUNCTION_EXISTS("dgesv" LAPACK_FOUND)
+ unset( CMAKE_REQUIRED_LIBRARIES )
+ message(STATUS "--> LAPACK routine dgesv is found: ${LAPACK_FOUND}.")
+ENDIF()
+
+if(LAPACK_FOUND)
+ message(STATUS "--> LAPACK supplied by user is WORKING, will use ${LAPACK_LIBRARIES}.")
+else(LAPACK_FOUND)
+ if(USE_OPTIMIZED_LAPACK_BLAS)
+ message(STATUS "--> Searching for optimized LAPACK and BLAS libraries on your machine.")
+ find_package(LAPACK)
+ ENDIF(USE_OPTIMIZED_LAPACK_BLAS)
+ if(NOT LAPACK_FOUND)
+ message(STATUS "--> LAPACK and BLAS were not found. Reference LAPACK and BLAS will be downloaded and installed")
+ include(ExternalProject)
+ ExternalProject_Add(
+ lapack
+ URL http://www.netlib.org/lapack/lapack.tgz
+ CMAKE_ARGS -DCMAKE_INSTALL_PREFIX:PATH=${SCALAPACK_BINARY_DIR}
+ PREFIX ${SCALAPACK_BINARY_DIR}/dependencies
+ )
+ if (UNIX)
+ SET(LAPACK_LIBRARIES ${SCALAPACK_BINARY_DIR}/lib/liblapack.a CACHE STRING "LAPACK library" FORCE)
+ SET(BLAS_LIBRARIES ${SCALAPACK_BINARY_DIR}/lib/libblas.a CACHE STRING "BLAS library" FORCE)
+ else (UNIX) # On Windows
+ SET(LAPACK_LIBRARIES ${SCALAPACK_BINARY_DIR}/lib/liblapack.lib CACHE STRING "LAPACK library" FORCE)
+ SET(BLAS_LIBRARIES ${SCALAPACK_BINARY_DIR}/lib/libblas.lib CACHE STRING "BLAS library" FORCE)
+ endif (UNIX)
+ ENDIF()
+ENDIF()
+
+message(STATUS "BLAS library: ${BLAS_LIBRARIES}")
+message(STATUS "LAPACK library: ${LAPACK_LIBRARIES}")
+
+MESSAGE(STATUS "=========")
+
+# --------------------------------------------------
+# By default static library
+OPTION(BUILD_SHARED_LIBS "Build shared libraries" OFF )
+OPTION(BUILD_STATIC_LIBS "Build static libraries" ON )
+
+# --------------------------------------------------
+# Subdirectories that need to be processed
+
+macro(append_subdir_files variable dirname)
+get_directory_property(holder DIRECTORY ${dirname} DEFINITION ${variable})
+foreach(depfile ${holder})
+ list(APPEND ${variable} "${dirname}/${depfile}")
+endforeach()
+endmacro()
+
+
+#
+# BLACS
+#
+add_subdirectory(BLACS)
+append_subdir_files(blacs "BLACS/SRC")
+
+#
+# TOOLS
+#
+add_subdirectory(TOOLS)
+append_subdir_files(tools TOOLS)
+append_subdir_files(tools-C TOOLS)
+append_subdir_files(extra_lapack "TOOLS/LAPACK")
+
+#
+# PBLAS
+#
+add_subdirectory(PBLAS)
+append_subdir_files(pblas "PBLAS/SRC")
+append_subdir_files(pblas-F "PBLAS/SRC")
+append_subdir_files(pbblas "PBLAS/SRC/PBBLAS")
+append_subdir_files(ptzblas "PBLAS/SRC/PTZBLAS")
+append_subdir_files(ptools "PBLAS/SRC/PTOOLS")
+
+#
+# REDIST
+#
+add_subdirectory(REDIST)
+append_subdir_files(redist "REDIST/SRC")
+
+#
+# SRC
+#
+add_subdirectory(SRC)
+append_subdir_files(src "SRC")
+append_subdir_files(src-C "SRC")
+
+if (UNIX)
+ add_library(scalapack ${blacs} ${tools} ${tools-C} ${extra_lapack} ${pblas} ${pblas-F} ${ptzblas} ${ptools} ${pbblas} ${redist} ${src} ${src-C})
+ target_link_libraries( scalapack ${LAPACK_LIBRARIES} ${BLAS_LIBRARIES})
+ scalapack_install_library(scalapack)
+else (UNIX) # Need to separate Fortran and C Code
+ OPTION(BUILD_SHARED_LIBS "Build shared libraries" ON )
+ add_library(scalapack ${blacs} ${tools-C} ${pblas} ${ptools} ${redist} ${src-C})
+ target_link_libraries( scalapack ${LAPACK_LIBRARIES} ${BLAS_LIBRARIES})
+ add_library(scalapack-F ${pblas-F} ${pbblas} ${ptzblas} ${tools} ${src} ${extra_lapack} )
+ target_link_libraries( scalapack-F ${LAPACK_LIBRARIES} ${BLAS_LIBRARIES})
+ scalapack_install_library(scalapack)
+ scalapack_install_library(scalapack-F)
+endif (UNIX)
+add_subdirectory(TESTING)
+
+# --------------------------------------------------
+# CPACK Packaging
+
+SET(CPACK_PACKAGE_NAME "ScaLAPACK")
+SET(CPACK_PACKAGE_VENDOR "University of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd")
+SET(CPACK_PACKAGE_DESCRIPTION_SUMMARY "ScaLAPACK- Linear Algebra Package")
+set(SCALAPACK_VERSION 2.0.2)
+set(CPACK_PACKAGE_VERSION_MAJOR 2)
+set(CPACK_PACKAGE_VERSION_MINOR 0)
+set(CPACK_PACKAGE_VERSION_PATCH 2)
+set(CPACK_RESOURCE_FILE_LICENSE "${CMAKE_CURRENT_SOURCE_DIR}/LICENSE")
+SET(CPACK_PACKAGE_INSTALL_DIRECTORY "SCALAPACK")
+IF(WIN32 AND NOT UNIX)
+ # There is a bug in NSI that does not handle full unix paths properly. Make
+ # sure there is at least one set of four (4) backlasshes.
+ SET(CPACK_NSIS_HELP_LINK "http:\\\\\\\\http://icl.cs.utk.edu/lapack-forum")
+ SET(CPACK_NSIS_URL_INFO_ABOUT "http:\\\\\\\\www.netlib.org/scalapack")
+ SET(CPACK_NSIS_CONTACT "scalapack at eecs.utk.edu")
+ SET(CPACK_NSIS_MODIFY_PATH ON)
+ SET(CPACK_NSIS_DISPLAY_NAME "SCALAPACK-${SCALAPACK_VERSION}")
+ set(CPACK_PACKAGE_RELOCATABLE "true")
+ELSE(WIN32 AND NOT UNIX)
+ SET(CPACK_GENERATOR "TGZ")
+ SET(CPACK_SOURCE_GENERATOR TGZ)
+ SET(CPACK_SOURCE_PACKAGE_FILE_NAME "scalapack-${SCALAPACK_VERSION}" )
+ SET(CPACK_SOURCE_IGNORE_FILES ~$ .svn ${CPACK_SOURCE_IGNORE_FILES} )
+ENDIF(WIN32 AND NOT UNIX)
+INCLUDE(CPack)
+
+
+# --------------------------------------------------
+
+
+export(TARGETS scalapack FILE scalapack-targets.cmake)
+
+if( NOT LAPACK_FOUND )
+ install(FILES
+ ${BLAS_LIBRARIES} ${LAPACK_LIBRARIES}
+ DESTINATION lib
+ )
+endif( NOT LAPACK_FOUND )
+
+configure_file(${SCALAPACK_SOURCE_DIR}/CMAKE/scalapack-config-version.cmake.in
+ ${SCALAPACK_BINARY_DIR}/scalapack-config-version.cmake @ONLY)
+configure_file(${SCALAPACK_SOURCE_DIR}/CMAKE/scalapack-config-build.cmake.in
+ ${SCALAPACK_BINARY_DIR}/scalapack-config.cmake @ONLY)
+
+configure_file(${CMAKE_CURRENT_SOURCE_DIR}/scalapack.pc.in ${CMAKE_CURRENT_BINARY_DIR}/scalapack.pc)
+ install(FILES
+ ${CMAKE_CURRENT_BINARY_DIR}/scalapack.pc
+ DESTINATION ${PKG_CONFIG_DIR}
+ )
+
+configure_file(${SCALAPACK_SOURCE_DIR}/CMAKE/scalapack-config-install.cmake.in
+ ${SCALAPACK_BINARY_DIR}/CMakeFiles/scalapack-config.cmake @ONLY)
+install(FILES
+ ${SCALAPACK_BINARY_DIR}/CMakeFiles/scalapack-config.cmake
+ ${SCALAPACK_BINARY_DIR}/scalapack-config-version.cmake
+ DESTINATION lib/cmake/scalapack-${SCALAPACK_VERSION}
+ )
+
+install(EXPORT scalapack-targets
+ DESTINATION lib/cmake/scalapack-${SCALAPACK_VERSION})
+
diff --git a/CTestConfig.cmake b/CTestConfig.cmake
new file mode 100644
index 0000000..751db23
--- /dev/null
+++ b/CTestConfig.cmake
@@ -0,0 +1,13 @@
+## This file should be placed in the root directory of your project.
+## Then modify the CMakeLists.txt file in the root directory of your
+## project to incorporate the testing dashboard.
+## # The following are required to uses Dart and the Cdash dashboard
+## ENABLE_TESTING()
+## INCLUDE(CTest)
+set(CTEST_PROJECT_NAME "ScaLAPACK")
+set(CTEST_NIGHTLY_START_TIME "00:00:00 EST")
+
+set(CTEST_DROP_METHOD "http")
+set(CTEST_DROP_SITE "icl.cs.utk.edu/cdash")
+set(CTEST_DROP_LOCATION "/submit.php?project=ScaLAPACK")
+set(CTEST_DROP_SITE_CDASH TRUE)
diff --git a/EXAMPLE/Makefile b/EXAMPLE/Makefile
index 150ff46..bc15c3f 100644
--- a/EXAMPLE/Makefile
+++ b/EXAMPLE/Makefile
@@ -15,61 +15,22 @@ complex: pcscaex
complex16: pzscaex
-$(TESTINGdir)/SCAEX.dat: SCAEX.dat
- cp SCAEX.dat $(TESTINGdir)
-
-$(TESTINGdir)/SSCAEXMAT.dat: SSCAEXMAT.dat
- cp SSCAEXMAT.dat $(TESTINGdir)
-
-$(TESTINGdir)/SSCAEXRHS.dat: SSCAEXRHS.dat
- cp SSCAEXRHS.dat $(TESTINGdir)
-
psscaex: $(TESTOBJS)
- $(F77LOADER) $(F77LOADFLAGS) -o $(TESTINGdir)/xsscaex $(TESTOBJS) $(LIBS)
- $(MAKE) $(TESTINGdir)/SCAEX.dat
- $(MAKE) $(TESTINGdir)/SSCAEXMAT.dat
- $(MAKE) $(TESTINGdir)/SSCAEXRHS.dat
-
-$(TESTINGdir)/ZSCAEXMAT.dat: ZSCAEXMAT.dat
- cp ZSCAEXMAT.dat $(TESTINGdir)
-
-$(TESTINGdir)/ZSCAEXRHS.dat: ZSCAEXRHS.dat
- cp ZSCAEXRHS.dat $(TESTINGdir)
+ $(FCLOADER) $(FCLOADFLAGS) -o xsscaex $(TESTOBJS) ../$(SCALAPACKLIB) $(LIBS)
pzscaex: $(TESTOBJZ)
- $(F77LOADER) $(F77LOADFLAGS) -o $(TESTINGdir)/xzscaex $(TESTOBJZ) $(LIBS)
- $(MAKE) $(TESTINGdir)/SCAEX.dat
- $(MAKE) $(TESTINGdir)/ZSCAEXMAT.dat
- $(MAKE) $(TESTINGdir)/ZSCAEXRHS.dat
-
-$(TESTINGdir)/CSCAEXMAT.dat: CSCAEXMAT.dat
- cp CSCAEXMAT.dat $(TESTINGdir)
-
-$(TESTINGdir)/CSCAEXRHS.dat: CSCAEXRHS.dat
- cp CSCAEXRHS.dat $(TESTINGdir)
+ $(FCLOADER) $(FCLOADFLAGS) -o xzscaex $(TESTOBJZ) ../$(SCALAPACKLIB) $(LIBS)
pcscaex: $(TESTOBJC)
- $(F77LOADER) $(F77LOADFLAGS) -o $(TESTINGdir)/xcscaex $(TESTOBJC) $(LIBS)
- $(MAKE) $(TESTINGdir)/SCAEX.dat
- $(MAKE) $(TESTINGdir)/CSCAEXMAT.dat
- $(MAKE) $(TESTINGdir)/CSCAEXRHS.dat
-
-$(TESTINGdir)/DSCAEXMAT.dat: DSCAEXMAT.dat
- cp DSCAEXMAT.dat $(TESTINGdir)
-
-$(TESTINGdir)/DSCAEXRHS.dat: DSCAEXRHS.dat
- cp DSCAEXRHS.dat $(TESTINGdir)
+ $(FCLOADER) $(FCLOADFLAGS) -o xcscaex $(TESTOBJC) ../$(SCALAPACKLIB) $(LIBS)
pdscaex: $(TESTOBJD)
- $(F77LOADER) $(F77LOADFLAGS) -o $(TESTINGdir)/xdscaex $(TESTOBJD) $(LIBS)
- $(MAKE) $(TESTINGdir)/SCAEX.dat
- $(MAKE) $(TESTINGdir)/DSCAEXMAT.dat
- $(MAKE) $(TESTINGdir)/DSCAEXRHS.dat
+ $(FCLOADER) $(FCLOADFLAGS) -o xdscaex $(TESTOBJD) ../$(SCALAPACKLIB) $(LIBS)
clean :
- rm -f *.o
+ rm -f $(TESTOBJS) $(TESTOBJD) $(TESTOBJZ) $(TESTOBJC) xsscaex xzscaex xcscaex xdscaex
-.f.o : ; $(F77) -c $(F77FLAGS) $*.f
+.f.o : ; $(FC) -c $(FCFLAGS) $*.f
-.c.o : ; $(CC) -c $(CCFLAGS) $(CDEFS) $*.c
+.c.o : ; $(CC) -c $(CDEFS) $(CCFLAGS) $*.c
diff --git a/INSTALL/SLmake.ALPHA b/INSTALL/SLmake.ALPHA
deleted file mode 100644
index a6aeb8d..0000000
--- a/INSTALL/SLmake.ALPHA
+++ /dev/null
@@ -1,103 +0,0 @@
-############################################################################
-#
-# Program: ScaLAPACK
-#
-# Module: SLmake.inc
-#
-# Purpose: Top-level Definitions
-#
-# Creation date: Feburary 15, 2000
-#
-# Modified:
-#
-# Send bug reports, comments or suggestions to scalapack at cs.utk.edu
-#
-############################################################################
-#
-SHELL = /bin/sh
-#
-# The complete path to the top level of ScaLAPACK directory, usually
-# $(HOME)/SCALAPACK
-#
-home = $(HOME)/SCALAPACK
-#
-# The platform identifier to suffix to the end of library names
-#
-PLAT = ALPHA
-#
-# BLACS setup. All version need the debug level (0 or 1),
-# and the directory where the BLACS libraries are
-#
-BLACSDBGLVL = 0
-BLACSdir = $(HOME)/BLACS/LIB
-#
-# MPI setup; tailor to your system if using MPIBLACS
-# Will need to comment out these 6 lines if using PVM
-#
-USEMPI = -DUsingMpiBlacs
-SMPLIB = /usr/lib/mpi/build/alpha/ch_p4/lib/libmpich.a
-BLACSFINIT = $(BLACSdir)/blacsF77init_MPI-$(PLAT)-$(BLACSDBGLVL).a
-BLACSCINIT = $(BLACSdir)/blacsCinit_MPI-$(PLAT)-$(BLACSDBGLVL).a
-BLACSLIB = $(BLACSdir)/blacs_MPI-$(PLAT)-$(BLACSDBGLVL).a
-TESTINGdir = $(home)/TESTING
-
-#
-# PVMBLACS setup, uncomment next 6 lines if using PVM
-#
-#USEMPI =
-#SMPLIB = $(PVM_ROOT)/lib/$(PLAT)/libpvm3.a
-#BLACSFINIT =
-#BLACSCINIT =
-#BLACSLIB = $(BLACSdir)/blacs_PVM-$(PLAT)-$(BLACSDBGLVL).a
-#TESTINGdir = $(HOME)/pvm3/bin/$(PLAT)
-
-CBLACSLIB = $(BLACSCINIT) $(BLACSLIB) $(BLACSCINIT)
-FBLACSLIB = $(BLACSFINIT) $(BLACSLIB) $(BLACSFINIT)
-
-#
-# The directories to find the various pieces of ScaLapack
-#
-PBLASdir = $(home)/PBLAS
-SRCdir = $(home)/SRC
-TESTdir = $(home)/TESTING
-PBLASTSTdir = $(TESTINGdir)
-TOOLSdir = $(home)/TOOLS
-REDISTdir = $(home)/REDIST
-REDISTTSTdir = $(TESTINGdir)
-#
-# The fortran and C compilers, loaders, and their flags
-#
-F77 = f77
-CC = cc
-NOOPT =
-F77FLAGS = -O $(NOOPT)
-DRVOPTS = $(F77FLAGS)
-CCFLAGS = $(F77FLAGS)
-SRCFLAG =
-F77LOADER = $(F77)
-CCLOADER = $(CC)
-F77LOADFLAGS =
-CCLOADFLAGS =
-#
-# C preprocessor defs for compilation
-# (-DNoChange, -DAdd_, -DUpCase, or -Df77IsF2C)
-#
-CDEFS = -DAdd_ -DNO_IEEE $(USEMPI)
-#
-# The archiver and the flag(s) to use when building archive (library)
-# Also the ranlib routine. If your system has no ranlib, set RANLIB = echo
-#
-ARCH = ar
-ARCHFLAGS = cr
-RANLIB = ranlib
-#
-# The name of the libraries to be created/linked to
-#
-SCALAPACKLIB = $(home)/libscalapack.a
-BLASLIB = -lcxml
-LAPACKLIB =
-#
-PBLIBS = $(SCALAPACKLIB) $(FBLACSLIB) $(LAPACKLIB) $(BLASLIB) $(SMPLIB)
-PRLIBS = $(SCALAPACKLIB) $(CBLACSLIB) $(SMPLIB)
-RLIBS = $(SCALAPACKLIB) $(FBLACSLIB) $(LAPACKLIB) $(CBLACSLIB) $(BLASLIB) $(SMPLIB)
-LIBS = $(PBLIBS)
diff --git a/INSTALL/SLmake.HPPA b/INSTALL/SLmake.HPPA
deleted file mode 100644
index 24d19d0..0000000
--- a/INSTALL/SLmake.HPPA
+++ /dev/null
@@ -1,103 +0,0 @@
-############################################################################
-#
-# Program: ScaLAPACK
-#
-# Module: SLmake.inc
-#
-# Purpose: Top-level Definitions
-#
-# Creation date: February 15, 2000
-#
-# Modified:
-#
-# Send bug reports, comments or suggestions to scalapack at cs.utk.edu
-#
-############################################################################
-#
-SHELL = /bin/sh
-#
-# The complete path to the top level of ScaLAPACK directory, usually
-# $(HOME)/SCALAPACK
-#
-home = $(HOME)/SCALAPACK
-#
-# The platform identifier to suffix to the end of library names
-#
-PLAT = HPPA
-#
-# BLACS setup. All version need the debug level (0 or 1),
-# and the directory where the BLACS libraries are
-#
-BLACSDBGLVL = 0
-BLACSdir = $(HOME)/BLACS/LIB
-#
-# MPI setup; tailor to your system if using MPIBLACS
-# Will need to comment out these 6 lines if using PVM
-#
-USEMPI = -DUsingMpiBlacs
-SMPLIB = /usr/lib/mpi/build/hpux/ch_p4/lib/libmpich.a -lV3 -Wl,-B,immediate
-BLACSFINIT = $(BLACSdir)/blacsF77init_MPI-$(PLAT)-$(BLACSDBGLVL).a
-BLACSCINIT = $(BLACSdir)/blacsCinit_MPI-$(PLAT)-$(BLACSDBGLVL).a
-BLACSLIB = $(BLACSdir)/blacs_MPI-$(PLAT)-$(BLACSDBGLVL).a
-TESTINGdir = $(home)/TESTING
-
-#
-# PVMBLACS setup, uncomment next 6 lines if using PVM
-#
-#USEMPI =
-#SMPLIB = $(PVM_ROOT)/lib/$(PLAT)/libpvm3.a
-#BLACSFINIT =
-#BLACSCINIT =
-#BLACSLIB = $(BLACSdir)/blacs_PVM-$(PLAT)-$(BLACSDBGLVL).a
-#TESTINGdir = $(HOME)/pvm3/bin/$(PLAT)
-
-CBLACSLIB = $(BLACSCINIT) $(BLACSLIB) $(BLACSCINIT)
-FBLACSLIB = $(BLACSFINIT) $(BLACSLIB) $(BLACSFINIT)
-
-#
-# The directories to find the various pieces of ScaLapack
-#
-PBLASdir = $(home)/PBLAS
-SRCdir = $(home)/SRC
-TESTdir = $(home)/TESTING
-PBLASTSTdir = $(TESTINGdir)
-TOOLSdir = $(home)/TOOLS
-REDISTdir = $(home)/REDIST
-REDISTTSTdir = $(TESTINGdir)
-#
-# The fortran and C compilers, loaders, and their flags
-#
-F77 = f77
-CC = cc
-NOOPT =
-F77FLAGS = -O $(NOOPT)
-DRVOPTS = $(F77FLAGS)
-CCFLAGS = $(F77FLAGS)
-SRCFLAG =
-F77LOADER = $(F77)
-CCLOADER = $(CC)
-F77LOADFLAGS =
-CCLOADFLAGS =
-#
-# C preprocessor defs for compilation
-# (-DNoChange, -DAdd_, -DUpCase, or -Df77IsF2C)
-#
-CDEFS = -DNoChange $(USEMPI)
-#
-# The archiver and the flag(s) to use when building archive (library)
-# Also the ranlib routine. If your system has no ranlib, set RANLIB = echo
-#
-ARCH = ar
-ARCHFLAGS = cr
-RANLIB = echo
-#
-# The name of the libraries to be created/linked to
-#
-SCALAPACKLIB = $(home)/libscalapack.a
-BLASLIB = -lblas
-LAPACKLIB = -llapack
-#
-PBLIBS = $(SCALAPACKLIB) $(FBLACSLIB) $(LAPACKLIB) $(BLASLIB) $(SMPLIB)
-PRLIBS = $(SCALAPACKLIB) $(CBLACSLIB) $(SMPLIB)
-RLIBS = $(SCALAPACKLIB) $(FBLACSLIB) $(CBLACSLIB) $(LAPACKLIB) $(BLASLIB) $(SMPLIB)
-LIBS = $(PBLIBS)
diff --git a/INSTALL/SLmake.I860 b/INSTALL/SLmake.I860
deleted file mode 100644
index fb5b1a4..0000000
--- a/INSTALL/SLmake.I860
+++ /dev/null
@@ -1,102 +0,0 @@
-############################################################################
-#
-# Program: ScaLAPACK
-#
-# Module: SLmake.inc
-#
-# Purpose: Top-level Definitions
-#
-# Creation date: February 15, 2000
-#
-# Modified:
-#
-# Send bug reports, comments or suggestions to scalapack at cs.utk.edu
-#
-############################################################################
-#
-SHELL = /bin/sh
-#
-# The complete path to the top level of ScaLAPACK directory, usually
-# $(HOME)/SCALAPACK
-#
-home = $(HOME)/SCALAPACK
-#
-# The platform identifier to suffix to the end of library names
-#
-PLAT = I860
-#
-# BLACS setup. All version need the debug level (0 or 1),
-# and the directory where the BLACS libraries are
-#
-BLACSDBGLVL = 0
-BLACSdir = $(HOME)/BLACS/LIB
-#
-# MPI setup; uncomment and tailor to your system if using MPIBLACS
-# Will need to comment out the default native BLACS setup below below
-#
-#USEMPI = -DUsingMpiBlacs
-#SMPLIB = $(HOME)/mpich/lib/intelnx/ch_nx/libmpi.a
-#BLACSFINIT = $(BLACSdir)/blacsF77init_MPI-$(PLAT)-$(BLACSDBGLVL).a
-#BLACSCINIT = $(BLACSdir)/blacsCinit_MPI-$(PLAT)-$(BLACSDBGLVL).a
-#BLACSLIB = $(BLACSdir)/blacs_MPI-$(PLAT)-$(BLACSDBGLVL).a
-
-TESTINGdir = $(home)/TESTING
-
-#
-# system primitive NX BLACS setup, comment out if using MPI
-#
-SMPLIB =
-USEMPI =
-BLACSFINIT =
-BLACSCINIT =
-BLACSLIB = $(HOME)/BLACS/LIB/blacs_NX-$(PLAT)-$(BLACSDBGLVL).a
-CBLACSLIB = $(BLACSCINIT) $(BLACSLIB) $(BLACSCINIT)
-FBLACSLIB = $(BLACSFINIT) $(BLACSLIB) $(BLACSFINIT)
-
-#
-# The directories to find the various pieces of ScaLapack
-#
-PBLASdir = $(home)/PBLAS
-SRCdir = $(home)/SRC
-TESTdir = $(home)/TESTING
-PBLASTSTdir = $(PBLASdir)/TESTING
-TOOLSdir = $(home)/TOOLS
-REDISTdir = $(home)/REDIST
-REDISTTSTdir = $(REDISTdir)/TESTING
-#
-# The fortran and C compilers, loaders, and their flags
-#
-F77 = if77
-CC = icc
-NOOPT = -nx
-F77FLAGS = -O4 $(NOOPT)
-DRVOPTS = $(F77FLAGS)
-CCFLAGS = $(F77FLAGS)
-SRCFLAG =
-F77LOADER = $(F77)
-CCLOADER = $(CC)
-F77LOADFLAGS = -nx
-CCLOADFLAGS = -nx
-#
-# C preprocessor defs for compilation
-# (-DNoChange, -DAdd_, -DUpCase, or -Df77IsF2C)
-#
-CDEFS = -DAdd_ $(USEMPI)
-#
-# The archiver and the flag(s) to use when building archive (library)
-# Also the ranlib routine. If your system has no ranlib, set RANLIB = echo
-#
-ARCH = ar860
-ARCHFLAGS = r
-RANLIB = echo
-#
-# The name of the libraries to be created/linked to
-#
-SCALAPACKLIB = $(home)/libscalapack.a
-BLASLIB = -lkmath
-LAPACKLIB =
-#
-PBLIBS = $(SCALAPACKLIB) $(FBLACSLIB) $(LAPACKLIB) $(BLASLIB) $(SMPLIB)
-PRLIBS = $(SCALAPACKLIB) $(CBLACSLIB) $(SMPLIB)
-RLIBS = $(SCALAPACKLIB) $(FBLACSLIB) $(LAPACKLIB) $(CBLACSLIB) $(BLASLIB) $(SMPLIB)
-LIBS = $(PBLIBS)
diff --git a/INSTALL/SLmake.IRIX64 b/INSTALL/SLmake.IRIX64
deleted file mode 100644
index 71a001b..0000000
--- a/INSTALL/SLmake.IRIX64
+++ /dev/null
@@ -1,106 +0,0 @@
-############################################################################
-#
-# Program: ScaLAPACK
-#
-# Module: SLmake.inc
-#
-# Purpose: Top-level Definitions
-#
-# Creation date: March 20, 1995
-#
-# Modified:
-#
-# Send bug reports, comments or suggestions to scalapack at cs.utk.edu
-#
-############################################################################
-#
-SHELL = /bin/sh
-#
-# The complete path to the top level of ScaLAPACK directory, usually
-# $(HOME)/SCALAPACK
-#
-home = $(HOME)/SCALAPACK
-#
-# The platform identifier to suffix to the end of library names
-#
-PLAT = IRIX64
-#
-# BLACS setup. All version need the debug level (0 or 1),
-# and the directory where the BLACS libraries are
-#
-BLACSDBGLVL = 0
-BLACSdir = $(HOME)/BLACS/LIB
-#
-# MPI setup; tailor to your system if using MPIBLACS
-# Will need to comment out these 6 lines if using PVM
-#
-USEMPI = -DUsingMpiBlacs
-#SMPLIB = /usr/local/mpich/lib/libmpich.a
-SMPLIB = -lmpi
-BLACSFINIT = $(BLACSdir)/blacsF77init_MPI-$(PLAT)-$(BLACSDBGLVL).a
-BLACSCINIT = $(BLACSdir)/blacsCinit_MPI-$(PLAT)-$(BLACSDBGLVL).a
-BLACSLIB = $(BLACSdir)/blacs_MPI-$(PLAT)-$(BLACSDBGLVL).a
-TESTINGdir = $(home)/TESTING
-
-#
-# PVMBLACS setup, uncomment next 6 lines if using PVM
-#
-#USEMPI =
-#SMPLIB = $(PVM_ROOT)/lib/$(PLAT)/libpvm3.a
-#BLACSFINIT =
-#BLACSCINIT =
-#BLACSLIB = $(BLACSdir)/blacs_PVM-$(PLAT)-$(BLACSDBGLVL).a
-#TESTINGdir = $(HOME)/pvm3/bin/$(PLAT)
-
-CBLACSLIB = $(BLACSCINIT) $(BLACSLIB) $(BLACSCINIT)
-FBLACSLIB = $(BLACSFINIT) $(BLACSLIB) $(BLACSFINIT)
-
-#
-# The directories to find the various pieces of ScaLapack
-#
-PBLASdir = $(home)/PBLAS
-SRCdir = $(home)/SRC
-TESTdir = $(home)/TESTING
-PBLASTSTdir = $(TESTINGdir)
-TOOLSdir = $(home)/TOOLS
-REDISTdir = $(home)/REDIST
-REDISTTSTdir = $(TESTINGdir)
-#
-# The fortran and C compilers, loaders, and their flags
-#
-F77 = f77
-CC = cc
-NOOPT = -64 -mips4 -r12000
-#NOOPT = -g -DEBUG:subscript_check=ON -trapuv
-F77FLAGS = -O3 $(NOOPT)
-#F77FLAGS = $(NOOPT)
-DRVOPTS = $(F77FLAGS) -static
-CCFLAGS = $(F77FLAGS)
-SRCFLAG =
-F77LOADER = $(F77)
-CCLOADER = $(CC)
-F77LOADFLAGS = $(F77FLAGS)
-CCLOADFLAGS = $(CCFLAGS)
-#
-# C preprocessor defs for compilation
-# (-DNoChange, -DAdd_, -DUpCase, or -Df77IsF2C)
-#
-CDEFS = -DAdd_ $(USEMPI)
-#
-# The archiver and the flag(s) to use when building archive (library)
-# Also the ranlib routine. If your system has no ranlib, set RANLIB = echo
-#
-ARCH = ar
-ARCHFLAGS = cr
-RANLIB = echo
-#
-# The name of the libraries to be created/linked to
-#
-SCALAPACKLIB = $(home)/libscalapack.a
-BLASLIB = -lblas
-LAPACKLIB = -llapack
-#
-PBLIBS = $(SCALAPACKLIB) $(FBLACSLIB) $(LAPACKLIB) $(BLASLIB) $(SMPLIB)
-PRLIBS = $(SCALAPACKLIB) $(CBLACSLIB) $(SMPLIB)
-RLIBS = $(SCALAPACKLIB) $(FBLACSLIB) $(CBLACSLIB) $(LAPACKLIB) $(BLASLIB) $(SMPLIB)
-LIBS = $(PBLIBS)
diff --git a/INSTALL/SLmake.LINUX b/INSTALL/SLmake.LINUX
deleted file mode 100644
index d20b21e..0000000
--- a/INSTALL/SLmake.LINUX
+++ /dev/null
@@ -1,103 +0,0 @@
-############################################################################
-#
-# Program: ScaLAPACK
-#
-# Module: SLmake.inc
-#
-# Purpose: Top-level Definitions
-#
-# Creation date: February 15, 2000
-#
-# Modified:
-#
-# Send bug reports, comments or suggestions to scalapack at cs.utk.edu
-#
-############################################################################
-#
-SHELL = /bin/sh
-#
-# The complete path to the top level of ScaLAPACK directory, usually
-# $(HOME)/SCALAPACK
-#
-home = $(HOME)/SCALAPACK
-#
-# The platform identifier to suffix to the end of library names
-#
-PLAT = LINUX
-#
-# BLACS setup. All version need the debug level (0 or 1),
-# and the directory where the BLACS libraries are
-#
-BLACSDBGLVL = 0
-BLACSdir = $(HOME)/BLACS/LIB
-#
-# MPI setup; tailor to your system if using MPIBLACS
-# Will need to comment out these 6 lines if using PVM
-#
-USEMPI = -DUsingMpiBlacs
-SMPLIB = /usr/lib/mpi/build/LINUX/ch_p4/lib/libmpich.a
-BLACSFINIT = $(BLACSdir)/blacsF77init_MPI-$(PLAT)-$(BLACSDBGLVL).a
-BLACSCINIT = $(BLACSdir)/blacsCinit_MPI-$(PLAT)-$(BLACSDBGLVL).a
-BLACSLIB = $(BLACSdir)/blacs_MPI-$(PLAT)-$(BLACSDBGLVL).a
-TESTINGdir = $(home)/TESTING
-
-#
-# PVMBLACS setup, uncomment next 6 lines if using PVM
-#
-#USEMPI =
-#SMPLIB = $(PVM_ROOT)/lib/$(PLAT)/libpvm3.a
-#BLACSFINIT =
-#BLACSCINIT =
-#BLACSLIB = $(BLACSdir)/blacs_PVM-$(PLAT)-$(BLACSDBGLVL).a
-#TESTINGdir = $(HOME)/pvm3/bin/$(PLAT)
-
-CBLACSLIB = $(BLACSCINIT) $(BLACSLIB) $(BLACSCINIT)
-FBLACSLIB = $(BLACSFINIT) $(BLACSLIB) $(BLACSFINIT)
-
-#
-# The directories to find the various pieces of ScaLapack
-#
-PBLASdir = $(home)/PBLAS
-SRCdir = $(home)/SRC
-TESTdir = $(home)/TESTING
-PBLASTSTdir = $(TESTINGdir)
-TOOLSdir = $(home)/TOOLS
-REDISTdir = $(home)/REDIST
-REDISTTSTdir = $(TESTINGdir)
-#
-# The fortran and C compilers, loaders, and their flags
-#
-F77 = mpif77
-CC = mpicc
-NOOPT =
-F77FLAGS = -funroll-all-loops -O3 $(NOOPT)
-DRVOPTS = $(F77FLAGS)
-CCFLAGS = -O4
-SRCFLAG =
-F77LOADER = $(F77)
-CCLOADER = $(CC)
-F77LOADFLAGS =
-CCLOADFLAGS =
-#
-# C preprocessor defs for compilation
-# (-DNoChange, -DAdd_, -DUpCase, or -Df77IsF2C)
-#
-CDEFS = -Df77IsF2C -DNO_IEEE $(USEMPI)
-#
-# The archiver and the flag(s) to use when building archive (library)
-# Also the ranlib routine. If your system has no ranlib, set RANLIB = echo
-#
-ARCH = ar
-ARCHFLAGS = cr
-RANLIB = ranlib
-#
-# The name of the libraries to be created/linked to
-#
-SCALAPACKLIB = $(home)/libscalapack.a
-BLASLIB = /usr/lib/libblas.a
-LAPACKLIB = /usr/lib/liblapack.a
-#
-PBLIBS = $(SCALAPACKLIB) $(FBLACSLIB) $(LAPACKLIB) $(BLASLIB) $(SMPLIB)
-PRLIBS = $(SCALAPACKLIB) $(CBLACSLIB) $(SMPLIB)
-RLIBS = $(SCALAPACKLIB) $(FBLACSLIB) $(CBLACSLIB) $(LAPACKLIB) $(BLASLIB) $(SMPLIB)
-LIBS = $(PBLIBS)
diff --git a/INSTALL/SLmake.O2K b/INSTALL/SLmake.O2K
deleted file mode 100644
index 840ee23..0000000
--- a/INSTALL/SLmake.O2K
+++ /dev/null
@@ -1,104 +0,0 @@
-############################################################################
-#
-# Program: ScaLAPACK
-#
-# Module: SLmake.inc
-#
-# Purpose: Top-level Definitions
-#
-# Creation date: February 15, 2000
-#
-# Modified:
-#
-# Send bug reports, comments or suggestions to scalapack at cs.utk.edu
-#
-############################################################################
-#
-SHELL = /bin/sh
-#
-# The complete path to the top level of ScaLAPACK directory, usually
-# $(HOME)/SCALAPACK
-#
-home = $(HOME)/SCALAPACK
-#
-# The platform identifier to suffix to the end of library names
-#
-PLAT = O2K
-#
-# BLACS setup. All version need the debug level (0 or 1),
-# and the directory where the BLACS libraries are
-#
-BLACSDBGLVL = 0
-BLACSdir = $(HOME)/BLACS/LIB
-#
-# MPI setup; tailor to your system if using MPIBLACS
-# Will need to comment out these 6 lines if using PVM
-#
-USEMPI = -DUsingMpiBlacs
-SMPLIB = -lmpi
-BLACSFINIT = $(BLACSdir)/blacsF77init_MPI-$(PLAT)-$(BLACSDBGLVL).a
-BLACSCINIT = $(BLACSdir)/blacsCinit_MPI-$(PLAT)-$(BLACSDBGLVL).a
-BLACSLIB = $(BLACSdir)/blacs_MPI-$(PLAT)-$(BLACSDBGLVL).a
-TESTINGdir = $(home)/TESTING
-
-#
-# PVMBLACS setup, uncomment next 6 lines if using PVM
-#
-#USEMPI =
-#SMPLIB = $(PVM_ROOT)/lib/$(PLAT)/libpvm3.a
-#BLACSFINIT =
-#BLACSCINIT =
-#BLACSLIB = $(BLACSdir)/blacs_PVM-$(PLAT)-$(BLACSDBGLVL).a
-#TESTINGdir = $(HOME)/pvm3/bin/$(PLAT)
-
-CBLACSLIB = $(BLACSCINIT) $(BLACSLIB) $(BLACSCINIT)
-FBLACSLIB = $(BLACSFINIT) $(BLACSLIB) $(BLACSFINIT)
-
-#
-# The directories to find the various pieces of ScaLapack
-#
-PBLASdir = $(home)/PBLAS
-SRCdir = $(home)/SRC
-TESTdir = $(home)/TESTING
-PBLASTSTdir = $(TESTINGdir)
-TOOLSdir = $(home)/TOOLS
-REDISTdir = $(home)/REDIST
-REDISTTSTdir = $(TESTINGdir)
-#
-# The fortran and C compilers, loaders, and their flags
-#
-F77 = f77
-CC = cc
-NOOPT = -64 -mips4 -r12000
-#NOOPT = -n32 -mips4 -r12000
-F77FLAGS = -O2 $(NOOPT)
-DRVOPTS = $(F77FLAGS) -static
-CCFLAGS = $(F77FLAGS)
-SRCFLAG =
-F77LOADER = $(F77)
-CCLOADER = $(CC)
-F77LOADFLAGS = $(F77FLAGS)
-CCLOADFLAGS = $(CCFLAGS)
-#
-# C preprocessor defs for compilation
-# (-DNoChange, -DAdd_, -DUpCase, or -Df77IsF2C)
-#
-CDEFS = -DAdd_ $(USEMPI)
-#
-# The archiver and the flag(s) to use when building archive (library)
-# Also the ranlib routine. If your system has no ranlib, set RANLIB = echo
-#
-ARCH = ar
-ARCHFLAGS = cr
-RANLIB = echo
-#
-# The name of the libraries to be created/linked to
-#
-SCALAPACKLIB = $(home)/libscalapack.a
-BLASLIB = -lblas
-LAPACKLIB = -llapack
-#
-PBLIBS = $(SCALAPACKLIB) $(FBLACSLIB) $(LAPACKLIB) $(BLASLIB) $(SMPLIB)
-PRLIBS = $(SCALAPACKLIB) $(CBLACSLIB) $(SMPLIB)
-RLIBS = $(SCALAPACKLIB) $(FBLACSLIB) $(CBLACSLIB) $(LAPACKLIB) $(BLASLIB) $(SMPLIB)
-LIBS = $(PBLIBS)
diff --git a/INSTALL/SLmake.PCA b/INSTALL/SLmake.PCA
deleted file mode 100644
index 7cb4716..0000000
--- a/INSTALL/SLmake.PCA
+++ /dev/null
@@ -1,104 +0,0 @@
-############################################################################
-#
-# Program: ScaLAPACK
-#
-# Module: SLmake.inc
-#
-# Purpose: Top-level Definitions
-#
-# Creation date: February 15, 2000
-#
-# Modified:
-#
-# Send bug reports, comments or suggestions to scalapack at cs.utk.edu
-#
-############################################################################
-#
-SHELL = /bin/sh
-#
-# The complete path to the top level of ScaLAPACK directory, usually
-# $(HOME)/SCALAPACK
-#
-home = $(HOME)/SCALAPACK
-#
-# The platform identifier to suffix to the end of library names
-#
-PLAT = PCA
-#
-# BLACS setup. All version need the debug level (0 or 1),
-# and the directory where the BLACS libraries are
-#
-BLACSDBGLVL = 0
-BLACSdir = $(HOME)/BLACS/LIB
-#
-# MPI setup; tailor to your system if using MPIBLACS
-# Will need to comment out these 6 lines if using PVM
-#
-USEMPI = -DUsingMpiBlacs
-SMPLIB = -lmpi
-BLACSFINIT = $(BLACSdir)/blacsF77init_MPI-$(PLAT)-$(BLACSDBGLVL).a
-BLACSCINIT = $(BLACSdir)/blacsCinit_MPI-$(PLAT)-$(BLACSDBGLVL).a
-BLACSLIB = $(BLACSdir)/blacs_MPI-$(PLAT)-$(BLACSDBGLVL).a
-TESTINGdir = $(home)/TESTING
-
-#
-# PVMBLACS setup, uncomment the next 6 lines if using PVM
-#
-#USEMPI =
-#SMPLIB = $(PVM_ROOT)/lib/$(PLAT)/libpvm3.a
-#BLACSFINIT =
-#BLACSCINIT =
-#BLACSLIB = $(BLACSdir)/blacs_PVM-$(PLAT)-$(BLACSDBGLVL).a
-#TESTINGdir = $(HOME)/pvm3/bin/$(PLAT)
-
-CBLACSLIB = $(BLACSCINIT) $(BLACSLIB) $(BLACSCINIT)
-FBLACSLIB = $(BLACSFINIT) $(BLACSLIB) $(BLACSFINIT)
-
-#
-# The directories to find the various pieces of ScaLapack
-#
-PBLASdir = $(home)/PBLAS
-SRCdir = $(home)/SRC
-TESTdir = $(home)/TESTING
-PBLASTSTdir = $(TESTINGdir)
-TOOLSdir = $(home)/TOOLS
-REDISTdir = $(home)/REDIST
-REDISTTSTdir = $(TESTINGdir)
-#
-# The fortran and C compilers, loaders, and their flags
-#
-F77 = f77
-CC = cc
-NOOPT = -64 -mips4 -r8000
-#NOOPT = -n32 -mips4 -r8000
-F77FLAGS = -O2 $(NOOPT)
-DRVOPTS = $(F77FLAGS) -static
-CCFLAGS = $(F77FLAGS)
-SRCFLAG =
-F77LOADER = $(F77)
-CCLOADER = $(CC)
-F77LOADFLAGS = $(F77FLAGS)
-CCLOADFLAGS = $(CCFLAGS)
-#
-# C preprocessor defs for compilation
-# (-DNoChange, -DAdd_, -DUpCase, or -Df77IsF2C)
-#
-CDEFS = -DAdd_ $(USEMPI)
-#
-# The archiver and the flag(s) to use when building archive (library)
-# Also the ranlib routine. If your system has no ranlib, set RANLIB = echo
-#
-ARCH = ar
-ARCHFLAGS = cr
-RANLIB = echo
-#
-# The name of the libraries to be created/linked to
-#
-SCALAPACKLIB = $(home)/libscalapack.a
-BLASLIB = -lblas
-LAPACKLIB = =llapack
-#
-PBLIBS = $(SCALAPACKLIB) $(FBLACSLIB) $(LAPACKLIB) $(BLASLIB) $(SMPLIB)
-PRLIBS = $(SCALAPACKLIB) $(CBLACSLIB) $(SMPLIB)
-RLIBS = $(SCALAPACKLIB) $(FBLACSLIB) $(CBLACSLIB) $(LAPACKLIB) $(BLASLIB) $(SMPLIB)
-LIBS = $(PBLIBS)
diff --git a/INSTALL/SLmake.PGON b/INSTALL/SLmake.PGON
deleted file mode 100644
index f0920dc..0000000
--- a/INSTALL/SLmake.PGON
+++ /dev/null
@@ -1,102 +0,0 @@
-############################################################################
-#
-# Program: ScaLAPACK
-#
-# Module: SLmake.inc
-#
-# Purpose: Top-level Definitions
-#
-# Creation date: February 15, 2000
-#
-# Modified:
-#
-# Send bug reports, comments or suggestions to scalapack at cs.utk.edu
-#
-############################################################################
-#
-SHELL = /bin/sh
-#
-# The complete path to the top level of ScaLAPACK directory, usually
-# $(HOME)/SCALAPACK
-#
-home = $(HOME)/SCALAPACK
-#
-# The platform identifier to suffix to the end of library names
-#
-PLAT = PGON
-#
-# BLACS setup. All version need the debug level (0 or 1),
-# and the directory where the BLACS libraries are
-#
-BLACSDBGLVL = 0
-BLACSdir = $(HOME)/BLACS/LIB
-#
-# MPI setup; uncomment and tailor to your system if using MPIBLACS
-# Will need to comment out the default native BLACS setup below below
-#
-#USEMPI = -DUsingMpiBlacs
-#SMPLIB = @(MPIdir)/libmpi.a
-#BLACSFINIT = $(BLACSdir)/blacsF77init_MPI-$(PLAT)-$(BLACSDBGLVL).a
-#BLACSCINIT = $(BLACSdir)/blacsCinit_MPI-$(PLAT)-$(BLACSDBGLVL).a
-#BLACSLIB = $(BLACSdir)/blacs_MPI-$(PLAT)-$(BLACSDBGLVL).a
-
-TESTINGdir = $(home)/TESTING
-
-#
-# system primitive NX BLACS setup, comment out if using MPI
-#
-SMPLIB =
-USEMPI =
-BLACSFINIT =
-BLACSCINIT =
-BLACSLIB = $(HOME)/BLACS/LIB/blacs_NX-$(PLAT)-$(BLACSDBGLVL).a
-CBLACSLIB = $(BLACSCINIT) $(BLACSLIB) $(BLACSCINIT)
-FBLACSLIB = $(BLACSFINIT) $(BLACSLIB) $(BLACSFINIT)
-
-#
-# The directories to find the various pieces of ScaLapack
-#
-PBLASdir = $(home)/PBLAS
-SRCdir = $(home)/SRC
-TESTdir = $(home)/TESTING
-PBLASTSTdir = $(PBLASdir)/TESTING
-TOOLSdir = $(home)/TOOLS
-REDISTdir = $(home)/REDIST
-REDISTTSTdir = $(REDISTdir)/TESTING
-#
-# The fortran and C compilers, loaders, and their flags
-#
-F77 = if77
-CC = icc
-NOOPT = -nx
-F77FLAGS = -O4 $(NOOPT)
-DRVOPTS = $(F77FLAGS)
-CCFLAGS = $(F77FLAGS)
-SRCFLAG =
-F77LOADER = $(F77)
-CCLOADER = $(CC)
-F77LOADFLAGS = -nx
-CCLOADFLAGS = -nx
-#
-# C preprocessor defs for compilation
-# (-DNoChange, -DAdd_, -DUpCase, or -Df77IsF2C)
-#
-CDEFS = -DAdd_ $(USEMPI)
-#
-# The archiver and the flag(s) to use when building archive (library)
-# Also the ranlib routine. If your system has no ranlib, set RANLIB = echo
-#
-ARCH = ar860
-ARCHFLAGS = r
-RANLIB = echo
-#
-# The name of the libraries to be created/linked to
-#
-SCALAPACKLIB = $(home)/libscalapack.a
-BLASLIB = -lkmath
-LAPACKLIB =
-#
-PBLIBS = $(SCALAPACKLIB) $(FBLACSLIB) $(LAPACKLIB) $(BLASLIB) $(SMPLIB)
-PRLIBS = $(SCALAPACKLIB) $(CBLACSLIB) $(SMPLIB)
-RLIBS = $(SCALAPACKLIB) $(FBLACSLIB) $(CBLACSLIB) $(LAPACKLIB) $(BLASLIB) $(SMPLIB)
-LIBS = $(PBLIBS)
diff --git a/INSTALL/SLmake.POWER2 b/INSTALL/SLmake.POWER2
deleted file mode 100644
index 3d815a2..0000000
--- a/INSTALL/SLmake.POWER2
+++ /dev/null
@@ -1,103 +0,0 @@
-############################################################################
-#
-# Program: ScaLAPACK
-#
-# Module: SLmake.inc
-#
-# Purpose: Top-level Definitions
-#
-# Creation date: February 15, 2000
-#
-# Modified:
-#
-# Send bug reports, comments or suggestions to scalapack at cs.utk.edu
-#
-############################################################################
-#
-SHELL = /bin/sh
-#
-# The complete path to the top level of ScaLAPACK directory, usually
-# $(HOME)/SCALAPACK
-#
-home = $(HOME)/SCALAPACK
-#
-# The platform identifier to suffix to the end of library names
-#
-PLAT = POWER2
-#
-# BLACS setup. All version need the debug level (0 or 1),
-# and the directory where the BLACS libraries are
-#
-BLACSDBGLVL = 0
-BLACSdir = $(HOME)/BLACS/LIB
-#
-# MPI setup; tailor to your system if using MPIBLACS
-# Will need to comment out these 6 lines if using PVM
-#
-USEMPI = -DUsingMpiBlacs
-SMPLIB =
-BLACSFINIT = $(BLACSdir)/blacsF77init_MPI-$(PLAT)-$(BLACSDBGLVL).a
-BLACSCINIT = $(BLACSdir)/blacsCinit_MPI-$(PLAT)-$(BLACSDBGLVL).a
-BLACSLIB = $(BLACSdir)/blacs_MPI-$(PLAT)-$(BLACSDBGLVL).a
-TESTINGdir = $(home)/TESTING
-
-#
-# PVMBLACS setup, comment out next 6 lines if using MPI
-#
-#USEMPI =
-#SMPLIB = $(PVM_ROOT)/lib/$(PLAT)/libpvm3.a
-#BLACSFINIT =
-#BLACSCINIT =
-#BLACSLIB = $(BLACSdir)/blacs_PVM-$(PLAT)-$(BLACSDBGLVL).a
-#TESTINGdir = $(HOME)/pvm3/bin/$(PLAT)
-
-CBLACSLIB = $(BLACSCINIT) $(BLACSLIB) $(BLACSCINIT)
-FBLACSLIB = $(BLACSFINIT) $(BLACSLIB) $(BLACSFINIT)
-
-#
-# The directories to find the various pieces of ScaLapack
-#
-PBLASdir = $(home)/PBLAS
-SRCdir = $(home)/SRC
-TESTdir = $(home)/TESTING
-PBLASTSTdir = $(TESTINGdir)
-TOOLSdir = $(home)/TOOLS
-REDISTdir = $(home)/REDIST
-REDISTTSTdir = $(TESTINGdir)
-#
-# The fortran and C compilers, loaders, and their flags
-#
-F77 = xlf
-CC = xlc
-NOOPT =
-F77FLAGS = -O3 -qarch=pwr2 -qtune=pwr2 -qmaxmem=-1 $(NOOPT)
-DRVOPTS = $(F77FLAGS)
-CCFLAGS = $(F77FLAGS)
-SRCFLAG = -qnoansialias
-F77LOADER = $(F77)
-CCLOADER = $(CC)
-F77LOADFLAGS =
-CCLOADFLAGS =
-#
-# C preprocessor defs for compilation
-# (-DNoChange, -DAdd_, -DUpCase, or -Df77IsF2C)
-#
-CDEFS = -DNoChange $(USEMPI)
-#
-# The archiver and the flag(s) to use when building archive (library)
-# Also the ranlib routine. If your system has no ranlib, set RANLIB = echo
-#
-ARCH = ar
-ARCHFLAGS = cr
-RANLIB = ranlib
-#
-# The name of the libraries to be created/linked to
-#
-SCALAPACKLIB = $(home)/libscalapack.a
-BLASLIB = -lesslp2
-LAPACKLIB =
-#
-PBLIBS = $(SCALAPACKLIB) $(FBLACSLIB) $(LAPACKLIB) $(BLASLIB) $(SMPLIB)
-PRLIBS = $(SCALAPACKLIB) $(CBLACSLIB) $(SMPLIB)
-RLIBS = $(SCALAPACKLIB) $(FBLACSLIB) $(CBLACSLIB) $(LAPACKLIB) $(BLASLIB) $(SMPLIB)
-LIBS = $(PBLIBS)
diff --git a/INSTALL/SLmake.POWER3 b/INSTALL/SLmake.POWER3
deleted file mode 100644
index ed290d6..0000000
--- a/INSTALL/SLmake.POWER3
+++ /dev/null
@@ -1,103 +0,0 @@
-############################################################################
-#
-# Program: ScaLAPACK
-#
-# Module: SLmake.inc
-#
-# Purpose: Top-level Definitions
-#
-# Creation date: February 15, 2000
-#
-# Modified:
-#
-# Send bug reports, comments or suggestions to scalapack at cs.utk.edu
-#
-############################################################################
-#
-SHELL = /bin/sh
-#
-# The complete path to the top level of ScaLAPACK directory, usually
-# $(HOME)/SCALAPACK
-#
-home = $(HOME)/SCALAPACK
-#
-# The platform identifier to suffix to the end of library names
-#
-PLAT = POWER3
-#
-# BLACS setup. All version need the debug level (0 or 1),
-# and the directory where the BLACS libraries are
-#
-BLACSDBGLVL = 0
-BLACSdir = $(HOME)/BLACS/LIB
-#
-# MPI setup; tailor to your system if using MPIBLACS
-# Will need to comment out these 6 lines if using PVM
-#
-USEMPI = -DUsingMpiBlacs
-SMPLIB =
-BLACSFINIT = $(BLACSdir)/blacsF77init_MPI-$(PLAT)-$(BLACSDBGLVL).a
-BLACSCINIT = $(BLACSdir)/blacsCinit_MPI-$(PLAT)-$(BLACSDBGLVL).a
-BLACSLIB = $(BLACSdir)/blacs_MPI-$(PLAT)-$(BLACSDBGLVL).a
-TESTINGdir = $(home)/TESTING
-
-#
-# PVMBLACS setup, comment out next 6 lines if using MPI
-#
-#USEMPI =
-#SMPLIB = $(PVM_ROOT)/lib/$(PLAT)/libpvm3.a
-#BLACSFINIT =
-#BLACSCINIT =
-#BLACSLIB = $(BLACSdir)/blacs_PVM-$(PLAT)-$(BLACSDBGLVL).a
-#TESTINGdir = $(HOME)/pvm3/bin/$(PLAT)
-
-CBLACSLIB = $(BLACSCINIT) $(BLACSLIB) $(BLACSCINIT)
-FBLACSLIB = $(BLACSFINIT) $(BLACSLIB) $(BLACSFINIT)
-
-#
-# The directories to find the various pieces of ScaLapack
-#
-PBLASdir = $(home)/PBLAS
-SRCdir = $(home)/SRC
-TESTdir = $(home)/TESTING
-PBLASTSTdir = $(TESTINGdir)
-TOOLSdir = $(home)/TOOLS
-REDISTdir = $(home)/REDIST
-REDISTTSTdir = $(TESTINGdir)
-#
-# The fortran and C compilers, loaders, and their flags
-#
-F77 = xlf
-CC = xlc
-NOOPT =
-F77FLAGS = -O3 -qarch=pwr3 -qtune=pwr3 -qmaxmem=-1 $(NOOPT)
-DRVOPTS = $(F77FLAGS)
-CCFLAGS = $(F77FLAGS)
-SRCFLAG = -qnoansialias
-F77LOADER = $(F77)
-CCLOADER = $(CC)
-F77LOADFLAGS =
-CCLOADFLAGS =
-#
-# C preprocessor defs for compilation
-# (-DNoChange, -DAdd_, -DUpCase, or -Df77IsF2C)
-#
-CDEFS = -DNoChange $(USEMPI)
-#
-# The archiver and the flag(s) to use when building archive (library)
-# Also the ranlib routine. If your system has no ranlib, set RANLIB = echo
-#
-ARCH = ar
-ARCHFLAGS = cr
-RANLIB = ranlib
-#
-# The name of the libraries to be created/linked to
-#
-SCALAPACKLIB = $(home)/libscalapack.a
-BLASLIB = -lessl
-LAPACKLIB =
-#
-PBLIBS = $(SCALAPACKLIB) $(FBLACSLIB) $(LAPACKLIB) $(BLASLIB) $(SMPLIB)
-PRLIBS = $(SCALAPACKLIB) $(CBLACSLIB) $(SMPLIB)
-RLIBS = $(SCALAPACKLIB) $(FBLACSLIB) $(CBLACSLIB) $(LAPACKLIB) $(BLASLIB) $(SMPLIB)
-LIBS = $(PBLIBS)
diff --git a/INSTALL/SLmake.RS6K b/INSTALL/SLmake.RS6K
deleted file mode 100644
index 1ff509c..0000000
--- a/INSTALL/SLmake.RS6K
+++ /dev/null
@@ -1,103 +0,0 @@
-############################################################################
-#
-# Program: ScaLAPACK
-#
-# Module: SLmake.inc
-#
-# Purpose: Top-level Definitions
-#
-# Creation date: February 15, 2000
-#
-# Modified:
-#
-# Send bug reports, comments or suggestions to scalapack at cs.utk.edu
-#
-############################################################################
-#
-SHELL = /bin/sh
-#
-# The complete path to the top level of ScaLAPACK directory, usually
-# $(HOME)/SCALAPACK
-#
-home = $(HOME)/SCALAPACK
-#
-# The platform identifier to suffix to the end of library names
-#
-PLAT = RS6K
-#
-# BLACS setup. All version need the debug level (0 or 1),
-# and the directory where the BLACS libraries are
-#
-BLACSDBGLVL = 0
-BLACSdir = /usr/local/lib
-#
-# MPI setup; tailor to your system if using MPIBLACS
-# Will need to comment out these 6 lines if using PVM
-#
-USEMPI = -DUsingMpiBlacs
-SMPLIB = /usr/local/mpich/lib/libmpich.a
-BLACSFINIT = $(BLACSdir)/blacsF77init_MPI-$(PLAT)-$(BLACSDBGLVL).a
-BLACSCINIT = $(BLACSdir)/blacsCinit_MPI-$(PLAT)-$(BLACSDBGLVL).a
-BLACSLIB = $(BLACSdir)/blacs_MPI-$(PLAT)-$(BLACSDBGLVL).a
-TESTINGdir = $(home)/TESTING
-
-#
-# PVMBLACS setup, comment out next 6 lines if using MPI
-#
-#USEMPI =
-#SMPLIB = $(PVM_ROOT)/lib/$(PLAT)/libpvm3.a
-#BLACSFINIT =
-#BLACSCINIT =
-#BLACSLIB = $(BLACSdir)/blacs_PVM-$(PLAT)-$(BLACSDBGLVL).a
-#TESTINGdir = $(HOME)/pvm3/bin/$(PLAT)
-
-CBLACSLIB = $(BLACSCINIT) $(BLACSLIB) $(BLACSCINIT)
-FBLACSLIB = $(BLACSFINIT) $(BLACSLIB) $(BLACSFINIT)
-
-#
-# The directories to find the various pieces of ScaLapack
-#
-PBLASdir = $(home)/PBLAS
-SRCdir = $(home)/SRC
-TESTdir = $(home)/TESTING
-PBLASTSTdir = $(TESTINGdir)
-TOOLSdir = $(home)/TOOLS
-REDISTdir = $(home)/REDIST
-REDISTTSTdir = $(TESTINGdir)
-#
-# The fortran and C compilers, loaders, and their flags
-#
-F77 = xlf
-CC = xlc
-NOOPT =
-F77FLAGS = -O3 $(NOOPT) -qarch=pwr3 -qmaxmem=-1
-DRVOPTS = $(F77FLAGS)
-CCFLAGS = $(F77FLAGS)
-SRCFLAG = -qnoansialias
-F77LOADER = $(F77)
-CCLOADER = $(CC)
-F77LOADFLAGS =
-CCLOADFLAGS =
-#
-# C preprocessor defs for compilation
-# (-DNoChange, -DAdd_, -DUpCase, or -Df77IsF2C)
-#
-CDEFS = -DNoChange $(USEMPI)
-#
-# The archiver and the flag(s) to use when building archive (library)
-# Also the ranlib routine. If your system has no ranlib, set RANLIB = echo
-#
-ARCH = ar
-ARCHFLAGS = cr
-RANLIB = ranlib
-#
-# The name of the libraries to be created/linked to
-#
-SCALAPACKLIB = $(home)/libscalapack.a
-BLASLIB = -lessl
-LAPACKLIB =
-#
-PBLIBS = $(SCALAPACKLIB) $(FBLACSLIB) $(LAPACKLIB) $(BLASLIB) $(SMPLIB)
-PRLIBS = $(SCALAPACKLIB) $(CBLACSLIB) $(SMPLIB)
-RLIBS = $(SCALAPACKLIB) $(FBLACSLIB) $(CBLACSLIB) $(LAPACKLIB) $(BLASLIB) $(SMPLIB)
-LIBS = $(PBLIBS)
diff --git a/INSTALL/SLmake.SP2 b/INSTALL/SLmake.SP2
deleted file mode 100644
index 87041e9..0000000
--- a/INSTALL/SLmake.SP2
+++ /dev/null
@@ -1,102 +0,0 @@
-############################################################################
-#
-# Program: ScaLAPACK
-#
-# Module: SLmake.inc
-#
-# Purpose: Top-level Definitions
-#
-# Creation date: February 15, 2000
-#
-# Modified:
-#
-# Send bug reports, comments or suggestions to scalapack at cs.utk.edu
-#
-############################################################################
-#
-SHELL = /bin/sh
-#
-# The complete path to the top level of ScaLAPACK directory, usually
-# $(HOME)/SCALAPACK
-#
-home = $(HOME)/SCALAPACK
-#
-# The platform identifier to suffix to the end of library names
-#
-PLAT = SP2
-#
-# BLACS setup. All version need the debug level (0 or 1),
-# and the directory where the BLACS libraries are
-#
-BLACSDBGLVL = 0
-BLACSdir = $(HOME)/BLACS/LIB
-#
-# MPI setup; tailor to your system if using MPIBLACS
-# Will need to comment out these 6 lines if using MPL
-#
-USEMPI = -DUsingMpiBlacs
-SMPLIB =
-BLACSFINIT = $(BLACSdir)/blacsF77init_MPI-$(PLAT)-$(BLACSDBGLVL).a
-BLACSCINIT = $(BLACSdir)/blacsCinit_MPI-$(PLAT)-$(BLACSDBGLVL).a
-BLACSLIB = $(BLACSdir)/blacs_MPI-$(PLAT)-$(BLACSDBGLVL).a
-
-TESTINGdir = $(home)/TESTING
-
-#
-# system primitive MPL BLACS setup, uncomment next 6 lines if using MPL
-#
-#SMPLIB =
-#USEMPI =
-#BLACSFINIT =
-#BLACSCINIT =
-#BLACSLIB = $(HOME)/BLACS/LIB/blacs_MPL-$(PLAT)-$(BLACSDBGLVL).a
-#CBLACSLIB = $(BLACSCINIT) $(BLACSLIB) $(BLACSCINIT)
-#FBLACSLIB = $(BLACSFINIT) $(BLACSLIB) $(BLACSFINIT)
-
-#
-# The directories to find the various pieces of ScaLapack
-#
-PBLASdir = $(home)/PBLAS
-SRCdir = $(home)/SRC
-TESTdir = $(home)/TESTING
-PBLASTSTdir = $(PBLASdir)/TESTING
-TOOLSdir = $(home)/TOOLS
-REDISTdir = $(home)/REDIST
-REDISTTSTdir = $(REDISTdir)/TESTING
-#
-# The fortran and C compilers, loaders, and their flags
-#
-F77 = mpxlf
-CC = mpcc
-NOOPT = -qarch=pwr2 -qtune=pwr2 -qmaxmem=-1
-F77FLAGS = -O3 $(NOOPT)
-DRVOPTS = $(F77FLAGS)
-CCFLAGS = $(F77FLAGS)
-SRCFLAG =
-F77LOADER = $(F77)
-CCLOADER = $(CC)
-F77LOADFLAGS = $(F77FLAGS)
-CCLOADFLAGS = $(F77FLAGS)
-#
-# C preprocessor defs for compilation
-# (-DNoChange, -DAdd_, -DUpCase, or -Df77IsF2C)
-#
-CDEFS = -DNoChange $(USEMPI)
-#
-# The archiver and the flag(s) to use when building archive (library)
-# Also the ranlib routine. If your system has no ranlib, set RANLIB = echo
-#
-ARCH = ar
-ARCHFLAGS = cr
-RANLIB = ranlib
-#
-# The name of the libraries to be created/linked to
-#
-SCALAPACKLIB = $(home)/libscalapack.a
-BLASLIB = -lesslp2
-LAPACKLIB =
-#
-PBLIBS = $(SCALAPACKLIB) $(FBLACSLIB) $(LAPACKLIB) $(BLASLIB) $(SMPLIB)
-PRLIBS = $(SCALAPACKLIB) $(CBLACSLIB) $(SMPLIB)
-RLIBS = $(SCALAPACKLIB) $(FBLACSLIB) $(CBLACSLIB) $(LAPACKLIB) $(BLASLIB) $(SMPLIB)
-LIBS = $(PBLIBS)
diff --git a/INSTALL/SLmake.SUN4SOL2 b/INSTALL/SLmake.SUN4SOL2
deleted file mode 100644
index b6c2247..0000000
--- a/INSTALL/SLmake.SUN4SOL2
+++ /dev/null
@@ -1,106 +0,0 @@
-############################################################################
-#
-# Program: ScaLAPACK
-#
-# Module: SLmake.inc
-#
-# Purpose: Top-level Definitions
-#
-# Creation date: February 15, 2000
-#
-# Modified:
-#
-# Send bug reports, comments or suggestions to scalapack at cs.utk.edu
-#
-############################################################################
-#
-SHELL = /bin/sh
-#
-# The complete path to the top level of ScaLAPACK directory, usually
-# $(HOME)/SCALAPACK
-#
-home = $(HOME)/SCALAPACK
-#
-# The platform identifier to suffix to the end of library names
-#
-PLAT = SUN4SOL2
-#
-# BLACS setup. All version need the debug level (0 or 1),
-# and the directory where the BLACS libraries are
-#
-BLACSDBGLVL = 0
-BLACSdir = /usr/local/lib
-#
-# MPI setup; tailor to your system if using MPIBLACS
-# Will need to comment out these 6 lines if using PVM
-#
-USEMPI = -DUsingMpiBlacs
-SMPLIB = /usr/local/mpich/lib/libmpich.a -lnsl -lsocket
-BLACSFINIT = $(BLACSdir)/libmpiblacsF77init-p4.a
-BLACSCINIT = $(BLACSdir)/libmpiblacsCinit-p4.a
-BLACSLIB = $(BLACSdir)/libmpiblacs-p4.a
-TESTINGdir = $(home)/TESTING
-
-#
-# PVMBLACS setup, uncomment next 6 lines if using PVM
-#
-#USEMPI =
-#SMPLIB = $(PVM_ROOT)/lib/$(PLAT)/libpvm3.a -lnsl -lsocket
-#BLACSFINIT =
-#BLACSCINIT =
-#BLACSLIB = $(BLACSdir)/blacs_PVM-$(PLAT)-$(BLACSDBGLVL).a
-#TESTINGdir = $(HOME)/pvm3/bin/$(PLAT)
-
-CBLACSLIB = $(BLACSCINIT) $(BLACSLIB) $(BLACSCINIT)
-FBLACSLIB = $(BLACSFINIT) $(BLACSLIB) $(BLACSFINIT)
-
-#
-# The directories to find the various pieces of ScaLapack
-#
-PBLASdir = $(home)/PBLAS
-SRCdir = $(home)/SRC
-TESTdir = $(home)/TESTING
-PBLASTSTdir = $(TESTINGdir)
-TOOLSdir = $(home)/TOOLS
-REDISTdir = $(home)/REDIST
-REDISTTSTdir = $(TESTINGdir)
-#
-# The fortran and C compilers, loaders, and their flags
-#
-F77 = mpif77
-CC = mpicc
-NOOPT = -f
-#NOOPT = -f -mt
-F77FLAGS = $(NOOPT) -dalign -native -xO5 -xarch=v8plusa
-DRVOPTS = $(F77FLAGS)
-CCFLAGS = -xO4
-SRCFLAG =
-F77LOADER = $(F77)
-CCLOADER = $(CC)
-F77LOADFLAGS =
-CCLOADFLAGS =
-#
-# C preprocessor defs for compilation
-# (-DNoChange, -DAdd_, -DUpCase, or -Df77IsF2C)
-#
-CDEFS = -DAdd_ $(USEMPI)
-#
-# The archiver and the flag(s) to use when building archive (library)
-# Also the ranlib routine. If your system has no ranlib, set RANLIB = echo
-#
-ARCH = ar
-ARCHFLAGS = cr
-RANLIB = echo
-#
-# The name of the libraries to be created/linked to
-#
-SCALAPACKLIB = $(home)/libscalapack.a
-#BLASLIB = /usr/local/lib/libf77blas.a /usr/local/lib/libatlas.a
-BLASLIB = -xlic_lib=sunperf
-#BLASLIB = -xlic_lib=sunperf_mt
-LAPACKLIB =
-#
-PBLIBS = $(SCALAPACKLIB) $(FBLACSLIB) $(LAPACKLIB) $(BLASLIB) $(SMPLIB)
-PRLIBS = $(SCALAPACKLIB) $(CBLACSLIB) $(SMPLIB)
-RLIBS = $(SCALAPACKLIB) $(FBLACSLIB) $(CBLACSLIB) $(LAPACKLIB) $(BLASLIB) $(SMPLIB)
-LIBS = $(PBLIBS)
diff --git a/INSTALL/SLmake.SUNMP b/INSTALL/SLmake.SUNMP
deleted file mode 100644
index bd2b2a1..0000000
--- a/INSTALL/SLmake.SUNMP
+++ /dev/null
@@ -1,105 +0,0 @@
-############################################################################
-#
-# Program: ScaLAPACK
-#
-# Module: SLmake.inc
-#
-# Purpose: Top-level Definitions
-#
-# Creation date: March 20, 1995
-#
-# Modified:
-#
-# Send bug reports, comments or suggestions to scalapack at cs.utk.edu
-#
-############################################################################
-#
-SHELL = /bin/sh
-#
-# The complete path to the top level of ScaLAPACK directory, usually
-# $(HOME)/SCALAPACK
-#
-home = $(HOME)/SCALAPACK
-#
-# The platform identifier to suffix to the end of library names
-#
-PLAT = SUNMP
-#
-# BLACS setup. All version need the debug level (0 or 1),
-# and the directory where the BLACS libraries are
-#
-BLACSDBGLVL = 0
-BLACSdir = $(HOME)/BLACS/LIB
-#
-# MPI setup; tailor to your system if using MPIBLACS
-# Will need to comment out these 6 lines if using PVM
-#
-USEMPI = -DUsingMpiBlacs
-SMPLIB = /usr/lib/mpi/build/solaris/ch_shmem/lib/libmpich.a -lnsl -lsocket -lthread
-BLACSFINIT = $(BLACSdir)/blacsF77init_MPI-$(PLAT)-$(BLACSDBGLVL).a
-BLACSCINIT = $(BLACSdir)/blacsCinit_MPI-$(PLAT)-$(BLACSDBGLVL).a
-BLACSLIB = $(BLACSdir)/blacs_MPI-$(PLAT)-$(BLACSDBGLVL).a
-TESTINGdir = $(home)/TESTING
-
-#
-# PVMBLACS setup, comment out next 6 lines if using MPI
-#
-#USEMPI =
-#SMPLIB = $(PVM_ROOT)/lib/$(PLAT)/libpvm3.a -lnsl -lsocket -lthread
-#BLACSFINIT =
-#BLACSCINIT =
-#BLACSLIB = $(BLACSdir)/blacs_PVM-$(PLAT)-$(BLACSDBGLVL).a
-#TESTINGdir = $(HOME)/pvm3/bin/$(PLAT)
-
-CBLACSLIB = $(BLACSCINIT) $(BLACSLIB) $(BLACSCINIT)
-FBLACSLIB = $(BLACSFINIT) $(BLACSLIB) $(BLACSFINIT)
-
-#
-# The directories to find the various pieces of ScaLapack
-#
-PBLASdir = $(home)/PBLAS
-SRCdir = $(home)/SRC
-TESTdir = $(home)/TESTING
-PBLASTSTdir = $(TESTINGdir)
-TOOLSdir = $(home)/TOOLS
-REDISTdir = $(home)/REDIST
-REDISTTSTdir = $(TESTINGdir)
-#
-# The fortran and C compilers, loaders, and their flags
-#
-F77 = f77
-CC = cc
-NOOPT = -f
-#NOOPT = -f -mt
-F77FLAGS = $(NOOPT) -dalign -native -xO5 -xarch=v8plusa
-DRVOPTS = $(F77FLAGS)
-CCFLAGS = -xO4
-SRCFLAG =
-F77LOADER = $(F77)
-CCLOADER = $(CC)
-F77LOADFLAGS =
-CCLOADFLAGS =
-#
-# C preprocessor defs for compilation
-# (-DNoChange, -DAdd_, -DUpCase, or -Df77IsF2C)
-#
-CDEFS = -DAdd_ $(USEMPI)
-#
-# The archiver and the flag(s) to use when building archive (library)
-# Also the ranlib routine. If your system has no ranlib, set RANLIB = echo
-#
-ARCH = ar
-ARCHFLAGS = cr
-RANLIB = echo
-#
-# The name of the libraries to be created/linked to
-#
-SCALAPACKLIB = $(home)/scalapack_$(PLAT).a
-BLASLIB = -xlic_lib=sunperf
-#BLASLIB = -xlic_lib=sunperf_mt
-LAPACKLIB =
-#
-PBLIBS = $(SCALAPACKLIB) $(FBLACSLIB) $(LAPACKLIB) $(BLASLIB) $(SMPLIB)
-PRLIBS = $(SCALAPACKLIB) $(CBLACSLIB) $(SMPLIB)
-RLIBS = $(SCALAPACKLIB) $(FBLACSLIB) $(CBLACSLIB) $(LAPACKLIB) $(BLASLIB) $(SMPLIB)
-LIBS = $(PBLIBS)
diff --git a/INSTALL/SLmake.SX4 b/INSTALL/SLmake.SX4
deleted file mode 100644
index 7365c8a..0000000
--- a/INSTALL/SLmake.SX4
+++ /dev/null
@@ -1,103 +0,0 @@
-############################################################################
-#
-# Program: ScaLAPACK
-#
-# Module: SLmake.inc
-#
-# Purpose: Top-level Definitions
-#
-# Creation date: February 15, 2000
-#
-# Modified:
-#
-# Send bug reports, comments or suggestions to scalapack at cs.utk.edu
-#
-############################################################################
-#
-SHELL = /bin/sh
-#
-# The complete path to the top level of ScaLAPACK directory, usually
-# $(HOME)/SCALAPACK
-#
-home = $(HOME)/SCALAPACK
-#
-# The platform identifier to suffix to the end of library names
-#
-PLAT = SX4
-#
-# BLACS setup. All version need the debug level (0 or 1),
-# and the directory where the BLACS libraries are
-#
-BLACSDBGLVL = 0
-BLACSdir = $(HOME)/BLACS/LIB
-#
-# MPI setup; tailor to your system if using MPIBLACS
-# Will need to comment out these 6 lines if using PVM
-#
-USEMPI = -DUsingMpiBlacs
-SMPLIB = /usr/lib0/libmpi.a
-BLACSFINIT = $(BLACSdir)/blacsF77init_MPI-$(PLAT)-$(BLACSDBGLVL).a
-BLACSCINIT = $(BLACSdir)/blacsCinit_MPI-$(PLAT)-$(BLACSDBGLVL).a
-BLACSLIB = $(BLACSdir)/blacs_MPI-$(PLAT)-$(BLACSDBGLVL).a
-TESTINGdir = $(home)/TESTING
-
-#
-# PVMBLACS setup, uncomment next 6 lines if using PVM
-#
-#USEMPI =
-#SMPLIB = $(PVM_ROOT)/lib/$(PLAT)/libpvm3.a
-#BLACSFINIT =
-#BLACSCINIT =
-#BLACSLIB = $(BLACSdir)/blacs_PVM-$(PLAT)-$(BLACSDBGLVL).a
-#TESTINGdir = $(HOME)/pvm3/bin/$(PLAT)
-
-CBLACSLIB = $(BLACSCINIT) $(BLACSLIB) $(BLACSCINIT)
-FBLACSLIB = $(BLACSFINIT) $(BLACSLIB) $(BLACSFINIT)
-
-#
-# The directories to find the various pieces of ScaLapack
-#
-PBLASdir = $(home)/PBLAS
-SRCdir = $(home)/SRC
-TESTdir = $(home)/TESTING
-PBLASTSTdir = $(TESTINGdir)
-TOOLSdir = $(home)/TOOLS
-REDISTdir = $(home)/REDIST
-REDISTTSTdir = $(TESTINGdir)
-#
-# The fortran and C compilers, loaders, and their flags
-#
-F77 = f77
-CC = cc
-NOOPT =
-F77FLAGS = -eb -float0 -P stack -Cvopt -Wf"-O nomsg -i -pvctl nomsg noassume vwork=stack"
-DRVOPTS = $(F77FLAGS)
-CCFLAGS = -h ansi, float0 -D_REENTRANT
-SRCFLAG =
-F77LOADER = $(F77)
-CCLOADER = $(CC)
-F77LOADFLAGS = $(F77FLAGS)
-CCLOADFLAGS = $(CCFLAGS)
-#
-# C preprocessor defs for compilation
-# (-DNoChange, -DAdd_, -DUpCase, or -Df77IsF2C)
-#
-CDEFS = -DAdd_ -DNO_IEEE $(USEMPI)
-#
-# The archiver and the flag(s) to use when building archive (library)
-# Also the ranlib routine. If your system has no ranlib, set RANLIB = echo
-#
-ARCH = ar
-ARCHFLAGS = cr
-RANLIB = echo
-#
-# The name of the libraries to be created/linked to
-#
-SCALAPACKLIB = $(home)/libscalapack.a
-BLASLIB = /usr/lib0/libblas.a
-LAPACKLIB = /usr/lib0/liblapack.a
-#
-PBLIBS = $(SCALAPACKLIB) $(FBLACSLIB) $(LAPACKLIB) $(BLASLIB) $(SMPLIB)
-PRLIBS = $(SCALAPACKLIB) $(CBLACSLIB) $(SMPLIB)
-RLIBS = $(SCALAPACKLIB) $(FBLACSLIB) $(CBLACSLIB) $(LAPACKLIB) $(BLASLIB) $(SMPLIB)
-LIBS = $(PBLIBS)
diff --git a/INSTALL/SLmake.T3D b/INSTALL/SLmake.T3D
deleted file mode 100644
index b4086f6..0000000
--- a/INSTALL/SLmake.T3D
+++ /dev/null
@@ -1,115 +0,0 @@
-############################################################################
-#
-# Program: ScaLAPACK
-#
-# Module: SLmake.inc
-#
-# Purpose: Top-level Definitions
-#
-# Creation date: February 15, 2000
-#
-# Modified:
-#
-# Send bug reports, comments or suggestions to scalapack at cs.utk.edu
-#
-############################################################################
-#
-SHELL = /bin/sh
-#
-# The complete path to the top level of ScaLAPACK directory, usually
-# $(HOME)/SCALAPACK
-#
-home = $(HOME)/SCALAPACK
-#
-# The platform identifier to suffix to the end of library names
-#
-PLAT = T3D
-#
-# BLACS setup. All version need the debug level (0 or 1),
-# and the directory where the BLACS libraries are
-#
-BLACSDBGLVL = 0
-BLACSdir = $(HOME)/BLACS/LIB
-#
-# MPI setup; uncomment and tailor to your system if using MPIBLACS
-# Will need to comment out the default native BLACS setup below below
-#
-#USEMPI = -DUsingMpiBlacs
-#SMPLIB = /mpp/lib/libmpi.a
-#BLACSFINIT = $(BLACSdir)/blacsF77init_MPI-$(PLAT)-$(BLACSDBGLVL).a
-#BLACSCINIT = $(BLACSdir)/blacsCinit_MPI-$(PLAT)-$(BLACSDBGLVL).a
-#BLACSLIB = $(BLACSdir)/blacs_MPI-$(PLAT)-$(BLACSDBGLVL).a
-#TESTINGdir = $(home)/TESTING
-
-#
-# PVMBLACS setup, comment out next 6 lines if using MPI
-#
-USEMPI =
-SMPLIB = $(PVM_ROOT)/lib/$(PLAT)/libpvm3.a
-BLACSFINIT =
-BLACSCINIT =
-BLACSLIB = $(BLACSdir)/blacs_PVM-$(PLAT)-$(BLACSDBGLVL).a
-TESTINGdir = $(HOME)/pvm3/bin/$(PLAT)
-
-
-TESTINGdir = $(home)/TESTING
-
-#
-# system primitive BLACS setup, comment out if using MPI
-#
-SMPLIB =
-USEMPI =
-BLACSFINIT =
-BLACSCINIT =
-BLACSLIB =
-
-CBLACSLIB = $(BLACSCINIT) $(BLACSLIB) $(BLACSCINIT)
-FBLACSLIB = $(BLACSFINIT) $(BLACSLIB) $(BLACSFINIT)
-
-#
-# The directories to find the various pieces of ScaLapack
-#
-PBLASdir = $(home)/PBLAS
-SRCdir = $(home)/SRC
-TESTdir = $(home)/TESTING
-PBLASTSTdir = $(TESTINGdir)
-TOOLSdir = $(home)/TOOLS
-REDISTdir = $(home)/REDIST
-REDISTTSTdir = $(TESTINGdir)
-#
-# The fortran and C compilers, loaders, and their flags
-#
-F77 = /mpp/bin/cft77
-CC = /mpp/bin/cc
-NOOPT =
-F77FLAGS = -dp
-DRVOPTS = $(F77FLAGS)
-CCFLAGS = -Tcray-t3d
-SRCFLAG =
-F77LOADER = /mpp/bin/mppldr
-CCLOADER = $(CC)
-F77LOADFLAGS = -O MSHARED
-CCLOADFLAGS = -Tcray-t3d
-#
-# C preprocessor defs for compilation
-# (-DNoChange, -DAdd_, -DUpCase, or -Df77IsF2C)
-#
-CDEFS = -DUpCase -DT3D $(USEMPI)
-#
-# The archiver and the flag(s) to use when building archive (library)
-# Also the ranlib routine. If your system has no ranlib, set RANLIB = echo
-#
-ARCH = ar
-ARCHFLAGS = cr
-RANLIB = echo
-#
-# The name of the libraries to be created/linked to
-#
-SCALAPACKLIB = $(home)/libscalapack.a
-BLASLIB =
-LAPACKLIB =
-#
-PBLIBS = $(SCALAPACKLIB) $(FBLACSLIB) $(LAPACKLIB) $(BLASLIB) $(SMPLIB)
-PRLIBS = $(SCALAPACKLIB) $(CBLACSLIB) $(SMPLIB)
-RLIBS = $(SCALAPACKLIB) $(FBLACSLIB) $(CBLACSLIB) $(LAPACKLIB) $(BLASLIB) $(SMPLIB)
-LIBS = $(PBLIBS)
diff --git a/INSTALL/SLmake.T3E b/INSTALL/SLmake.T3E
deleted file mode 100644
index 23a164a..0000000
--- a/INSTALL/SLmake.T3E
+++ /dev/null
@@ -1,114 +0,0 @@
-############################################################################
-#
-# Program: ScaLAPACK
-#
-# Module: SLmake.inc
-#
-# Purpose: Top-level Definitions
-#
-# Creation date: February 15, 2000
-#
-# Modified:
-#
-# Send bug reports, comments or suggestions to scalapack at cs.utk.edu
-#
-############################################################################
-#
-SHELL = /bin/sh
-#
-# The complete path to the top level of ScaLAPACK directory, usually
-# $(HOME)/SCALAPACK
-#
-home = $(HOME)/SCALAPACK
-#
-# The platform identifier to suffix to the end of library names
-#
-PLAT = T3E
-#
-# BLACS setup. All version need the debug level (0 or 1),
-# and the directory where the BLACS libraries are
-#
-BLACSDBGLVL = 0
-BLACSdir = $(HOME)/BLACS/LIB
-#
-# MPI setup; tailor to your system if using MPIBLACS
-# Will need to comment out these 6 lines if using PVM
-#
-USEMPI = -DUsingMpiBlacs
-SMPLIB = /mpp/lib/libmpi.a
-BLACSFINIT = $(BLACSdir)/blacsF77init_MPI-$(PLAT)-$(BLACSDBGLVL).a
-BLACSCINIT = $(BLACSdir)/blacsCinit_MPI-$(PLAT)-$(BLACSDBGLVL).a
-BLACSLIB = $(BLACSdir)/blacs_MPI-$(PLAT)-$(BLACSDBGLVL).a
-TESTINGdir = $(home)/TESTING
-
-#
-# PVMBLACS setup, uncomment next 6 lines if using PVM
-#
-#USEMPI =
-#SMPLIB = $(PVM_ROOT)/lib/$(PLAT)/libpvm3.a
-#BLACSFINIT =
-#BLACSCINIT =
-#BLACSLIB = $(BLACSdir)/blacs_PVM-$(PLAT)-$(BLACSDBGLVL).a
-#TESTINGdir = $(HOME)/pvm3/bin/$(PLAT)
-
-TESTINGdir = $(home)/TESTING
-
-#
-# system primitive BLACS setup, comment out if using MPI
-#
-SMPLIB =
-USEMPI =
-BLACSFINIT =
-BLACSCINIT =
-BLACSLIB =
-
-CBLACSLIB = $(BLACSCINIT) $(BLACSLIB) $(BLACSCINIT)
-FBLACSLIB = $(BLACSFINIT) $(BLACSLIB) $(BLACSFINIT)
-
-#
-# The directories to find the various pieces of ScaLapack
-#
-PBLASdir = $(home)/PBLAS
-SRCdir = $(home)/SRC
-TESTdir = $(home)/TESTING
-PBLASTSTdir = $(TESTINGdir)
-TOOLSdir = $(home)/TOOLS
-REDISTdir = $(home)/REDIST
-REDISTTSTdir = $(TESTINGdir)
-#
-# The fortran and C compilers, loaders, and their flags
-#
-F77 = f90
-CC = cc
-NOOPT =
-F77FLAGS = -dp -O3
-DRVOPTS = $(F77FLAGS)
-CCFLAGS = -g -O3
-SRCFLAG =
-F77LOADER = $(F77)
-CCLOADER = $(CC)
-F77LOADFLAGS =
-CCLOADFLAGS =
-#
-# C preprocessor defs for compilation
-# (-DNoChange, -DAdd_, -DUpCase, or -Df77IsF2C)
-#
-CDEFS = -DUpCase -DT3E $(USEMPI)
-#
-# The archiver and the flag(s) to use when building archive (library)
-# Also the ranlib routine. If your system has no ranlib, set RANLIB = echo
-#
-ARCH = ar
-ARCHFLAGS = cr
-RANLIB = echo
-#
-# The name of the libraries to be created/linked to
-#
-SCALAPACKLIB = $(home)/libscalapack.a
-BLASLIB =
-LAPACKLIB =
-#
-PBLIBS = $(SCALAPACKLIB) $(FBLACSLIB) $(LAPACKLIB) $(BLASLIB) $(SMPLIB)
-PRLIBS = $(SCALAPACKLIB) $(CBLACSLIB) $(SMPLIB)
-RLIBS = $(SCALAPACKLIB) $(FBLACSLIB) $(CBLACSLIB) $(LAPACKLIB) $(BLASLIB) $(SMPLIB)
-LIBS = $(PBLIBS)
diff --git a/INSTALL/SLmake.pghpf.SUN4SOL2 b/INSTALL/SLmake.pghpf.SUN4SOL2
deleted file mode 100644
index 8c569b5..0000000
--- a/INSTALL/SLmake.pghpf.SUN4SOL2
+++ /dev/null
@@ -1,103 +0,0 @@
-############################################################################
-#
-# Program: ScaLAPACK
-#
-# Module: SLmake.inc
-#
-# Purpose: Top-level Definitions
-#
-# Creation date: February 15, 2000
-#
-# Modified:
-#
-# Send bug reports, comments or suggestions to scalapack at cs.utk.edu
-#
-############################################################################
-#
-SHELL = /bin/sh
-#
-# The complete path to the top level of ScaLAPACK directory, usually
-# $(HOME)/SCALAPACK
-#
-home = $(HOME)/SCALAPACK
-#
-# The platform identifier to suffix to the end of library names
-#
-PLAT = pghpf_SUN4SOL2
-#
-# BLACS setup. All version need the debug level (0 or 1),
-# and the directory where the BLACS libraries are
-#
-BLACSDBGLVL = 0
-BLACSdir = $(HOME)/BLACS/LIB
-#
-# MPI setup; tailor to your system if using MPIBLACS
-# Will need to comment out these 6 lines if using PVM
-#
-USEMPI = -DUsingMpiBlacs
-SMPLIB = @(MPIdir)/libmpi.a
-BLACSFINIT = $(BLACSdir)/blacsF77init_MPI-$(PLAT)-$(BLACSDBGLVL).a
-BLACSCINIT = $(BLACSdir)/blacsCinit_MPI-$(PLAT)-$(BLACSDBGLVL).a
-BLACSLIB = $(BLACSdir)/blacs_MPI-$(PLAT)-$(BLACSDBGLVL).a
-TESTINGdir = $(home)/TESTING
-
-#
-# PVMBLACS setup, uncomment next 6 lines if using PVM
-#
-#USEMPI =
-#SMPLIB = $(PVM_ROOT)/lib/$(PLAT)/libpvm3.a -lnsl -lsocket
-#BLACSFINIT =
-#BLACSCINIT =
-#BLACSLIB = $(BLACSdir)/blacs_PVM-$(PLAT)-$(BLACSDBGLVL).a
-#TESTINGdir = $(HOME)/pvm3/bin/$(PLAT)
-
-CBLACSLIB = $(BLACSCINIT) $(BLACSLIB) $(BLACSCINIT)
-FBLACSLIB = $(BLACSFINIT) $(BLACSLIB) $(BLACSFINIT)
-
-#
-# The directories to find the various pieces of ScaLapack
-#
-PBLASdir = $(home)/PBLAS
-SRCdir = $(home)/SRC
-TESTdir = $(home)/TESTING
-PBLASTSTdir = $(TESTINGdir)
-TOOLSdir = $(home)/TOOLS
-REDISTdir = $(home)/REDIST
-REDISTTSTdir = $(TESTINGdir)
-#
-# The fortran and C compilers, loaders, and their flags
-#
-F77 = pghpf
-CC = gcc
-NOOPT = -Mnohpfc -Mdclchk
-F77FLAGS = -O4 $(NOOPT)
-DRVOPTS = $(F77FLAGS)
-CCFLAGS = -O4
-SRCFLAG =
-F77LOADER = $(F77)
-CCLOADER = $(CC)
-F77LOADFLAGS =
-CCLOADFLAGS =
-#
-# C preprocessor defs for compilation
-# (-DNoChange, -DAdd_, -DUpCase, or -Df77IsF2C)
-#
-CDEFS = -DAdd_ $(USEMPI)
-#
-# The archiver and the flag(s) to use when building archive (library)
-# Also the ranlib routine. If your system has no ranlib, set RANLIB = echo
-#
-ARCH = ar
-ARCHFLAGS = cr
-RANLIB = echo
-#
-# The name of the libraries to be created/linked to
-#
-SCALAPACKLIB = $(home)/libscalapack.a
-BLASLIB = /usr/lib/libblas.a
-LAPACKLIB = /usr/lib/liblapack.a
-#
-PBLIBS = $(SCALAPACKLIB) $(FBLACSLIB) $(LAPACKLIB) $(BLASLIB) $(SMPLIB)
-PRLIBS = $(SCALAPACKLIB) $(CBLACSLIB) $(SMPLIB)
-RLIBS = $(SCALAPACKLIB) $(FBLACSLIB) $(CBLACSLIB) $(LAPACKLIB) $(BLASLIB) $(SMPLIB)
-LIBS = $(PBLIBS)
diff --git a/INSTALL/scalapack_install.pdf b/INSTALL/scalapack_install.pdf
deleted file mode 100644
index 3e4c824..0000000
Binary files a/INSTALL/scalapack_install.pdf and /dev/null differ
diff --git a/INSTALL/scalapack_install.ps b/INSTALL/scalapack_install.ps
deleted file mode 100644
index 06185ec..0000000
--- a/INSTALL/scalapack_install.ps
+++ /dev/null
@@ -1,7357 +0,0 @@
-%!PS-Adobe-2.0
-%%Creator: dvips(k) 5.95a Copyright 2005 Radical Eye Software
-%%Title: lawn93.dvi
-%%Pages: 36
-%%PageOrder: Ascend
-%%BoundingBox: 0 0 595 842
-%%DocumentFonts: CMR12 CMR10 CMR8 CMR6 CMR9 CMBX12 CMTT10 CMBX10 CMSY10
-%%+ CMTI10 CMTT12 CMMI10 CMITT10 CMSL10 CMMI8 CMSY8 CMSY9 CMMI9 CMEX10
-%%+ CMCSC10
-%%DocumentPaperSizes: a4
-%%EndComments
-%DVIPSWebPage: (www.radicaleye.com)
-%DVIPSCommandLine: dvips lawn93.dvi -o
-%DVIPSParameters: dpi=600
-%DVIPSSource: TeX output 2007.04.05:1405
-%%BeginProcSet: tex.pro 0 0
-%!
-/TeXDict 300 dict def TeXDict begin/N{def}def/B{bind def}N/S{exch}N/X{S
-N}B/A{dup}B/TR{translate}N/isls false N/vsize 11 72 mul N/hsize 8.5 72
-mul N/landplus90{false}def/@rigin{isls{[0 landplus90{1 -1}{-1 1}ifelse 0
-0 0]concat}if 72 Resolution div 72 VResolution div neg scale isls{
-landplus90{VResolution 72 div vsize mul 0 exch}{Resolution -72 div hsize
-mul 0}ifelse TR}if Resolution VResolution vsize -72 div 1 add mul TR[
-matrix currentmatrix{A A round sub abs 0.00001 lt{round}if}forall round
-exch round exch]setmatrix}N/@landscape{/isls true N}B/@manualfeed{
-statusdict/manualfeed true put}B/@copies{/#copies X}B/FMat[1 0 0 -1 0 0]
-N/FBB[0 0 0 0]N/nn 0 N/IEn 0 N/ctr 0 N/df-tail{/nn 8 dict N nn begin
-/FontType 3 N/FontMatrix fntrx N/FontBBox FBB N string/base X array
-/BitMaps X/BuildChar{CharBuilder}N/Encoding IEn N end A{/foo setfont}2
-array copy cvx N load 0 nn put/ctr 0 N[}B/sf 0 N/df{/sf 1 N/fntrx FMat N
-df-tail}B/dfs{div/sf X/fntrx[sf 0 0 sf neg 0 0]N df-tail}B/E{pop nn A
-definefont setfont}B/Cw{Cd A length 5 sub get}B/Ch{Cd A length 4 sub get
-}B/Cx{128 Cd A length 3 sub get sub}B/Cy{Cd A length 2 sub get 127 sub}
-B/Cdx{Cd A length 1 sub get}B/Ci{Cd A type/stringtype ne{ctr get/ctr ctr
-1 add N}if}B/CharBuilder{save 3 1 roll S A/base get 2 index get S
-/BitMaps get S get/Cd X pop/ctr 0 N Cdx 0 Cx Cy Ch sub Cx Cw add Cy
-setcachedevice Cw Ch true[1 0 0 -1 -.1 Cx sub Cy .1 sub]{Ci}imagemask
-restore}B/D{/cc X A type/stringtype ne{]}if nn/base get cc ctr put nn
-/BitMaps get S ctr S sf 1 ne{A A length 1 sub A 2 index S get sf div put
-}if put/ctr ctr 1 add N}B/I{cc 1 add D}B/bop{userdict/bop-hook known{
-bop-hook}if/SI save N @rigin 0 0 moveto/V matrix currentmatrix A 1 get A
-mul exch 0 get A mul add .99 lt{/QV}{/RV}ifelse load def pop pop}N/eop{
-SI restore userdict/eop-hook known{eop-hook}if showpage}N/@start{
-userdict/start-hook known{start-hook}if pop/VResolution X/Resolution X
-1000 div/DVImag X/IEn 256 array N 2 string 0 1 255{IEn S A 360 add 36 4
-index cvrs cvn put}for pop 65781.76 div/vsize X 65781.76 div/hsize X}N
-/p{show}N/RMat[1 0 0 -1 0 0]N/BDot 260 string N/Rx 0 N/Ry 0 N/V{}B/RV/v{
-/Ry X/Rx X V}B statusdict begin/product where{pop false[(Display)(NeXT)
-(LaserWriter 16/600)]{A length product length le{A length product exch 0
-exch getinterval eq{pop true exit}if}{pop}ifelse}forall}{false}ifelse
-end{{gsave TR -.1 .1 TR 1 1 scale Rx Ry false RMat{BDot}imagemask
-grestore}}{{gsave TR -.1 .1 TR Rx Ry scale 1 1 false RMat{BDot}
-imagemask grestore}}ifelse B/QV{gsave newpath transform round exch round
-exch itransform moveto Rx 0 rlineto 0 Ry neg rlineto Rx neg 0 rlineto
-fill grestore}B/a{moveto}B/delta 0 N/tail{A/delta X 0 rmoveto}B/M{S p
-delta add tail}B/b{S p tail}B/c{-4 M}B/d{-3 M}B/e{-2 M}B/f{-1 M}B/g{0 M}
-B/h{1 M}B/i{2 M}B/j{3 M}B/k{4 M}B/w{0 rmoveto}B/l{p -4 w}B/m{p -3 w}B/n{
-p -2 w}B/o{p -1 w}B/q{p 1 w}B/r{p 2 w}B/s{p 3 w}B/t{p 4 w}B/x{0 S
-rmoveto}B/y{3 2 roll p a}B/bos{/SS save N}B/eos{SS restore}B end
-
-%%EndProcSet
-%%BeginProcSet: texps.pro 0 0
-%!
-TeXDict begin/rf{findfont dup length 1 add dict begin{1 index/FID ne 2
-index/UniqueID ne and{def}{pop pop}ifelse}forall[1 index 0 6 -1 roll
-exec 0 exch 5 -1 roll VResolution Resolution div mul neg 0 0]FontType 0
-ne{/Metrics exch def dict begin Encoding{exch dup type/integertype ne{
-pop pop 1 sub dup 0 le{pop}{[}ifelse}{FontMatrix 0 get div Metrics 0 get
-div def}ifelse}forall Metrics/Metrics currentdict end def}{{1 index type
-/nametype eq{exit}if exch pop}loop}ifelse[2 index currentdict end
-definefont 3 -1 roll makefont/setfont cvx]cvx def}def/ObliqueSlant{dup
-sin S cos div neg}B/SlantFont{4 index mul add}def/ExtendFont{3 -1 roll
-mul exch}def/ReEncodeFont{CharStrings rcheck{/Encoding false def dup[
-exch{dup CharStrings exch known not{pop/.notdef/Encoding true def}if}
-forall Encoding{]exch pop}{cleartomark}ifelse}if/Encoding exch def}def
-end
-
-%%EndProcSet
-%%BeginFont: CMCSC10
-%!PS-AdobeFont-1.1: CMCSC10 1.0
-%%CreationDate: 1991 Aug 18 17:46:49
-% Copyright (C) 1997 American Mathematical Society. All Rights Reserved.
-11 dict begin
-/FontInfo 7 dict dup begin
-/version (1.0) readonly def
-/Notice (Copyright (C) 1997 American Mathematical Society. All Rights Reserved) readonly def
-/FullName (CMCSC10) readonly def
-/FamilyName (Computer Modern) readonly def
-/Weight (Medium) readonly def
-/ItalicAngle 0 def
-/isFixedPitch false def
-end readonly def
-/FontName /CMCSC10 def
-/PaintType 0 def
-/FontType 1 def
-/FontMatrix [0.001 0 0 0.001 0 0] readonly def
-/Encoding 256 array
-0 1 255 {1 index exch /.notdef put} for
-dup 39 /quoteright put
-dup 44 /comma put
-dup 45 /hyphen put
-dup 46 /period put
-dup 65 /A put
-dup 66 /B put
-dup 67 /C put
-dup 68 /D put
-dup 69 /E put
-dup 70 /F put
-dup 71 /G put
-dup 72 /H put
-dup 73 /I put
-dup 74 /J put
-dup 75 /K put
-dup 76 /L put
-dup 77 /M put
-dup 79 /O put
-dup 80 /P put
-dup 82 /R put
-dup 83 /S put
-dup 84 /T put
-dup 86 /V put
-dup 87 /W put
-dup 97 /a put
-dup 99 /c put
-dup 100 /d put
-dup 101 /e put
-dup 102 /f put
-dup 103 /g put
-dup 104 /h put
-dup 105 /i put
-dup 107 /k put
-dup 108 /l put
-dup 109 /m put
-dup 110 /n put
-dup 111 /o put
-dup 114 /r put
-dup 115 /s put
-dup 116 /t put
-dup 117 /u put
-dup 118 /v put
-dup 119 /w put
-dup 121 /y put
-dup 122 /z put
-readonly def
-/FontBBox{14 -250 1077 750}readonly def
-currentdict end
-currentfile eexec
-D9D66F633B846A97B686A97E45A3D0AA0529731C99A784CCBE85B4993B2EEBDE
-3B12D472B7CF54651EF21185116A69AB1096ED4BAD2F646635E019B6417CC77B
-532F85D811C70D1429A19A5307EF63EB5C5E02C89FC6C20F6D9D89E7D91FE470
-B72BEFDA23F5DF76BE05AF4CE93137A219ED8A04A9D7D6FDF37E6B7FCDE0D90B
-986423E5960A5D9FBB4C956556E8DF90CBFAEC476FA36FD9A5C8175C9AF513FE
-D919C2DDD26BDC0D99398B9F4D03D5993DFC0930297866E1CD0A30EB76029337
-900ECFB1390CA5C0C3A04528044F266BA17BE487C79B94FAC6D6484684C5BFEA
-87BCCC77D40AD11552035E95E3007126418ED49B68468B38A14E88E68A267B98
-076F1C9769A5AFBC285E5B158EAC9F926F1D6C0B8F1D57D9C31D25AE27123518
-9D2CD92E5689E0213089BD268DA5E47525CB8EABAA4B78A15AEA34705889AB3A
-FFB8953B5B3482E52BFA0940630ADF8C0AC2177D907324299EE980E850F203CD
-B627962F43D5A678C44243CDE97853BDC6AB45FD5C09AD274DAF89929F583CC9
-CCC24BDFC68B92111055ABA5F26D2DC67C70906F71C2957701D65AE746A60C30
-40E6CB24B97FCDAD0487AE38A201FBF0E41BABD2181981A71940F1E707F91E5D
-C8CA50CB16D8702D188E56D014D92F76CE0B52ABDB9110E32438D2BBF3E6A40B
-7B005F10BB437812CAC6ED2996F7606DC962C4FDE207FF322782C343DF44CEC5
-FF06A55C630C20E9AE1B0D1C5673753C43BA0767D65D1B451CC6380D8BB3C4DC
-81E8FD8AA79BE993218686F29D3CD925566DD587F541A0DA1B1CC3BCEA2E6C7D
-5E1016F6917A871F1BBAD96AF9E867735017119A381FCF33EB2D3E1E7093FD90
-CDB0CED4818CFD9E201A03430CEC713620BE0D3254158931FB657C6AD4B2482A
-0E7D070D7497892E9E942DF58E88CAF0C8221BF36BF7C435BF2C683A4A2EF4CB
-E85820A8AD3486155A40143011BA9D76297F46DEF69ECA4596D6E4CAABF84091
-22A96A4BC78A8DD072FEB759A68A44BE1164638B6D952147EE3C628F9A022060
-1D1941E73310943FA782532ABCCC88593FD63E7E2CECF6665C04DB48D641ABD3
-AE1BB468638681E96394B9E7BED1D13E534B897DB90EA6EC706BAAE06BE2FEFF
-1DFA5258113E9B4CD2D36655973864574E0E8D6291E48A8C62203F679B7ED838
-6F7CBD523C2943ECA994CACE6679ADD23290C50FA5ACCD01D64928BEB3E5BEBB
-7CEE09A8E654AAAB01E0B0FAD974BFFAD8A9A1B6CAC9E28290B6B76146CE0D8B
-8FE70111A50AB10B3E4D9F4C4B57D10980F9E02FCA8A51294D5651CAFB548336
-E9FDBC163CD16141B9C52B4FC42C122901F70138B2176B760E0C9768F0DC3C11
-CFD3E826C3BA6234EBE8515797347333923C6CED42FCE5E716FAB1DA0E826F24
-4CE08C6A562EF0FC7F9D959F3BEEC37B9B9A2275C223F1BDFEEEDBBB04D1CF68
-8DDE2BC3F55C5328752E085094926432D3C557D166E24611A1B9773D49630884
-24DF6D3A89228EBACFC3D032D4994480A53EED5E7F8507C5B83051D3AB9ED331
-E179797FC67F9912F0E155E0DDB93C2565C1964E04F0590E318C908CEDC2D58D
-6083D3F0C7B8320AE6E65E622CACDEE38315F342A7B067B71D1CAB5EEFC82C49
-1AF28C6BCE96BB7744B4AE081EBB8B63FC373E1B7B996C7CB81AF8B309495FCB
-05F816307210CB8DF3B0E69677B69B7193BEB754A973B9C62A7FE49BC4371CF3
-8E4CF9B320716913CC3D871C0BA5AE03D8C1E304E7C79A1FFB97F13D72492BEE
-E29824AA7033505C3071876186C5E86211246A6A24B69959AC6C9E7ACFC8CC2B
-7DA72A91647B43D8F4BB5CB92687CE6D257F01DB8EF9282A274997EDF1A00013
-20ED4576656AFD42104025E4170D11F4F892FB2BEF17CDD1F909FD6B03F25E67
-7155789B71DA23A6A0D6C89A8E3E7CFDC94CA9D3965A5EF54866F47A4F52CF8C
-844D881C2789127CC09C8DE04FA4F90F6D37D8BC87E1EAE0B991AC363D0543FC
-C3C414E0B5559A60C6B32FAEE8B9D37CA39D6148C90709D8EFE5DEAF1F7EE20F
-180509E1969A76333067D012C175644C24995CA68C0EFC2C599E69D8EF52EB82
-20302646C41E4115B5DB34F67879F106F79D3B745404DD66CB7CE5FF252E5F64
-BE01A5AA9545B7A9FCC91B334574F0CC301F28D693E6AB6F75CD349A0EDB0A20
-36CF84752035472076EB6271286C03619BF6D9F72D3B341AD1F88BC7E2F8DE4A
-25CA82AB15009F3A5F53585928A959E7FD95ACE70A37652B140EF0F5C304089A
-AE6B9251E6741E0A6D078D68E6CA0F3C32A2A7E2864EE1A1D509D9418ACC3819
-BA4D9E5D82AEADAE9AEF380E6982DD9F07393F71005955D7AC64C1567B4708B1
-F0462DE483E32C0085E5A36A48B250B539D737286B2B485B9980F21FD5E26D89
-20F51BE7927CFAA4465C847A9B8B9F83DBF005A3BD548DC26E22EE9D49A4227B
-6C584F16D7A0A6DF31E161EC94F559DA166873CBE9C3026FCB22F96080E637CC
-C5FF951D5044951EA41E7671AA5FADFF60CE8BB7BF237E29A2B4F54BE63B59EA
-E28BC5EA1E70AED2589F5693C8CDAD6DA5642E4E8E9327B072A538ECECAAD737
-941671DCCF52DE1D84C0B9028CCF7E582B17090321A0C49FE21564CFBEEA51A1
-ADD70594999CD3E94133ED9C3BCB796CE430BF1B111CD1E29F341D0DAD385028
-8F7737D218CA8A9230872C498B7C8527C82346FE6F3AF4D38349A043A417B49B
-1868B036146ABC7567802CC61EA2BBF742F638E0084AF4A93EA46EC93D06AD6D
-17F0BCB651EDE7C75B64E4B38B2BCC6915A4607612DEEEC081BC9796B79F9283
-513DD3874486E63393521328EB10F9C36638BE827663F94AF7C4E0CF254CFBAE
-8ED7D0CA9C1F632AE5F0670C5DC717F4C89FD5919F57372396E367592EFB77E0
-B887B4C196B4A576D12AB641FCE038D53DAE53725E598711A73741DA51CA2CDB
-4A3CD44ECB92603CDD08540E01274D9A8D859BE640BD58F0EC5DB4AFBD350642
-15D477681527D908DB58902FFE53380DBC210F2A7503D88C7B6623748A4AEC69
-6B113991537D4909C8BA62F44FDD52DEC6DA93E1F0F3400257788484F255B463
-D1FD49FA84478C92BDCF2CA847C685E0B5E36C3562524546DCC942BF37F0E34C
-02AC14D98D652EECCF114879F9F6E7638AA39395A31C3340C35832864D5ABDF8
-28FE4D5EEA80BBECF32B7F81AF6ED4EE619658566A42B3AFAFDDF7B198C9B25D
-2B1019FEE03BFA0E6C832442BD1C1CE3B8657C79A4BDE9022EAEE14B36611259
-FFADD46612E4959134C8E7EBF7186150CD6126420BE7DB359CF875B91D8E55D5
-EF62EA0BCFE42DF6C272DED8E7444F218C70E0EC1AD477AE81DDD08363E5A877
-C6A91C0407033E76F5AA57C956B6F8DEE834A405568767F7E36EC7ABB4F4EC81
-56708D2404320B3444A59078B4697773C08E0BD6C6BE6E93FACA01198889C93B
-86B048CEF863DC1A096D0C031A977B156E7C83D2C8C23E43FEFBB46682D27793
-F7EF4B59608A373958A75B005C69F20BE644F30F6A338CF9EBE5D66221749D6B
-B4F87BC9439FD1CD681D07CB766165B61CA83D12607A822E35F163D2B3B982F3
-E4C1A4DE52DF9B12EA26C61EC75FC4410B8CB1CD4A7E5C887A645BEB72AB69B6
-8FE3CEB934D185E8250DE85BE70BFF46E7A2AD718C208B29205D5FA39F806912
-0DF859814183D72E3BFE618C6F0A946CE5EF8EA04F460C45AC22A838F3E14DD0
-D47F1052915F1F8722DA1EE17778ADDEC203BB93B9E470ACA0F350081FE6EEBF
-F6C64374F30AABF77DFD29C8DB94389B7C3B857F20814B04572590D9A382D2F8
-3DC8C04840DB2C44F469CA791E18225987CD2528D9344F987AB56918D9BFDB67
-E9F5DA5BA117F1999A6AB49EAC5DF683108E04BA9900C72FA02A9266FC9235CD
-5FD1E02A022121E2E64BAA50D08A39F8D4C588C2D8506508AF4A37AF05F8DD40
-2077E067C9E1811B042C5626FF27E31DAEF48B729BA7C93A8812617B8F2E0BB2
-3C6D367110DF6BFB3C8AA6CC0F348116BC1908CBAF3C5CD88CF6EA147241BD5C
-2FC36AA8C6C2B9294BB0A9A366F9BB36738A9A90EC9ECE8D1FF1B27AE947762A
-EC27C0D65265A016A046337C7A1DF9A6F0E106E140812511046EC959F77D1B97
-922E876C3FF41A68A975C5817BCB1140A63A9742D9F79E7C39AC937B3FFEA93E
-1CDAB7F55D67FE8A2FD69CD7C208ABB86047E8C4899E7A80AA212CD295537F4D
-C42E9E3B9A64E4FEC29753516B7C4F6D6374D3BBCB1F2A5D6A47D0640EC0EABE
-99BEDDD58901B1B2B280C5E539F84D1A3277EDC18EFEA35EBB20789E5790F140
-9FC4C3B52AD1EF2380B2FF6ED708ED39093F8C75E3E67425A0C3E835280959A7
-125AB7F4DBADCEEFD0CA5A67E1A10C515D5001D8CDE628A7F29D6DF58FB5F437
-AAB992D735A0892F56A6C1ADBB4996B863EDA50A75D6B26421AB0472CDC75549
-FEF749AB834E742C3FEFEA566ECDA97CF8C2C4C0E9907CFD457E40BD7F623A9C
-A34870D149B29BBD3985BBEB7D5CAFA06304A8B5D3501779094C24D733A26438
-B732FEF82A5EF1F7F2AFD1C270920AE89128ABEDAFE626889138A2610C9DA0F0
-BD741C98C0D47A530D381792B798ADF1EFE837EEC94040CEF61347F5FB39D0AC
-46ABD874C7A513E5996200BE60A84190B0DAFE520264738098944C875D8F99B4
-0B624B008E16D6EAB9B06616E46072956259174B8D6F94A73698714E4713A7D2
-F792E19A27CCF09E84E050CE6408C3AE69BE3D540A18E1DEF193F0F97316D4A9
-BBE2D4C611EA5DB69E8A538E604B579AB7850AB424267097F2FE78D8A3AFDE5C
-167995EFC16EC7A6DA7BA19DC1A56F7A1288039A8703AE04D41D436F665A580D
-AE8E20CBF2924B9E3A6684463FFE8B461AF38249D28E9684E621F8F0E76B99C7
-ECD964A664FC8F103CC9E0C2976B13B942AB0FD96B2066DD7D83AB0A5D81255D
-6A49F744F43364FB2AE380CD9B1E4CD67EC57C912CA62F89ED73B445FCA0EA87
-9CB5CDCA5A30D293D3D77B313619F8E342BB47158F26445F200C532FD2E0B60C
-74F56AEB05CA6DCDB1B1B38BDAA58EB10A6F9689CEFF658260B3CA32A6241CC5
-582F160879A5D70B75FBE99D3C3512ADAB7A9F7A00E5BD70D5E74C850C5A7510
-016E1A634246569FD210CA4F276B46009CC3367D3F50864E7F1BC642EE469F60
-25B67006674A40DE6F4B05D5B3495BEF8EC7860732703EA3FEC53DCB43B6CF74
-D3876DB433922F0DB59B1F2933B9B72206D1E8F61F399CC2CD4BB955FCB044B7
-B6A816C5885DF66517D6C74E4BF234193AACBBEEAD3B4A98D6FF39CE0740B24C
-B7A2B9B0F29B662310B3E9ECDF6B1C5851273D52F2C9B4EF558A621DABFB7FA2
-C79EB0D0B253C4F82E47B8E91BF13B79E16EAFAAAA5538D5DA51B88DD71F9C2D
-A758738D9C3FC1B41E3252A48A9F3D04C63FD5E4903035F348D7CF229AF76CF4
-E11D592C187AB13C87BD93CA7856505A3E3F7D8B75BCE6E2384A57F88EA76B21
-32B8D885429F451D9151EC93FAC44E1BAFAEE2A26FC0A8F0CE25069E4FE5C428
-E144B9C82A5E7EFAE9319DABDB2F4AFA101212D9C18F0C2B05DFBB0E143309EF
-B6054624D897EE87D0CE3CBDBA3C0F6BACDB281A2E55129057273BA33E290ACC
-ABA916122B6DF94E42D830E9700DFAEC18289E92A1E846DF937F66DC207ECF08
-8E90A554041222379D83F35D285A113527725FA3C978631907EFA9444E174EE3
-6307C33B8B59103C779DFE516B9731135AD3FA649283EB3681F99329091E63F1
-2270E84AEAB99D64B1A8B6D842F410EA8EB3E40AB74113BB68750A964DEC25D0
-63E389DA1DADD1817487E494CD516C0566CCFF32A750296EF30998EA17F47DFA
-FFB7B0C278EF067764228DF564403105DE0918F5F45C705533D1F7A910539856
-10C8CF921E5EF46AEAB7C23021911815D7AF789A28D1D3C51AC54A52C7618FA6
-3EE00A3500391ED01404B346A8365975E7055B3E28D83A80F1A192CE1151ECA9
-D6DB5DBE618CABCA7890CED68313680CE18355FA6810E3E8E608CE1EE1A59F84
-25B7982DBE507F7E25EFBC8307EED0DEA1495A51A1A1F374E1CA6E4F318A4F1E
-F731CEFA9443DE54B62DD4F3CBE2EA6ABFD3B0A9138755C5B7419831E2028949
-7A49A1792C8F1A190096DEB7FA5EEDEB8DB3F539139F8A30C478D135C39DF174
-2D96F6413ABD28438110D75837C6A5E2D6D88519BBE951F41344A06A45F8F92B
-F109EB023F7B475A31CFBB129E1527A8A58803F0633AF52494550FF0E8EA87BF
-3ED39F8200D1AC85322FD0C03C1468C03209889ECF27927A1D80157914C176CB
-2D44C5C154B68E7B47762E50D5766DA00D61DE9C1D154C6A048CD2E2081915F9
-793501D2A211BA463101018D31FD30213A30EE029A485FCBA8F035B069C19FE7
-EDC257C25720EE67691F1B7551B5C42D06D4B52907C664F937BCED7261E541AB
-278ED627CAD2F99A61AF2272BAB24209A83A4B87F1B7A7341ED3966BB97238DE
-C68515AB042A0960BF9C3A82B13E31A09236AA6EAF31FCA158618EFE97ED3B15
-6038F646FD053965CE5BBB59E89D8A621CA565EE390CE69E9EFF2A4AF3F0CE45
-06581D8E191BAEF34CEB20783CA934F04A29A60422ECD6465F5E8B4FB3FD1DD9
-CBF0294DA1F00EB8B5349C12399E296ADE6BC9B3F6EEE9D1457BAAB8BAFEDA8B
-D3663430CF539DEFF45BA9829A952F6D6759DF18D5320FC6BE086E2ABD1751E9
-980DB0D88BF506E206B49F085FDA1D8F6849454C37246510FA57BAF974BE596B
-02255530A976E6697F8C9B6E71FED0360D7251384E5BEE2860CBFD3365FBEBB2
-D1B68F8258F8E9FF3CB2060D28EF6DA8B472608BECA36C75632BCCCCECF9B697
-1E10D54B277AEA3909047CC3D1FBC02F4D972AB98509A0C8D8E189BC3F6BE9FF
-A184BDF9FF7BC80D654722955516D58879D5CFCE9401688637004CD85C6CF53A
-DA4183425BB6D488A96E335BB30914BC4E4B7B34B44611FEF2277F3A6EBC5E2B
-5DCDF8272B4C14AB8C92390CD3E5F064A968BA3BFAFD4BA638F8BE19DE7CDFC8
-DF1A165A6CBAEBE48BABC9DD32419DF162AD15FD7B2358D4F82F04C655CA9453
-D70CE522AF513C85762D02103A195C4259A5875B8639225797972897576575B9
-7C82264A27DF16B55A46A9EC0CCE11EF4845E0D5A2D6709FB1EB75C3C90EA91E
-A6516D1D95EC169A99D2521C2B4AC66642BB229B28B1476322D2E9359B82548F
-873112A8F61ACC41B5BBC2518102F7B3A4FD3C3CC2C5942C5B0B4E10CDFE169B
-AC9A2961B8139E4436F895C7B101D198BD568ECE617EEF5D14E3A00631463B65
-510A0D25324764C641E644079745FB55D42D30F3E95E14A3813DDC47B435DA18
-43970F2874AD4AF049C4318F978EB8E1A8CB143150BDA27BDB680D106FF5AAE5
-D2C2B05725EA9CD3A9F07DD967A573053555217011BB01296C64E9EBC8AD7D50
-CC89126B08950D0912E1F5EB19BC002910E0DC36A73CD8E6ADA1B849436A14E6
-58165CE26F473ED3737379E1527A89E26ADA2E455E818C256DD4BA5185CE8312
-1142771E26C116072C57C39256DEBB6CAFB8FA19935B0E4BC554640E2E9DE4F8
-93D439A5202B6A250A8996080B445BD5F14340F685A964B02B60B306CB58E240
-15497209303D9F58C97AD2BEEC0035182839892BC37578CFD0BF46EA9427F791
-E369A28BDC3B6BA989A8D39CEF64EA7D2B1A7A816308F52FE1D047011CAFE591
-81E10DE0BAE29B4AEF4B12EF4A992D67CA1281D2E91640608B658DF3AED9BFE5
-D45BA1184D907DDA017E7D1DBC0F6D3B2F9566282910E2BFED267FAFA7C0E1D1
-94E737D22B37E35758AD995E653525E3E87C210E6E93A5F0667107FBA1AD2C4D
-0E96A8BA2C015A6D0AA8991A2D0AD4879B0F26A194309245BB584A1E28998DAA
-D8FB5513DA50C07CB3DFAB19593B9DBAB7E99C885589F3A1280332D4985168BD
-005066B1F60BE70E0B83CF8F4F8EB16C1E8F7DB1995AD495F7BBA93589B824C9
-75A1416EE7B9628FC1F7F79B765643126311D226BECC37A37402A46F48A68883
-0EB428992FDC3C5062E5B7E3B448192322839AEE7AF6DC14098B01C53E65FD29
-A1CC4B2AFE921329EB497C075873F14FA691FF2406EF91D864DCAED6A5109769
-5F8C07383566146718FD9A595E0C45019B66CAE7E8F079E486C67573529778AF
-DCEA4E393112E7FA77BFBFBB3A60655186D0004E6B20D4219C956443C3A5506C
-BBA973D3A3CA7167B0F2F919D7848F1685739C41FA0940BB2031D14C8DE27A80
-0E86B7C28C609537B27A0A83998D87E13FBE7A296908EACC17F3CFE068F65266
-824E8B24C82767F828DBAD2AB01F8EF7760E8E81CB6A271756062B431E2449F5
-C1B8B87A6EFE59E378E32B90D3451490777BB666F33FFC386C5A1C0844B75745
-A572A122D9CEAB13F7EAD8632ACCAAEB87E7D127FF30A8E8360674FDD52EF02A
-9E49CBC8B543D3B6C75A4F5C3FDA2AAAC2100059042EF86D4414F267DA3A650D
-CCE53A84A74388BB758D1281BF5582C90B482B005EB85B58D5CEC7D400102945
-83CF3B7053436D2A3EF0043871CBE6260361A5A65DC4976083E917DEDC17AC72
-D63B8665E572119E997C8124D755808680609B8FA3305BAE80159B4B8639168C
-DF4C19B7ADBF47EB044B59D85B50F33DD627BCB5BE256EAAC31E49AAD725D6C3
-B9F40CB937440DA36629B18EEE4FBFF3C97CC78E05B6A15223721B7E6C4DFD2C
-46E347E07BE40A56CA233A9043B2752E7F1B688D258CE4D4CC31487D24D87F6E
-D555E47ADC52BDA2C98B073C5558F82A31A7764E011DB9F66C17378D9C7BD18E
-06CFD04E09E90FEAC712CE50074054BDB1473722245C771F954D82DC707ADA2C
-07FE8D915CBDE9488A7942F11AFAC94F68578AD7E245A55C922900AE0BCF5400
-B30B992F1BE115E39BDF8EC378D1ABC97E2C9B1E4C668D9A4392A23EF19D60B9
-DE6504B2A1667C2BC44A6C3C3FF3339A331E613737B8405D31F541A3D13C133F
-EE0FAD837FBE62AA2E0D5EE35CACFF0CAE72AADBE8411336D5E2CF563AF0890D
-611B400E0B24FA4625A664682CDDC2E64E6FDD3AF6DE54D17FA3E06AA9A29899
-6C48C3945D48354C486C53818519731A989760CEE6987D36921683EDC710238E
-F12E664E48D165002E4AB0EA66872E461511519FFD598AFCF8C40013A96626FE
-951B817B63EE567234483F3D6DB67B1B51EFD6399F5A2A1AAF05E0884266F0F8
-03311025F7581447E499C905C08941D6D40D900CC96E395D5FE1D625B18A6DA8
-9C840C09EEABF82CCEE14D8A37E699EFF6D03A2C1C304A734E9B2CD024F505CE
-F584326188572C3DCBCA5F87F86C9D2BCBBDDE060BE9A3A7E0837B58DBF3BFFA
-79588474CC8396C267EA9BFC9AC958F8F44CDD6E038883550B981C545E68022B
-AAD9CECDEEFDAAE54CCAFFE4E4F160D858AB7051F760A4E5E56547E094AA89DF
-1D8C65AE393BC2F64C3511914C4A2A03BE054F9D9F7E21FEC9EB17BC5489B90C
-F7AAC2D3445181F68214DE5C9F5756D001E555E1C73DB4E29FEDD3B83DC8C740
-606BB7F2CADE09AE843E6F793B43B644C2FF149BED65230D4213DF7CDBB98A43
-5D92E750EEFC1BBFCB72917DE5E92B48694EAE443E0E61B7829AE02D3C9DBD10
-DE052AD77873E6227AEE107D6E1A1143D8C73228A7E4D763B9E7024779B91F86
-6C8ED35C1F2A6BF4BEE03FE584F81C1C2EA6E348D4318441CFC31CB33DEFA4DE
-3FE77857C95633CA5D07F0E5F469DD3207BC3F412648F722C4D41E8D97E5A01F
-41206917FCC02BF001D8A0A8F7F730B2C4ACFA76477F05ACC3376DFBF406A7D1
-A864F8DA0135F7B7F1C9425E5443652C68290C95FAEECF52796FE535A697F826
-C45A61E7A4B0BCA34F922D2632269CDEFDAB4460914C8929CE7B3986CDA53412
-6AA385A333BC7BBD00859B4510C52E127E6C902929D38503A2E8F3DA5ABC6000
-2B553111F76EBA3E1D8AFE526428A12DF12FD63B34FD47594A04E30C2B9B5222
-34D727126BB7491271FCF53AD99B08F6F25E7075F6ABE84EACFBCF68B2F671B8
-25ACEAD9837A6075AC1933EA504CB5F7A14625DD403D2ED0CE39898C5C8213C6
-FC4B4029E8CDF038923EE870051A01C5EBBF429C27FD6D24BDB7F42CF138F7AE
-AA621381737C0E48D455D06B379C95A0834B06CF51ED2726022FAF623187A674
-84160C0176B33DFA8A69C06E58548BF22E8E4F7AEDFABF0126FC2DDDE0DA6D4D
-3C6D3404E4DE7449D8A9466B96220C561C45BFA49E0A5EAFFDA325899B998313
-E1357938D77A423FA8E030847194B74B431F66EF9F999ECCFF367E18C13DAFF4
-C089189DBB212D5DBAE560C39D720A79006F8CE5D3ED94EB2181205307952C5D
-0BF0BF653E8FC0F384ADEFECC12CAFE85DB07BC8D8D98906E05AF72FC75C0694
-A1E2A2A2EE33008209A439D43640560901555AB1B23E21EDA992DFF655F9A0FF
-D4FF5373FADC829F0F73336DFC430FC034800A06FAE1AB1A5DDC9CFF2EE2C387
-0FB4904C1782B27804B3AE24C881A27CFE86DFBD5D9C2E2D30D48446D5685087
-91DC6488480592AD3581484A0D03C313D414EDA0A93268D9474519FA1C36F8E7
-09EFF3B9EA119A8CAA1FC58BC3C52952CB85BBF7922AEBA5EB0B247A6935C4D9
-FA88959AC9705FCA507AA491EC221716300878D45B906C81FFCC9A3459545BDA
-7AA34489920D5F6A097BCB45537E42F16CE06C2887363517793529B14AF2EDDA
-1D9FE40B4417F6FC94F351DE8574EC38B0B9FA9DBD000333193C3E1BE4CAC784
-F39122159FC9BA5DB8B5C3CAA29F398EE028788DBEF6FDE762A841A7ACAD7CD0
-6BE08F95327AF2FFA0B0FEB4620FAA56F96456681B296307DC89449AE033895A
-7104A8AF26D610FA877F9198C64BE77D309B2D65FB8EB8832F6EC6B9BFB701F6
-B1D6F88ED90886E03E3AFDBACF0BB8A50C49C43E7BA124EAAD8400AFAF4053EC
-743B9FEB3782C916705EA5AFD50DDF4162D3FDF44BB5400EFD48BA9D2137F65D
-68B418DCC0F2B7C90095148014DFA0C7302E711E8D9C2D44B588BC83B85698D4
-0495D50225A4CFFAA1AF8B1DE6F6214041DEB57BA19215A028C8F0BA0810DBC1
-A59E0F85A5A444E76A412A78E5DFCCC678EEB2A3993850310A5DCB1531B6B3E2
-7338CC84686E84D601020E0F9C2E4C12578DC5B48E76DC53E9324E864654F130
-4E192D0B798865B0D15C063C8E42A847031A7D4EC69647A3A45768C3C047A5EA
-EEA2DA6943D2A933A156EA51BEE6955D31B9B7D2A999EB3EED12D6378E3E0971
-1C280F204CDD8021A2E860235BCAB3CE278D14B9A00981B2AFA3F23B32BFA909
-D66164FF88535FF1EB74B03705
-0000000000000000000000000000000000000000000000000000000000000000
-0000000000000000000000000000000000000000000000000000000000000000
-0000000000000000000000000000000000000000000000000000000000000000
-0000000000000000000000000000000000000000000000000000000000000000
-0000000000000000000000000000000000000000000000000000000000000000
-0000000000000000000000000000000000000000000000000000000000000000
-0000000000000000000000000000000000000000000000000000000000000000
-0000000000000000000000000000000000000000000000000000000000000000
-cleartomark
-%%EndFont
-%%BeginFont: CMSY10
-%!PS-AdobeFont-1.1: CMSY10 1.0
-%%CreationDate: 1991 Aug 15 07:20:57
-% Copyright (C) 1997 American Mathematical Society. All Rights Reserved.
-11 dict begin
-/FontInfo 7 dict dup begin
-/version (1.0) readonly def
-/Notice (Copyright (C) 1997 American Mathematical Society. All Rights Reserved) readonly def
-/FullName (CMSY10) readonly def
-/FamilyName (Computer Modern) readonly def
-/Weight (Medium) readonly def
-/ItalicAngle -14.035 def
-/isFixedPitch false def
-end readonly def
-/FontName /CMSY10 def
-/PaintType 0 def
-/FontType 1 def
-/FontMatrix [0.001 0 0 0.001 0 0] readonly def
-/Encoding 256 array
-0 1 255 {1 index exch /.notdef put} for
-dup 0 /minus put
-dup 2 /multiply put
-dup 3 /asteriskmath put
-dup 15 /bullet put
-dup 21 /greaterequal put
-dup 106 /bar put
-dup 107 /bardbl put
-dup 121 /dagger put
-dup 122 /daggerdbl put
-readonly def
-/FontBBox{-29 -960 1116 775}readonly def
-currentdict end
-currentfile eexec
-D9D66F633B846A97B686A97E45A3D0AA052F09F9C8ADE9D907C058B87E9B6964
-7D53359E51216774A4EAA1E2B58EC3176BD1184A633B951372B4198D4E8C5EF4
-A213ACB58AA0A658908035BF2ED8531779838A960DFE2B27EA49C37156989C85
-E21B3ABF72E39A89232CD9F4237FC80C9E64E8425AA3BEF7DED60B122A52922A
-221A37D9A807DD01161779DDE7D31FF2B87F97C73D63EECDDA4C49501773468A
-27D1663E0B62F461F6E40A5D6676D1D12B51E641C1D4E8E2771864FC104F8CBF
-5B78EC1D88228725F1C453A678F58A7E1B7BD7CA700717D288EB8DA1F57C4F09
-0ABF1D42C5DDD0C384C7E22F8F8047BE1D4C1CC8E33368FB1AC82B4E96146730
-DE3302B2E6B819CB6AE455B1AF3187FFE8071AA57EF8A6616B9CB7941D44EC7A
-71A7BB3DF755178D7D2E4BB69859EFA4BBC30BD6BB1531133FD4D9438FF99F09
-4ECC068A324D75B5F696B8688EEB2F17E5ED34CCD6D047A4E3806D000C199D7C
-515DB70A8D4F6146FE068DC1E5DE8BC57034F6B6A67AB666E15104577F342F68
-CDE6AB4EF53E08A8E0552B76072FF46E80AC884959B54D147A9D5105D1FC6B3B
-BEB747B75D6E6A3BE833BFC95FBCB2A23A8697CF76D1B9F09F567345137B24FB
-84474441D5CC4C121EFE1E4AEFC2950C042F8C4C40FB10A631242F0A99BCA589
-D4B03328602937409D24869D80E6408319F42E1982A6426352CCBB6C1BEE79AD
-8CA6E8C49A7B752D6DEC5707AEFC6E7A7A7FEB9DD51ED1C6703D083C18F34D83
-589BB9DF0D0EE93A9D15623226127DB28CDDE276107C9CBED2F576FEC8FF1042
-42B66FCF98644EED8FF119653C032EA2E736A5F0F869D380EB13EBD3F4B95BEC
-4223CA8A47265C6CE2E8859C3CF7079465D7CA5CD067785829187E645D2DBEE3
-DFB64169EB31BA062FFC377655F7DCC6E2579038B4D8CC6D269A2DC9F040C423
-801B889713A4EC856097FD71223094CB35B3B037A5BE7F28D1C473E2FE42DDE4
-F16F5C1AF3E29247C58B0F9288411F926BEE5F3A05A9D74DC2E2E438308438B1
-F2744E927E164C05070EE525FFE45A0055C14CA5F35DC4F1246F1A300461E48D
-15FE58FBCA01FCD277CBCC544F6EF52C205908EB4BFF55568026F8AF1F9453FF
-27B0FC0B1180D47621A67B944DB43D6584D1BD46B788C13423AB4552F8163047
-C76A0368A1CC45B962C36852DD80BB03BBF0AFC1D906CF176FD08A71EF56B919
-AB94C50D05BCEAAE427531E09053D4885ACF4DAF592897580484378EB2CB9C44
-6513B8E718CD0F20F54666B4C4B1FBCFE8F5FE2D3C3237D79C24861462E3A142
-D9D40B38B12D83B58D6E52F5F771D016C970E5CFC264F50CF844B3A9B6463B18
-E5C44E316F5836DB33B40B2E2E760926622BED0CD21DBB2EAC1AF9144E93868E
-52E0473FE0485C84EB1F2C342A8E282C9CFE6B6F710764344EFC21F058DB25A9
-A9AF6E085A915340F5521881718AF08CBC0EC06F31C0DA098793EF6500A17277
-5CE37D8AC753BD0ADDE71A846DBB15781C4DB709E77C56BD968BD5BEEC9C6FAF
-5865A574B1952E23C7C9CBFA3C05B6CC7E1DADD00AB73F4D1B14BCE59373C7BE
-DCD98F44C0136040E899C38FD6370F4439C832A6BF4388325ECA3ADE7BA67D0B
-551EC5D347DC0E15C269A2BE1EA28A7688A8A68B95CB13231D566498B9DB4A81
-F29FD32B1CD8681F5E7C4B17EC0D4EE4DB2BACCBD0B48176995F8D8782467359
-A0185B85D17159F66B90F158510A1F32197132B56E302480902AF31D1113B979
-51E9C3D0EB16739F49E23A9F908799380DB5137DED7E0299987A5B918CC370FB
-616E4DA8C895956C9E3D7A910B62EAA610B27BF97078FE5B29B778576E65D3FF
-91A0777862EEA8AB8FF439A4049435AEDEFCD7FB3A1085458C404EFCFBC13332
-37553A8DE2F71B303667A67E2E246D368A0FC2B2A48F5ABAE2A3A61FFA351C67
-FE0D9C1779A1A8C782AF9723F994CBC9D64C32D121E895690AB02E8AA2A880C6
-420D1F963922562A327F63B55502B78888DD637D24004A39A1F0DEFD6C32B7C2
-866D18BAF0B0255503A1E3F4E79A0A60FA43E477AD8DFD94E10F3E102195363B
-946C23975AC20B7975DB010AB849A77C9CCA815E0BF044E61CAF0837E6712F32
-AD8461459F513D7BE79623F5AA2ABB20A94C233E2263B4230D9EC02966844AA8
-907CE05C3C384C1AD44A842832321E4DF1476E57681807AA245797BC993EB2F8
-F8EE6EE2C4D2C67BA06B781D7EA11DE3E1E3AA5A603BA66736F937647FAC7EE3
-A8A7674F872933105289C4D7C7F89F02771DBD555CAC91EAC8F96F31EBA543AC
-349BF0DED00ADC9F9E52BB8BF7C8BCB8EE48914ED4214620D13BE7300ACA4F93
-45A8A648A21A319D1A97B8183CD0E8AA37D874B6E85995BC880124D885D80D68
-6285C2F9EA352DE347BE224C233861596ADAD04AFA12870A50C292F4CD526345
-8624ECEF4C9C973C8A2DDDF172F6C9B0C25356DFBFE35423B7FA803609F03832
-F0B89BEFAF5EDCACAE074E77AA5466427ABB0E75F940631E100FE52B9B6D08A7
-677FAEFD848FDE552E57B63E26763ABC0314AACF5AC2E4221FD1C52E1F74633B
-2D42D66DF8D21BFE933C5D7087BCD0F67A341D61ADD6EC5689C26C4442CB1EBE
-C579FC92DEDF50E358C2FC6675CDEFAABB3D933F5C058F35579D4BA3913715DA
-B7A8A16DDA9D644D2C190CB307F900D071117D12F34FA84F7AD241413AD31581
-A9B96E5015A288D0AE21BBDF866486534D99FAB9C17098F3587241FB8C2CB384
-E71CA1EAAD
-0000000000000000000000000000000000000000000000000000000000000000
-0000000000000000000000000000000000000000000000000000000000000000
-0000000000000000000000000000000000000000000000000000000000000000
-0000000000000000000000000000000000000000000000000000000000000000
-0000000000000000000000000000000000000000000000000000000000000000
-0000000000000000000000000000000000000000000000000000000000000000
-0000000000000000000000000000000000000000000000000000000000000000
-0000000000000000000000000000000000000000000000000000000000000000
-cleartomark
-%%EndFont
-%%BeginFont: CMBX12
-%!PS-AdobeFont-1.1: CMBX12 1.0
-%%CreationDate: 1991 Aug 20 16:34:54
-% Copyright (C) 1997 American Mathematical Society. All Rights Reserved.
-11 dict begin
-/FontInfo 7 dict dup begin
-/version (1.0) readonly def
-/Notice (Copyright (C) 1997 American Mathematical Society. All Rights Reserved) readonly def
-/FullName (CMBX12) readonly def
-/FamilyName (Computer Modern) readonly def
-/Weight (Bold) readonly def
-/ItalicAngle 0 def
-/isFixedPitch false def
-end readonly def
-/FontName /CMBX12 def
-/PaintType 0 def
-/FontType 1 def
-/FontMatrix [0.001 0 0 0.001 0 0] readonly def
-/Encoding 256 array
-0 1 255 {1 index exch /.notdef put} for
-dup 12 /fi put
-dup 40 /parenleft put
-dup 41 /parenright put
-dup 44 /comma put
-dup 45 /hyphen put
-dup 46 /period put
-dup 48 /zero put
-dup 49 /one put
-dup 50 /two put
-dup 51 /three put
-dup 52 /four put
-dup 53 /five put
-dup 54 /six put
-dup 55 /seven put
-dup 56 /eight put
-dup 57 /nine put
-dup 65 /A put
-dup 66 /B put
-dup 67 /C put
-dup 68 /D put
-dup 69 /E put
-dup 71 /G put
-dup 72 /H put
-dup 73 /I put
-dup 75 /K put
-dup 76 /L put
-dup 77 /M put
-dup 78 /N put
-dup 80 /P put
-dup 81 /Q put
-dup 82 /R put
-dup 83 /S put
-dup 84 /T put
-dup 85 /U put
-dup 86 /V put
-dup 90 /Z put
-dup 97 /a put
-dup 98 /b put
-dup 99 /c put
-dup 100 /d put
-dup 101 /e put
-dup 102 /f put
-dup 103 /g put
-dup 104 /h put
-dup 105 /i put
-dup 108 /l put
-dup 109 /m put
-dup 110 /n put
-dup 111 /o put
-dup 112 /p put
-dup 113 /q put
-dup 114 /r put
-dup 115 /s put
-dup 116 /t put
-dup 117 /u put
-dup 118 /v put
-dup 120 /x put
-dup 121 /y put
-dup 122 /z put
-readonly def
-/FontBBox{-53 -251 1139 750}readonly def
-currentdict end
-currentfile eexec
-D9D66F633B846A97B686A97E45A3D0AA052A014267B7904EB3C0D3BD0B83D891
-016CA6CA4B712ADEB258FAAB9A130EE605E61F77FC1B738ABC7C51CD46EF8171
-9098D5FEE67660E69A7AB91B58F29A4D79E57022F783EB0FBBB6D4F4EC35014F
-D2DECBA99459A4C59DF0C6EBA150284454E707DC2100C15B76B4C19B84363758
-469A6C558785B226332152109871A9883487DD7710949204DDCF837E6A8708B8
-2BDBF16FBC7512FAA308A093FE5F0364CD5660F74BEE96790DE35AFA90CCF712
-B1805DA88AE375A04D99598EADFC625BDC1F9C315B6CF28C9BD427F32C745C99
-AEBE70DAAED49EA45AF94F081934AA47894A370D698ABABDA4215500B190AF26
-7FCFB7DDA2BC68605A4EF61ECCA3D61C684B47FFB5887A3BEDE0B4D30E8EBABF
-20980C23312618EB0EAF289B2924FF4A334B85D98FD68545FDADB47F991E7390
-B10EE86A46A5AF8866C010225024D5E5862D49DEB5D8ECCB95D94283C50A363D
-68A49071445610F03CE3600945118A6BC0B3AA4593104E727261C68C4A47F809
-D77E4CF27B3681F6B6F3AC498E45361BF9E01FAF5527F5E3CC790D3084674B3E
-26296F3E03321B5C555D2458578A89E72D3166A3C5D740B3ABB127CF420C316D
-F957873DA04CF0DB25A73574A4DE2E4F2D5D4E8E0B430654CF7F341A1BDB3E26
-77C194764EAD58C585F49EF10843FE020F9FDFD9008D660DE50B9BD7A2A87299
-BC319E66D781101BB956E30643A19B93C8967E1AE4719F300BFE5866F0D6DA5E
-C55E171A24D3B707EFA325D47F473764E99BC8B1108D815CF2ACADFA6C4663E8
-30855D673CE98AB78F5F829F7FA226AB57F07B3E7D4E7CE30ED3B7EB0D3035C5
-148DA8D9FA34483414FDA8E3DC9E6C479E3EEE9A11A0547FC9085FA4631AD19C
-E936E0598E3197207FA7BB6E55CFD5EF72AEC12D9A9675241C7A71316B2E148D
-E2A1732B3627109EA446CB320EBBE2E78281CDF0890E2E72B6711335857F1E23
-337C75E729701E93D5BEC0630CDC7F4E957233EC09F917E5CA703C7E93841598
-0E73843FC6619DE017C8473A6D1B2BE5142DEBA285B98FA1CC5E64D2ADB981E6
-472971848451A245DDF6AA3B8225E9AC8E4630B0FF32D679EC27ACAD85C6394E
-A6F71023B660EE883D8B676837E9EBA4E42BA8F365433A900F1DC3A9F0E88A26
-30F19E1BCE69BC499D860F9B17E6A78469F652E1F327CC0F46597373C632CB29
-0024F4D106BFB1238E71B84E6AA5B2484CF0DD8ACB90BE5E4916214130582DC5
-BC26EE23C6ED239A49243B7911EA4121E5BEF60E3379B6685F548F185BE9EA5D
-C95E517502C6DBF8590DF15D0C02C9DA2A1E8B4DF6BC91BCC47A7CC93B3FBFF1
-809BDC20FFC64F51465FAB3E491B746843AC44366FACF4E832A46C41BF4E3C24
-63BC9F166A8DDBB29AF7A52C88854A80B3535573458670CEF7803A6247CD6E86
-0320A45778B09FF104C07A1A878C6B78CA980184C80B8495AA0829480CF3AD57
-7C3875EF1C49300D6FDE665C6617A5D424ABACA15ED6AB979840AE517A5EC2D5
-100E065B60486C07D3CDE77361209298AF003BB6CE23753CFB96BF3654E4F4D8
-0F4F1F85E6FEE5BE8289C31697F19960768430466888F8C76F32D4D0D7612BAC
-C3D531B1A6C45EE6C8A481A6AAE03B4719537935032DE9695D829968A9251F3C
-F0F5E1A60A590A5A4E98C992475513AC2721FCAEFBA8C0C52F84352012767B17
-A170DC205ED42F95F100851B9E6DEFBED916DF9FA37880A62A459B6D00E5562A
-90D6A8D08643275D05CA4BAD67234CC5FC44BF8354A988BEFA4AC5F53B954629
-AF85B6FF9218A6AEBC31651AFD1E8D051C2BA28AB1FA7BFF083CF9ED849D2F80
-166F0756B627C35F424CA2B70F897C2143D3D24A95A1167462758B933CD27E3A
-384C6E3EADC96743CECE944AC61DB601CFDA0D90F04A2DB4C8F486AF2FA4671D
-2D63D9518107837E8777D40C1078551FCD23C653C241CD9D5F51482C0FBD3EA4
-20F3C4D14F47D60E390CFCB630578E6052B0BEC70F28FD87623C024046C3C219
-1FA521528182AA6642774EA7311432D03AC4740D683B550483D940130B1CB311
-04746C1848FB5B5EE5F1BD109B58C86DF64371A169E4DADD61B352D8EBA5DFFB
-E3A005C95A91FDDCC71BB4CCE5277B1734FB8C9F3293A33D3556159803648F15
-7534CDECAB9D1FA36A964AB92B380E4E5014086A6691916594EA438AB18A4210
-5A155C5BE25484F148ACD95EB59E939F86E79CCB86141A09306FD2808F5A9916
-2B2281C96B8DD77DE45EBCFB93697F832C36A682DFE4806A057B67D831D971F1
-22DF3A9F62974A042AE53DD74FF8F83DB9C4131B9CAC4D83501A89EE401B49EE
-E5FB974B00318CE77A115A8971312EA7D68F5C4D43FB70A90999CB95650D5949
-96C20650200F0098C69C2CE4C4499AB449732007D634A826840FBC4274F29600
-7ED2DCEDEDA74792832E3D059505B422384A96422BDDA3127259F34C5C97B042
-FB4E6745F3BB77A9657679F8042EAF0E5C2649AA23F800DDF7B4D38843B2C8D0
-AAA56EAA482599CBDCF0CD0848F31BB27527A444147E7984A38D5ECF017D9339
-0A36AB57CCBC60A08E2C6F15E43B4399A5155E7C484D4AC4681388FF9E33131A
-EDE9DB002CF851AA2E57FDFC01B6553B1E18210173B2F0CCC57A0D18EF8BF3D1
-77C6817EC7A6BD2E8C5C4429D4BFC58E490F82D9855A3F5174669BF6C0F72900
-A9A4767AE4BEE0D24F9A8B8237D59E44E871362CC6D28CC0513842E00CC780F3
-7C22C1BC325704FD11BA743DD1F3F3B54CF4FE15DD1665687542CDEF9D4AB659
-744D3308727DA3C890B237F3069C6AC7045C6269C32EF582A8560D20BADD4E14
-EB9B510D47F595F26B93B48E9FFC81D7BC519CE985EB072E6DA8598E031415C2
-16F78C8D855DC1BBBF355BADC0F04AF0B5E285D6ED852FDDBF25E06AF443E559
-5710EC45D6EBA52F09854FB71535964AE1FD2E74D458CF87CC786AF6C990FE81
-CD7EF456EAECF76CAE6EA9835715DE11F0BDE67E628E6A5B3EF3A12D9F697FDA
-158D30DC457929CF40951DF6D3D2A95D132CD178A5FF042FB886278E95401B08
-35761DA6F10631C4083FA4DF97A4E43103377522788A9D1AF845424C3F41BA7A
-A39A66D2AAC43C162CCB78D1486C480931A34FD4F3A3B934BC052F789E6820E1
-FDBD9C8A95BFBB179A017B354C1DD91F9118E4C9C1B2D5C29AD4FB92871094BB
-B0A722C17FACEDC7566AAFE0EBEA4136731A7252C2E6E7F74375F8EFC0B77581
-3FA3188840B04A9DF570CAD3CD255CDFC37B308659AA9803882F7B5E47F6E47D
-C8B83C9B3E0DAF531BB2CE8C00E563CBD484C292BFBF1C124E93ABD0F7BCFAC9
-EBB49639291353908047C55A9A2C20B3466284CC845A32FFD8F43FC6327ABABD
-B8CF9DDE96C7C1B5B327CD2F0FF47C70120724A3DD47B3773D9A51BF334F20D6
-3ABA69C7963E72376AD49BEA11DDC1CA4A70507C578C683B1AE6B160FDACF86A
-6BD9BFA9D8D39B14B6D7A41F08C4CACD1299B622D1D6A98E9F7FA9CD1AA7F6BB
-ACD4A26D57FD6AF6649E877F6827C46D08BF29C6FB3084F30159590266F10696
-4A196F931582C488A4D820E9EB827F8051C939C71658767BE31C62425580F3F6
-75B6E352DC01F8F5C8467DAB29531B8277DF273118F3FBAEED7EBD57AFD24DB7
-AD1D2B18C20A7627E7ACD44F8A7C7AE1A6193B3E6CFC2C40C70F018126A45F14
-907C6DE640AFC0D8A6D0F4F3031A9BFA5C804F593D7811614F4DF98ABD83477D
-3868E8BF0C89B9074E34BB9C0387F634B749941C3D16ADF3CF570F14DB1748AE
-2D5CEA6B84EE64470571CAA5FEECD87897CF745401B12213F2CA0EA774587FB8
-8E4705FEC4FA063E5E9EB610ED095CE7A8F8B58DA15D00CCE283B926B4FC225A
-216B8E595B9DF0244CB62EFD8FE0C5264DD195BE96F4D45F472672C4A3965ED6
-8FCE75116AE79445F7877DA64AA809B2B229FD7CA0FB88662A4DE6CB1F9FF34C
-D14DF9A64AB7F4E31564B6FB84A96678AAE68A3FE06BE23E48B752EF997CAA28
-43303A3CC38AD965623F9BFCACAC717115D8A7B99945359B41CA11F6C1E9099F
-CA0911552C7B7B2EAB703174C90565B0BE0133BB4B558E32F30B5B821B09B15D
-9CB2C65144758AF4E449ABF5F221C1C7E2DD3265023A93990C5271492D40822C
-E7ED9126BDECCFBAAAFE5127DA325C77FC375F1A98D780996BA767A0962D8334
-F56AA75CF26E7BA36AC093D72989299CC1D0B20008E33AF515CAE12F899B5A64
-C948906154B7CDEB5105F228076BC0D54B202E7DE03483B6D3E1D0D29CEFC939
-293B0C438AD9B1FF8546BEC3A484D1BA4CD5B9A238D65AEE7EA484EE0D8428E9
-41DC1B6846644FBA6FF066788AB15F0EAA730FA116E914B339CA765A6A8B93D6
-F1129E0759E53FA4451730A75FAC0A4EF3771519F9C6273E0439E20DFA978196
-69BFEF108FB14735887E0AD363CB3DDFD4212CCD976F35FE0704FA7CCC5B496C
-6953643536803BF212CB1DA8050C331FEC075AA060E0C3604A8B649542D72FB6
-2401DAADB6F04EB44F0959B9BB090955C7F5847CFE616DA502E42522D7B6D32C
-0CBDA0450E16D1972C780DABDBA36281E46F2A6669648A47948B29A6EF898C10
-CB602ED449D9B3339C0263FC24A987A4B3437F67627DA20F201974040C54F95B
-84D0426ECD8A5EDDEA670E50C969FC139B94838AA85D7A1C5E6516BD4A389446
-90AF8CDA506C91E202999DCDC5197D1482D17099530440423B76B5DC0D046D18
-5C1B643ACA8FAE21E03D30672705E42E58EEF7EAF572532E6986731F75B2B4F4
-6680FA9072888B84E01CD92C3447D856712220DF37AAD6E33C13E76D70251C19
-4652712D3F6D44A069AA611915A73C42E1649C907FB53F211DCFB7FB64006EC0
-07160B4AB1DFFA41AA14213C7A2BD2C1CFB8A8062C030F6EA4B4F129A083EDDE
-E5DA866AE0B35930E1B68C129F1D03C85F4D7A76B681C9D676631B2B8B6973A8
-816AF640E67EF0153FF91A6A9BFB1A8F48F9502699A3D54D7B74D7A9F7252367
-78EA29913880B7F8E7801AE8CBE8483F9EC70BB1747B456B00683D51D7B5E03C
-A21A3A77376AE9DB41E6BE190C0443416E5ED492462AB9C5E561C80E98C42936
-B69F8A1FBA4C3BC847423B672C6160E4261103D7244A07BC8B958C989A79A143
-A06F4B16D132191EFF5729DC2488A05DFF7381E02A775BADD7D4C6770DE67432
-B76CE31C5562EB6029033371B64861027D0F4B482F3B7C820ACCD72F714DE076
-5E81F108AB995C8645FE122D7B6AD7072403FEC7C3E93F2191001085DAC15523
-569391DAD826D7A2CF377A3CFEC812EAC64E7FD415B0D9C0B9DCC3A52DCEAB67
-4B71604A2B8BD355BDA2A2BA610AAB1C65FDE10716936D012E855BEA69AEE261
-544B3AF03C564FD8B13F5F5D8861B0657D4295DA7D6A03351B237649FD1F6597
-EC1A1C03E42ECD9868133D9DD717655A3F873B9BB98FC06527462F90965DD3C6
-5343ADBB00888E17681D2D3EDF3DDA789E51AECD3BF2BAD0591BAE8B03548AD1
-28EFF018CCEC16071B902B1321F417335D50716E930FF70A936FDC30A3EFA8A7
-991ABF38BD2820B64694D57DB7F1C866FD1833317A69D6736F39B2785F5EACA0
-706B0CDBDFF34BDE47406080A5FA5E844AB89A0915216CF11B0483D3F1432424
-C961319ECF0589C052B0D6F8908B6466D2BF1952CBF553ACAA0B7D252B5DCF63
-8EB212BA4E13DEFFF2913D43A1F898E781E716AD91F116083B41CA16D24552CC
-3E1706CD87B6E01F14698C64889367BECF0485C1920373B202C04E591FCA83A1
-0810BBBAE4441EA288046246D0EA3378AE0C417D263720E334E73AF488D5CFA0
-C27FE75F7A4D7329E0999D08D23C9D76C8B17584F2BC8519BCFCCDD8D731A27B
-8A7EBE4A194012D159C1F7BD6796AC2950BD7A3D47542FDFFCE5B7BFD5D2C05F
-B2D82F8A7D2A7469EDBD4559090D528362BF97DF0CC686EF549D3CDA349D7622
-43264866FDE915AA25C67EC387C9E87CBCA12CF5A2E431F118498CB8CB4B4659
-54527F0CB32B73C79BDFF55AA67EE4C71A2AB58BBC47554264AA514D96737C31
-B506AA8D4FE74126074E9225D6781DEF9FA253975D51E12E5485A7C3E4900CBA
-E0CCFDAADE90CA8B02162D4600CA4D1163A1045CE3C70BFDBBA490551B03F13E
-9902EC46F18E42DE95740ECC680590BEDDA60FD41B5B9812ADCE7F071881B925
-867A6F957E05CC8E0584F76293A3694C6D4CEE9E4F0DAE694297014A4E501224
-EF5DC464D4162BC36488093057155FBEFE36EF39DE79F385C509FD86A268428E
-810981FF11194B47A4627734359A9CFB5F47E0685E0428BD2D670B218618F229
-697A438064165BDDDB8817073C64CC58BDA04EBA5D5B8C04A93CFF4BE9A2F900
-441B78BD58A91D3FF452AA5F397A5E3C9B11E9CA7D0C6D5ABD57DF1018E16B5D
-14CBF15F2B5D7475CE41FA72384BC1FC48A0529E9CC78E4F6627929088F49297
-F312A04215789399B0B1D78941C654BF3D1A470D53D137DF9576D13EE976E0FF
-CEF5D97F7B3D371B0C619F818D53206EA36F7522807823D0793CA9D809F1B478
-75ECCA485D819ADDED65202A89963B6B1E5A4A25914FB85EF529A93AD3412F5A
-B9FCCEE578595BDF613E6EBCEC0E507A625004B0901E86EA31BC1851396E0F11
-D88C7B2A519C5E3454A1F8A1099C60DEA08B99CC10ABD4DFC93099E2E13A6FAA
-78D7FF2093901974600F84D5D91EC421EE832093FB679D980EC50C6D84D9E7ED
-BAE28D966101D85CDBD1179A193BB717A254927A21390B353F56DBDBBB68795F
-776F6FB1DB6F6D41B7D5342D36AEA6E1F859509B83DA6406AFF45F71476FD2B1
-612A5A391B010D1309A58A7CA7FE585678DA272F367BA8D0539453E92F2348F3
-208898151BA6A7E8CEF4978E026911E7CC3D2E3F11F168011412B739D4539FA0
-77F869EE850646BE93001A709E4CDF1150E877427F8EB8257FE6684AFE5E616C
-ED622C67013DC928EDCE79F2B4AC3CAEA629995FFCFBE78109EC4D5D9CCF50E2
-363D8A6DA585A43700A862714742118474355614DD000CEC4722E5F6A5847F1C
-F888A53665CD7A9B667589D7FF5B533A513E4F19F93D2FA9B86A67656C1104B5
-963D6C8173D4F181EBDF186763ADD98E4499518FC0CFBFF084BC509DE4627D70
-5D1EDA79EECB6B8E626CDEC3EFDBBA5C078FDF2CD197E73980F80BC61FF113A1
-2B4A405B701A984C89CAEA97A88C87B53F76FAB2F75AE0819416FDC4BA8BE946
-C25323AD04CBF73468E9E8CF64D545C1E0D5FE23792D4D48D2109D8787E7CD45
-28E000F8E4934EDC9F90A89A91208C65E31F136B1AE6D3530B988DC77E0818E3
-3E74C5DC72683965FB8703DE9D7D5648C506D0974D418F3F308622E2FFE5AFCE
-FA720A0A5BB82CBE653E223CAF707BC3FD56D6440352A6CD7065EECE635C68C1
-44B392D355FEA81A4F3F1D9E4ECDC8C0B48826118F5E5832AC9E233F6DE00D0F
-2545C44690AA13DB1D09C4CBB4459E58C0A33E052CACA89D9F398361656D3628
-485E1FFD4F027020B3422CD80F1CDF283F260AD42CF93FF8B24940DF358FE1D7
-E75196447CDEF8541BB215788D8AAFBA1084901184B20885297CDEB68586846B
-B3440CA8F066029C20FD6F2CE9F33E732FEDB79C874DBB8C0B6C33A2706E3AFA
-6F625F48135B65D8FB91F2A8B9A2E7A3891FC07A79487445F6802EF8D69A2FF2
-029B739266148AC675D2A1EEE1194D75276030B9BD16B9A596A335587CB157B4
-C415A249B54240DD7EB343B60DD97439B8A93605EA58BD18C5A3F28F5B4505DC
-17549AE0F88030B4F59C96F1EB00B02D2DF7934A605C6698CE71692EDD7069F6
-2149038F08DB3F15F3BD881A5F3F57D538A2E481A4A4F38C6A6A9B7E99BBB353
-5D4F68E67E7718F0C32032E3B78D93040F91DD2E7499E24660955020613273DF
-0B1FE3EEEDC01D8D5D9DE9AA2EB5492AD936129D5BEF48F8FD677ACA7D3ACEEE
-A467493381D478F57328292415BCBA25539B6211ECDEE7DB867D4FAA404F1298
-2EEEC3E92B9188B7E69DCA33E0F4B819A1C7E23FFA8C24D3E500D5590D8AE8FF
-E41AD476A1416C7BB0E44DA2E575446F3DDA76990CCCF85C60D61B913DCD91B0
-F56DAFDA55B0FC7626F4B6730933B623A22CB2F16BAED949C0A7E01801F44D47
-DA5B37884A05C3587AED8A7F58A9679E50B8E688F426B87FEE7A5ED3ACE2F5F2
-91F8D8C5639E2D2B183530F359D90FD108140278FE3591E9FC318347FED4D56B
-25F95AD951509721A784EC5A800832D72EE03698FEDD42F44C1BAD22A95BE7C1
-10B8D9EA0F29E24FEB76D0829B996B5801B9A3FD705F873432B0BB912FBE5525
-9942F6002CDD38F41B6A2C5346B62BCBBFFA0184D98136B8FE70D2E3B2D3686B
-1285E358C3AA1B3E404A3A9277630EE23524546BB817F7494443A254DF391C45
-9B0E029BE8E550F5852037574C57E745B1587CE2DF9D26BFCE979851AA691F12
-2BC689ECA8B19201CD3FD24C3E24798BF5E031520BBD233F222D23007300452E
-5A0CB7490C86332B5B03D150FD6D9AACD888A7F9CEC625836FA5F28461DB8445
-E53F923BA21C097DBE7615ADC0F0D4D56DDCEC2F8E6DF57DED5403AE331BDFEF
-ED104146725602DB7E97E07499D37CC2161877B0C86F7524866F14A670FCE79D
-9349844194E5A90365073E17991B0C3618D64F4DCBCA1E0C1CAB4E0D74F6B298
-4CDCB6A0BB3588A4006821D6E86D7A6DAB5EA62CEBF2648B9A14E215B0D106BE
-990FC653E2E4C202DF29C270C35E22725132C43B7A90492F33480A98C5B40D03
-DE79B092A34698F12E8C2FE3639CBFBB5AE65E7885FB908835EEAE8132C3DC98
-30C09BD9AE469B9A1A9477D01C72E9E813D5D53E335551DF7041A31475EF9ED4
-106188738F2153F922B49652BB4E28E3B2CCA8B62D3DFBC3288F88E17686D572
-6ABB9B9224E8EBF2ABB75E6F296389519201C62F8814C75789069C010EAF6221
-09D76A3E2D4DA88001859FF8EEB7BC5E951FA006D610E77C2EA86972A181F280
-BE6A620831E6AF01518FCDED5D8DE72B033785D106C69D3D6A6979EF335330C3
-20E63F1F5266E92B680C32615AA0A70E79CB4FABA81390FBDE363D6EE313EA2E
-345ED24396147CAE933F1394FE2A0E5F07FE09C344DC7D0B23E069F333EB3EC9
-D17C877C481652244D1F3437032338587AA19E28F4A320BD03CE702C67380657
-0B44263346669F57D7C90E64FFB584AF2BE15981C8EDF6B65097EAA68AF65391
-A769F9F53F826119F3524D3100411D569DB4B030AC046A0FB2A26C09564658F0
-84A537580912F9E001877E66BB43172BBB0A40C73EF60AE9C3A791DF15C0F99B
-793321888543243A81259EAB31DDF383B5B08CE989A8373805FE0C49050E0210
-B07F17FB5F57D80FC977870270E5CCC39D7AEA7C7070D99136FBF6EC505E5580
-F806D36FC7B85BE6501CD00CC580F80761EAF779809149F34A7F234374189318
-4188F7B9465A278719779B356EE007FC7BA0D23D549414D31F931F9D5749B2B5
-3A4BE4C6E658BF3ECD68F129AA4CD93A19AA0054C9F2F1356128BB801A8BE677
-315D11C828F67109B4FE65BD2ABA965E7C918664E00A647A6D43A301A0EF3826
-48A5DE00F831F216AC1DAA325F5E39EE553034BE86F5E32A3AD1B71CC08935B6
-B6ED2AF22D72D146154A8CFF885AA948BFBC13E0260FB4246823AF4CDDF0C731
-7B2394EE04CC7565FD262AA519933F6B714ED6EF99B6D01F997136494B5D86C3
-1ED354415A7F59E2376FC01C21FB00E87FF7E8BDEB47CDE4203F880320A427E6
-1A2B5FB3B308F0419FF96006ED9F890A01FEAA23005A0BA580320E10B5F26AD3
-BBCFA3FDF02DC3C759E50C717A33D954DCB47EB8E416B0196B0191C15E89D10F
-413C75365DF26EB1B468FDA3C1BAAD3B3EEF12BBB91D3E581F4BD9CCB379FF0B
-45C1778EFE80DEC0422F3B8F0B936E0AA28B1126C0573C96DE2421D0079C2A44
-AD5F2312BD5F2D2E951D0F647414615B81AFD5ACACD6B55B05828221E14A12E9
-BD3FDDF291039274E91F7F05B82B52B292AC49C7F5DE132FCDE85B35C554E95E
-8538234685F3F534B125B10B401EDBB5DF6EB903CB28C62F069FE480DCCA9D2B
-51D1CBA093FBEC5B5A43985143EDA46249ECA3A989BEDB3B940DA7D0406EE498
-7D461F3558D6095D6712513900523D65F8E8FA81B3791FD638DD090A7CB8C98F
-C07DCF8FD37BF4390D08C78A52CDCC436DBF56AD3E40F6AD2C132D8ABC3A55FB
-50DEA640371E91F7973A1D4FE1DE12EB02071BD65A71B7C132FD2BAE50097DF6
-53D3BA72D992DE74156A5AF87B8CBB15FC10FDDCEDC48B9E166F109278115098
-3084E999332A971CFD510D63483F6679CF8728F8C93656DD0695D948A0C0C84B
-7238A2C00A4E9833B3FBDB08EB4DE60C346B78A4C8B0FA581C5A93978D38C163
-2CA395851BE13B7F649C4D1C0CAF4754C4A711D6E836E81FB09529296294BF0D
-57F1746970ED7C363B726826B9A12738EA3E4F2A80C3D724F8E0F6F3632ADB27
-319B08B9BE64AEF9A34D81CE67949CC15EEF26C3B1BEEEA016536ECA65B65336
-BDC3FED62ED95AA887675AC57B91E03602523DACE7E8D850CAB390B49AB4A00D
-73F13CD4B4857060F1DE4B6DA4D6A0E8F70E8752747251E2366C1EBE6C5C826B
-CDEEA1C1519342451074C33962E7CA807FFF39FDFFC7C2D441581E8D834713B4
-B54971DBC836009463D0E635503DA63EA897E78BA09242623D3E25DC9B7BBD3F
-C24A290B5D815B630247A36A734E9E7D77DF2C7621942DCEEE49A8D0DCF3515C
-80D661C6AF98D72B5729514909DD3F7FCDB02D12527FA1EABFA0737D8556511D
-44F9888D8DEE8B5B3A061C3DFDF85D96F8DCD224954AFAE62C132F7B71DA9B6B
-BC3B54057B2B7E0455E6A80296733B10725A14BDD28243C2824FF37A248CA220
-777B0933689F2FCCF69BE43F36379461CC0373155D7CB683B8C0FE2D1BF9DEDD
-259C75D85967AF0887EBEA511B9C1D0B537E96C7B91E84F5616D1E2AB6150C14
-55AB8F33F1EF517849541029FE560D3A03EF5345DEC0C977E5CDD26270628694
-650B208D09DCB9E2972B227C7CFF5706DED731899301CF5B3C3AB4E88D4EECD8
-4B4E00ACFD8482D62B837248E5CE89BB7BD24864D732CC13A39A4D281EF86DAC
-C305E8CC30E8E30BC4D53598F57790A23524B1547394C60121572943FB4A85C5
-5EB3F9617FCDABB96E1B24BFFEDF6E0BC6757CB74EFED9E28D14D431A0EC990E
-8DA7B5F9BFCD845D946AEC72C980C03B58FD7501423DA04D6D5AEAC0EA81AFB4
-CB18CC92EA90C226A2A58DC08C4C54C7F8ECF6D4B6A5C40ECE286CE9F19D65AB
-ACB4AECA08175AD9B9DA900B74399F40B3C2DDBA939AFDFEEA5756C119CD1DF7
-B92B2BBB0DDC10ABF94B4E0E3DB498C774D8BBF8F1280837EB7DA17AA5F98C7A
-EADAB40350D733F6D745768A5DF8808E76003A3B2233C094A1DEB61FA33DF151
-906BE978F8FD783C618B1895EC38FCF5512AFD467DCB3A987F056C62B08D8310
-FFC438E4AC0A55AF880DC06A0DDA1086F5929D32E20CDA4569461ED935B76F8D
-07390055D5C99C89C20047363C2402E7B3BEE04D71F9F950976DBCB2DE14B2D8
-37B4F1993152770DE2B14B47D9CEF068D7E1DDEA283BCCC13A08B9FE6FEA0F88
-6A533C2AB2B470342BADA6AA8CD870C7F7B2EE285DEE1CDE87D651F54143CA22
-0D2095ED4B6C00ED68926A1B77462DECA5179048E7017D449ECA4A466B5D46D8
-53FFABB69477986DEC90E0C3A6C8A28B0C487C822AE40C73FDA530AC24ED0163
-BBDC9D53A576355DC7355C77102075B10DB485DFD5562D853C39701CC661FAA8
-58FDE9D06737096F33C3D168F8B6A373AA610F73E41F5FD735804326F1C95FB1
-5665EC79357AABF1F24FAB111A3EBCEC2DB966BF0A2B53C1F25465B29E11E241
-064D4D83D66D95C1D982CB10D6136C7BB84B1CC5623CAFEC830D470F6FEEA4CA
-BDB2D359CD9DE9B7A5EF643BF76BA4D37B95C0A8B62B1F1EB693E6421D671777
-D090E95E7EB4330DE177BC482EA750D36F0A1AB0DCDB38D42AE1D5BD72458AF0
-3E846C7E86BC2B1D8D72A60FC9ED3E96409EDCCC1D6808D8865F43947E84AA16
-47BB17B5A5C042194F3D1004E71C94905AC260D5446902478AF0315BA62909B5
-8740DC946AA1591B6E6182A2F5EBB162E3E75EDD0C7C71B55FAFCFA071D155AE
-CE5A87968B507CB8250412C4AAFA97E137A141A5550775BF7C90997B6D863258
-2EC919CFD37BA940449513DEC181CDA0624C3D4549AB46A8A17F1C1C5184EAFC
-A3ED1C4B2B5DF33097C66B12C3C113AE76C0257CE8D97F1F8C1C2ADDE761FBE6
-0FC023ACEC718C69791AB59BDE4A85910A3153598AC1DD5B90818965AC9558BB
-22CEC8D45C1A24860CAB88F57098A8503A56C4919C9CB10225F7A47A4DD1F164
-4AE9AD9EB80CC14E8FB6BD5603242E287D196361F5853A4D312D4974D339200A
-2E68CB2684D593964402D9C8319BD6688FB360C6ECDACDA0701958EB893C2AD0
-80F8F8509D9EB3AE2FAC4946DBECEC4028D0C6E5DFB87ADB9A6BB135382794EC
-D2E9C8E554F27B9AD1DF1CCE37F3D7EBB387AC3D63A2DF2D03D83E38D2B961CC
-3C5FA417914668E65DD30AAB8511D699E1759DBB733237F6F8CC7F9F2EED567F
-207FD8DC3453E0659608ACC0A880CC21B3298AC2FB4D368D5A3CEE12BA5AAF62
-0ECC9DC1266F00CC82D6988D97B398551DC5C660A755200B7FF836F926EC75E4
-48B3359DD09477356202BC99B6D389863B59FDDC02C091A500BBCC347460F05A
-F7DCDBD306E7B6ED372F480FB6F41A9A53E039B16EC1D31AB5CC80171605EC39
-CD0BD4587BB055C16FE1C61A653846EC57A225C4C65C7FAC787137BE909E3F03
-F388D91E304B45179631C609F5D53689D7F400B318EC2A30CC285DBE98F7697D
-2EEA02B4818BC00D34A548A1719FE8A48DFCE8A9534D0C23E5960FB2539EBB65
-20D9916B8123B2B580CFCDCDF7FAC448C1F4AFA12622492F16B4C3F6ABFC5799
-4753969FBAD9A19CA6264C1A2C4D3FA72071140029890F3B0A4FBFA4F64D3A29
-F92691FF93867D67FA711339877BA319CB1935B55F3F2D9B7C2A79CA5AB30929
-B3CC105090B79C3264AE766A91E8FB020D6C61338214B81F599D47EAFE1EE6FB
-1A7D09A028DE61F14B064C7097E41CDFAA77CFF94FB6C169F75893B8D8A2CE5D
-5F7F427D8AFB0BBD8FDFE49E3DC0BAC2EC3FB39AB29DF2B23C79E40AA674665E
-F0940062A909A8EB09563E42D0EE8A56AA440CA269460755E8679244C91C3D6F
-102781B4FD6ADC4A0DD3670496842B00CBE0E202A96AD8FC9A26EC9C7E863A20
-A94F86381B6208164A099AA59D34D579074DD2C8E223DC2AB161A800F763BC65
-323700E0F15A9901A1D1E854013B9E61F43F0378996FCEB7FCE9A2E3FEC93AC2
-73EB2178ECB1FAF64E4A1418D381DBF7EC1AFB2336A97579D8A6B532A5F49EDC
-82AE9AC7A22255AE0EBE778B75D9986AAAA16E834DE75E7F040C24E6A7F93666
-6899F51E10A0430E89DF6B6CD682089C9B5C20EB6A3D7EA635EFAB7E1A6B7D68
-A3B7E003AD2CC6B99D6206E94B39E8EC6D4A7E251FD9479563AD34B8F28BCE3B
-9F4F28FD84BD4FECD2C44DB9D97CEF05348690C7A3894E6739ACF7AB6DCC93CD
-1AA544C471175C4024A37779121FE3ECAD42D00C335974454A53290CD2214733
-72DB9B951D37E3004B18F41BC01C88B4AA90BC4FC66444271C754039D92936DB
-E6FCCE7CE68008AA02FA2A83DE7447ED
-0000000000000000000000000000000000000000000000000000000000000000
-0000000000000000000000000000000000000000000000000000000000000000
-0000000000000000000000000000000000000000000000000000000000000000
-0000000000000000000000000000000000000000000000000000000000000000
-0000000000000000000000000000000000000000000000000000000000000000
-0000000000000000000000000000000000000000000000000000000000000000
-0000000000000000000000000000000000000000000000000000000000000000
-0000000000000000000000000000000000000000000000000000000000000000
-cleartomark
-%%EndFont
-%%BeginFont: CMEX10
-%!PS-AdobeFont-1.1: CMEX10 1.00
-%%CreationDate: 1992 Jul 23 21:22:48
-% Copyright (C) 1997 American Mathematical Society. All Rights Reserved.
-11 dict begin
-/FontInfo 7 dict dup begin
-/version (1.00) readonly def
-/Notice (Copyright (C) 1997 American Mathematical Society. All Rights Reserved) readonly def
-/FullName (CMEX10) readonly def
-/FamilyName (Computer Modern) readonly def
-/Weight (Medium) readonly def
-/ItalicAngle 0 def
-/isFixedPitch false def
-end readonly def
-/FontName /CMEX10 def
-/PaintType 0 def
-/FontType 1 def
-/FontMatrix [0.001 0 0 0.001 0 0] readonly def
-/Encoding 256 array
-0 1 255 {1 index exch /.notdef put} for
-dup 13 /vextenddouble put
-dup 40 /braceleftBigg put
-readonly def
-/FontBBox{-24 -2960 1454 772}readonly def
-currentdict end
-currentfile eexec
-D9D66F633B846A97B686A97E45A3D0AA052A014267B7904EB3C0D3BD0B83D891
-016CA6CA4B712ADEB258FAAB9A130EE605E61F77FC1B738ABC7C51CD46EF8171
-9098D5FEE67660E69A7AB91B58F29A4D79E57022F783EB0FBBB6D4F4EC35014F
-D2DECBA99459A4C59DF0C6EBA150284454E707DC2100C15B76B4C19B84363758
-469A6C558785B226332152109871A9883487DD7710949204DDCF837E6A8708B8
-2BDBF16FBC7512FAA308A093FE5CF5B8CAC6A7BEB5D02276E511FFAF2AE11910
-DE076F24311D94D07CACC323F360887F1EA11BDDA7927FF3325986FDB0ABDFC8
-8E4B40E7988921D551EC0867EBCA44C05657F0DC913E7B3004A5F3E1337B6987
-FEBC45F989C8DC6DC0AD577E903F05D0D54208A0AE7F28C734F130C133B48422
-BED48639A2B74E4C08F2E710E24A99F347E0F4394CE64EACB549576E89044E52
-EABE595BC964156D9D8C2BAB0F49664E951D7C1A3D1789C47F03C7051A63D5E8
-DF04FAAC47351E82CAE0794AA9692C6452688A74A7A6A7AD09B8A9783C235EC1
-EA2156261B8FB331827145DE315B6EC1B3D8B67B3323F761EAF4C223BB214C4C
-6B062D1B281F5041D068319F4911058376D8EFBA59884BA3318C5BC95684F281
-E0591BC0D1B2A4592A137FF301610019B8AC46AE6E48BC091E888E4487688350
-E9AD5074EE4848271CE4ACC38D8CBC8F3DB32813DDD5B341AF9A6601281ABA38
-4A978B98483A63FCC458D0E3BCE6FD830E7E09B0DB987A6B63B74638FC9F21A5
-8C68479E1A85225670D79CDDE5AC0B77F5A994CA700B5F0FF1F97FC63EFDE023
-8135F04A9D20C31998B12AE06676C362141AAAA395CDEF0A49E0141D335965F2
-FB4198499799CECCC8AA5D255264784CD30A3E8295888EFBC2060ADDD7BAC45A
-EEEECDFF7A47A88E69D84C9E572616C1AC69A34B5F0D0DE8EE4EDF9F4ADE0387
-680924D8D5B73EF04EAD7F45977CA8AD73D4DD45DE1966A3B8251C0386164C35
-5880DD2609C80E96D1AB861C9259748E98F6711D4E241A269ED51FF328344664
-3AF9F18DCE671611DB2F5D3EA77EE734D2BED623F973E6840B8DAD1E2C3C2666
-DD4DD1C1C9C622FAEAB9D3E54476B49A2A026565F10A907B3B33DED2B3AF7DD5
-1A717C6F3322B4061D682CF928DAF9EFD083871A112BA0A76FA34F35E60902FF
-02043D966A58A3E052612591918ECA0DA4F91C716FA786D5F449D30797C9A503
-CC3A862619988DE3BF464699211760C6DE2E72A409A6E3B64F1372A87875A94B
-9B39927313A0BBAC8698FA32DC59706310E8B5AB38332E2BA87A0088E9864651
-75ABB116518641B3928D5B79B86F4623858BB05A98268AFF07ED326E70D72AFB
-9B8891EED3C1252ED718CC96E8039D5CB48509D79D04F57FBEDCC72FB443A1A3
-DAAEF15C92B8D26BE384F3D15F46DC9F0FD5418C39389BBE406FDE704354C50C
-53A66EAA65F2CA79BC5E914BEBB4DCF05FC36D708921F561DA780DDE250D7527
-D8945CEC0C5FC6A9E153B490E87BC1FBAFC3E6E54B150A7F4BC68CF3F1A34BCA
-0E6837E1FB1161B21F6AFB9C96A4BCF20715B1A3CA58A12F1438566D1B6F5A28
-25802A2B900186ACD058A28063802BE668E7F40F1A42B6D024A6CD0F4D6A612B
-3B2D666441A23E29168541EE2A3726C28C1B1802D38C28AB7D7D714A828E5755
-E94AE356C7E4C1E3C09661AC5864407EFF9D00BF0E36902F8CF423ED12E31CEE
-97B7907B0816C2A5CB68CAC754E998C35AB1A0CEC8F4907C3CB08215601BDEED
-91C3C4A9F0236964FF87
-0000000000000000000000000000000000000000000000000000000000000000
-0000000000000000000000000000000000000000000000000000000000000000
-0000000000000000000000000000000000000000000000000000000000000000
-0000000000000000000000000000000000000000000000000000000000000000
-0000000000000000000000000000000000000000000000000000000000000000
-0000000000000000000000000000000000000000000000000000000000000000
-0000000000000000000000000000000000000000000000000000000000000000
-0000000000000000000000000000000000000000000000000000000000000000
-cleartomark
-%%EndFont
-%%BeginFont: CMMI9
-%!PS-AdobeFont-1.1: CMMI9 1.100
-%%CreationDate: 1996 Jul 23 07:53:55
-% Copyright (C) 1997 American Mathematical Society. All Rights Reserved.
-11 dict begin
-/FontInfo 7 dict dup begin
-/version (1.100) readonly def
-/Notice (Copyright (C) 1997 American Mathematical Society. All Rights Reserved) readonly def
-/FullName (CMMI9) readonly def
-/FamilyName (Computer Modern) readonly def
-/Weight (Medium) readonly def
-/ItalicAngle -14.04 def
-/isFixedPitch false def
-end readonly def
-/FontName /CMMI9 def
-/PaintType 0 def
-/FontType 1 def
-/FontMatrix [0.001 0 0 0.001 0 0] readonly def
-/Encoding 256 array
-0 1 255 {1 index exch /.notdef put} for
-dup 63 /star put
-dup 79 /O put
-dup 97 /a put
-dup 98 /b put
-readonly def
-/FontBBox{-29 -250 1075 750}readonly def
-currentdict end
-currentfile eexec
-D9D66F633B846A97B686A97E45A3D0AA0529731C99A784CCBE85B4993B2EEBDE
-3B12D472B7CF54651EF21185116A69AB1096ED4BAD2F646635E019B6417CC77B
-532F85D811C70D1429A19A5307EF63EB5C5E02C89FC6C20F6D9D89E7D91FE470
-B72BEFDA23F5DF76BE05AF4CE93137A219ED8A04A9D7D6FDF37E6B7FCDE0D90B
-986423E5960A5D9FBB4C956556E8DF90CBFAEC476FA36FD9A5C8175C9AF513FE
-D919C2DDD26BDC0D99398B9F4D03D5993DFC0930297866E1CD0A319B6B1FD958
-9E394A533A081C36D6F5CA5FED4F9AC9ADE41E04F9FC52E758C9F45A92BED935
-86F9CFDB57732045913A6422AD4206418610C81D882EE493DE9523CC1BFE1505
-DD1390B19BC1947A01B93BC668BE9B2A0E69A968554239B88C00AF9FBDF09CCD
-67D3B2094C11A04762FE8CC1E91D020A28B3C122D24BEAACF82313F4604F2FEF
-6E176D730A879BE45DD0D4996EF0247AEB1CA0AB08FF374D99F06D47B36F9554
-FAD9A2D3CE451B7791C3709D8A1DDDEFBD840C1B42AB824D5A0DFF0E0F15B0B7
-22AEEB877FF489581DA6FA8DA64944555101EB16F7AB0B717E148B7B98D8DBFD
-730C52937E226545CF8DC3E07C5BA30739BAFCD0F2B44275A6D503F582C0FB4F
-449963D0AD2FAFDE33BA3D77BCA9D1DF878DDAFCA2E22CC4BACD542B282164C7
-97C2BDE318AF9D501CA21F6E662E7AAB75A5F24D2C182E598D175D44E88AB19A
-E7CD59584F95B389183EE21B525BF52A3F23C0FE5383A5565A19361D716F508C
-AAB78411CA5A4D27552CC1C435760D5A89D535B71C593E755C616661363308DA
-A683F54ED0C23FB2C225A008392B0B719F66F11A946A090B7C00B662A3C69599
-B4ECB0CC70C85C4BBBF207E0026F6C7A19F2ACFB7A60804FC98A4BFFD7BFFF2B
-9529E6D9D4238002BBC255BC62959D6F3381FE06E0621B879D5FE5B541D45A1E
-759A6E7DC32B1D1632368D09A97039DF255B6492B1B2B7E2C1434E8306ECA7D3
-5A79B6D614B4979F10988BC76ED53A5F45315CD7DA216221F842FD0F3E050DD2
-BAC23C984D506D8F7D614BCB6B244F5F41321549BB0BD041FBF3053307168680
-3435E9C9438B42FAB00E47C88F11FD0F6B4EFE51F0E577DD810056E37D07C868
-3A15DA228A6992CBC01BCA5F12EB1D79E563FBF8DD6A531A596AAAE93347A442
-7BD14A0CAE46526ED7E8C51FD1A79FFE07197D5CDCB6764C74D82E9531E007E0
-EADDF55229017AB21384FC0520CAF59AE78559BD17FE97FF5EFBF496883F3E5D
-CBF9C7D944C058CA95B60727F99F0F39AD3DF1DE681E52A352AAFF400FFA0E94
-9AC1E3AD9C06A2D1FA23390A39C6F5156E008578D531906A84F619BA12AB472E
-16B641A7743A09C02E45D761419F9E35737593D75804F6A950E672D095E7E575
-3C728C4F8EBDD91B7D8F1F8FDE30C8D8A532580DC7E1CA05DBCEC93391D344CE
-E7D63BB7298C93EBF02866599116A459882C7979AE47C4419845AED1CDBA479C
-5A8A7B06D67426E0439A294824CF9DD2586FB93E8173ACE7F69720629B872B39
-DAB2E001679EA3DF136E434D1725CA745E82474F89FBFB41BB946065E0FC6A71
-02232DA9CCED093679E018D34A1EF00AFBC264871AC044F294C77562B8F52E4C
-E530257F3D2A875A54785A7E9FB7D2BDE79E36A768B10CF96B3566DF8BF94208
-AF060F2E167FCA10FE093F83F260C75177C5A1B58D5DFE4C513A72F44CC53211
-CFC718B6A019110E0322D51C33FEA9900D011F08279F99B2C22D861B1E6F413E
-5AC8A690ECB8616BE318B3F38079230311BD4C4336E7A135D8F65CDAD96D939B
-EB18EA199343FC84B112D363B87ED835C13FB135A5625EFDE76F320B1DD7F2B3
-B60484A06D32FD8D7AF153F1C847583FDAF5CEFEA9F0708724099CFA4D1BF193
-8B20B105DAF4112FE09E8C557295D32A7915F59D89741CCE24BD7A82215132DC
-70061654BADCA5D0A36851C4FAC9859830537CF66368C624E1823407EAD82DFD
-22736F17D8506A726722279E15B9CF11BC551D68F8933E99D9C94C0815B340BC
-7CDDB07C33FE70A97DBF0F6DB74DFAFE9328E67A281D357996FD0A6F08C734CB
-38332BB4DE1E0E45B95F19B79C42B03B5201F71E5D5EBB278A9A45A9731010F4
-2BB1B72E6324068F92F5F58E287A10FA3E78CFFEAA20710351227DA9A5DDFC20
-842AE9F4426025D2FE57C3796B65782E3298CF54F4C69DEBC065203152306723
-DFABB4CBFF6B259E78309BA1C50AD1F48773E0F0B20F281006429AF012560157
-B91EA8F657C17D9F0886FAD0225254
-0000000000000000000000000000000000000000000000000000000000000000
-0000000000000000000000000000000000000000000000000000000000000000
-0000000000000000000000000000000000000000000000000000000000000000
-0000000000000000000000000000000000000000000000000000000000000000
-0000000000000000000000000000000000000000000000000000000000000000
-0000000000000000000000000000000000000000000000000000000000000000
-0000000000000000000000000000000000000000000000000000000000000000
-0000000000000000000000000000000000000000000000000000000000000000
-cleartomark
-%%EndFont
-%%BeginFont: CMSY9
-%!PS-AdobeFont-1.1: CMSY9 1.0
-%%CreationDate: 1991 Aug 15 07:22:27
-% Copyright (C) 1997 American Mathematical Society. All Rights Reserved.
-11 dict begin
-/FontInfo 7 dict dup begin
-/version (1.0) readonly def
-/Notice (Copyright (C) 1997 American Mathematical Society. All Rights Reserved) readonly def
-/FullName (CMSY9) readonly def
-/FamilyName (Computer Modern) readonly def
-/Weight (Medium) readonly def
-/ItalicAngle -14.035 def
-/isFixedPitch false def
-end readonly def
-/FontName /CMSY9 def
-/PaintType 0 def
-/FontType 1 def
-/FontMatrix [0.001 0 0 0.001 0 0] readonly def
-/Encoding 256 array
-0 1 255 {1 index exch /.notdef put} for
-dup 3 /asteriskmath put
-dup 15 /bullet put
-dup 112 /radical put
-dup 121 /dagger put
-dup 122 /daggerdbl put
-readonly def
-/FontBBox{-30 -958 1146 777}readonly def
-currentdict end
-currentfile eexec
-D9D66F633B846A97B686A97E45A3D0AA052F09F9C8ADE9D907C058B87E9B6964
-7D53359E51216774A4EAA1E2B58EC3176BD1184A633B951372B4198D4E8C5EF4
-A213ACB58AA0A658908035BF2ED8531779838A960DFE2B27EA49C37156989C85
-E21B3ABF72E39A89232CD9F4237FC80C9E64E8425AA3BEF7DED60B122A52922A
-221A37D9A807DD01161779DDE7D31FF2B87F97C73D63EECDDA4C49501773468A
-27D1663E0B62F461F6E40A5D6676D0037D33F24E2FAC2B0009AD3C8350CDF8CC
-65BCA87979C36D14CB552E9A985E48BE4E88ECA16DF418749AF04FDD2B0E1380
-D281BB2476BB45FF30946B247DFD7F57305FA87E50CA338121C71CDFDF927A9C
-77FF14CB4A1D6D80356FB1171ED38C37702350497B44E42CE31DB2F493807DAA
-15B887C671199A54C4C1294BC520F5538C15556BC43C9F62342B121C6DCD6C5F
-491DA47FF360201EE21C08A781ED0589A6DF91B99FE118B9B29E4F068672E52F
-1A06C514D91C4C937D4E642503392B1CD1BA5279B4457B627485A2758184511D
-EA4D44D333A4B67F720D5EEF9A5E1AA66DF9C11AA72B65F2A7A8D4C2796662DF
-369048FBBE329786BC50A09FF5D30483227CD636263AD51F07A3E7A8EA503223
-46929A32E158B32C9A35BA57B632A1A9773B85571D16143BAD0432BFEAE3E898
-D679DDD2A73CEF9C7BBAA7194EF95BA77D0CA1136D3E767400155413383E63C6
-81ECB34018A8E4FE813ADCCC814D8545054E9D73981030F45072D55B4441A64D
-4D9DB40B12655A0D0077EC2C2C71FAF0EFB36028550FC548210F1CFFA82C3869
-2D9244F185A45F190CFA9919F2389E10C0997E3601D48ADC0DCAB9D5B0E51D67
-DC1A8061FA4908B96179816ED83B8FD55FD568B89E5FB45C12CEB13DE5326B77
-12E4B2A884A916C3BED9B45DA339C999457BBF3C4B9BDA8276E296D2DF73C7E7
-AEAD1350BC2DC435835D725651C05FBE8225A50E1E22E7B2E7A4925A288F962D
-0924B1AE3722842E4DB30B14870F29F6F08A11FB23E3E0AAD6DD690518B82B68
-CA8A1734CB7A66F5E14BD553439BE4BD7653861201E029B81EE47F1FE2A855A0
-879882AA087E2B14193F79A3C6E799CEBC47F2BC1C658F902EE2C002D7F70BB8
-18B5F93C6A3E87DF6A08524139B6A191008297FCB119A8B223DA5C963F8F8420
-A996C710905A7F4C916D4CAD20551F861052F3F4A7C24C108F9FD63A9846F8C6
-E421E64F2825E5CDC123050317C0A8ECCB712A0A999125173C9A99E5D44017AA
-4EC9DE8ADBE7ED1798027B2780B85C4E25F5EB4FACC199AF2214089E9B8FB9D3
-4E0276EE405D1200AFDB14DEE909F1FFDE7A7449E0CE93E9BAD2BB1ADB4DB9A3
-E9EA9A79177EE4897BCF3BF6F45D9365EC2A291E8C51AF28EC96AB1244A99842
-9F996C10F84830537F3CBBD9616E924CDD61B2EAF7A05C2B405A5C4E037DF8B7
-4D5F41C9A84E4E3D6CFB7A4F7F35B5161EE5E83B08964D904673FB3E5D87929C
-F991D1193BD92B8562263C7B5165D5123855EFCAE0119F5B4DB660D1C4D4E758
-64FCF1F49A5CFF4517D7143B24CFF700E0DECA45556966BDAE814269A3A2C163
-757988A762E4536151D4C94D23E41C798307B099E75577303D593FC1C71B9E95
-8C0EF1E04C801430A90CFEDB7023C146347C113FF0D5887D73BE2E4C19E6F11B
-A74D416817B4F2A2E2961576C8C587ABB710D4FD2B794BD167E0889A7B6AA881
-1CEEF2AADB3AAB517EB0EECEEBCBE2D65CCA60D227F7B6975FAB454F09F404FD
-D7CD3490F200712FE69533C6E98C08A994F80A7CDE2A78D5AEAD1750441738C9
-C93412150522BFFBFB09D5A6E4048AB3ABA44A919940E75476F41A96D00AEDA3
-C85EBCBD26EE801DF8EB4E10432635E625441FF28EF100888CE46FFD30FB5565
-472228A177152641BB157F578C1F4E12AC5E57130AF144BDA7423080DCA406A0
-4CFE02DF363811DFB48703C2150CD54298F88134366450666C500A4E489C5C94
-628D2FAA087AAD41C4C7FC9D062E26B3423B8DD0971BEE98FD884DD6B3EC1F03
-045EE09BC085A5C392F309746F554A872EC6CF91420DF7A34310E7D0127EF112
-B85F1C4074630E12993E575CE43C82A04D853780B2D198858A5960F5E532243C
-CA03FE21F8B7B6B8B06AC0CA408197E242D44B293BB32447F718FD7C038411E0
-EA8DD9B6801FB5A10588
-0000000000000000000000000000000000000000000000000000000000000000
-0000000000000000000000000000000000000000000000000000000000000000
-0000000000000000000000000000000000000000000000000000000000000000
-0000000000000000000000000000000000000000000000000000000000000000
-0000000000000000000000000000000000000000000000000000000000000000
-0000000000000000000000000000000000000000000000000000000000000000
-0000000000000000000000000000000000000000000000000000000000000000
-0000000000000000000000000000000000000000000000000000000000000000
-cleartomark
-%%EndFont
-%%BeginFont: CMSY8
-%!PS-AdobeFont-1.1: CMSY8 1.0
-%%CreationDate: 1991 Aug 15 07:22:10
-% Copyright (C) 1997 American Mathematical Society. All Rights Reserved.
-11 dict begin
-/FontInfo 7 dict dup begin
-/version (1.0) readonly def
-/Notice (Copyright (C) 1997 American Mathematical Society. All Rights Reserved) readonly def
-/FullName (CMSY8) readonly def
-/FamilyName (Computer Modern) readonly def
-/Weight (Medium) readonly def
-/ItalicAngle -14.035 def
-/isFixedPitch false def
-end readonly def
-/FontName /CMSY8 def
-/PaintType 0 def
-/FontType 1 def
-/FontMatrix [0.001 0 0 0.001 0 0] readonly def
-/Encoding 256 array
-0 1 255 {1 index exch /.notdef put} for
-dup 0 /minus put
-dup 3 /asteriskmath put
-readonly def
-/FontBBox{-30 -955 1185 779}readonly def
-currentdict end
-currentfile eexec
-D9D66F633B846A97B686A97E45A3D0AA052F09F9C8ADE9D907C058B87E9B6964
-7D53359E51216774A4EAA1E2B58EC3176BD1184A633B951372B4198D4E8C5EF4
-A213ACB58AA0A658908035BF2ED8531779838A960DFE2B27EA49C37156989C85
-E21B3ABF72E39A89232CD9F4237FC80C9E64E8425AA3BEF7DED60B122A52922A
-221A37D9A807DD01161779DDE7D5FC1B2109839E5B52DFBB2A7C1B5D8E7E8AA0
-5B10EA43D6A8ED61AF5B23D49920D8F79DAB6A59062134D84AC0100187A6CD1F
-80F5DDD9D222ACB1C23326A7656A635C4A241CCD32CBFDF8363206B8AA36E107
-1477F5496111E055C7491002AFF272E46ECC46422F0380D093284870022523FB
-DA1716CC4F2E2CCAD5F173FCBE6EDDB874AD255CD5E5C0F86214393FCB5F5C20
-9C3C2BB5886E36FC3CCC21483C3AC193485A46E9D22BD7201894E4D45ADD9BF1
-CC5CF6A5010B5654AC0BE0DA903DB563B13840BA3015F72E51E3BC80156388BA
-F83C7D393392BCBC227771CDCB976E93302530FA3F4BEF341997D4302A48384A
-CEFFC1559462EA5F60DC05245E8499D8E61397B2C094CEED1AF26EE15A837209
-ECE64FEF41ABE8DDA7BE1F351CF14E07BA8FD40CEFBFC3CE7B9D4912D6FE752D
-9CF163084E688DDCC4A450C440D47668A3F7CCE40030B01911C9A925DD42B5EE
-504AE98ED274FFCE11DDB10C749FF05ED2BC983ACEEE5C2A394FB61F725DAFA4
-E8AD4D01E203F60E03278425AF330330790BEA33AB3F1AC5B174162A6A40A2F8
-35278FFCC3BD96D81A859ECFBBF1FE491ABAA6222FB19C01EEE848A460377468
-6FCD71A6E58BF79E3DD28583C4808FB900E66910BD1C7EDA05D2F3D9AC7EB1DC
-982F9035227478BA2ED2BA805C8DCAFAFCA32819949643FA97B5A315684A334B
-976428949DF88C66D25824699079C3F44F7D5C0D8DA329C63ABA3AC0E9F7DC6B
-08A5A3363B62471C9347FF96D6D52CD63D21F7C15997965DC1B21C0BF7F8925C
-25C5EDB952A4431B75A63024E44969A9EF3C29C20571FE84C5513CC2C4FB684C
-CF0938E787E7A6494964F30D70FA29A75A7A0ADDFBE2D467B191F9E67A95758F
-B920D99157F37F32A5807FAACDFB
-0000000000000000000000000000000000000000000000000000000000000000
-0000000000000000000000000000000000000000000000000000000000000000
-0000000000000000000000000000000000000000000000000000000000000000
-0000000000000000000000000000000000000000000000000000000000000000
-0000000000000000000000000000000000000000000000000000000000000000
-0000000000000000000000000000000000000000000000000000000000000000
-0000000000000000000000000000000000000000000000000000000000000000
-0000000000000000000000000000000000000000000000000000000000000000
-cleartomark
-%%EndFont
-%%BeginFont: CMMI8
-%!PS-AdobeFont-1.1: CMMI8 1.100
-%%CreationDate: 1996 Jul 23 07:53:54
-% Copyright (C) 1997 American Mathematical Society. All Rights Reserved.
-11 dict begin
-/FontInfo 7 dict dup begin
-/version (1.100) readonly def
-/Notice (Copyright (C) 1997 American Mathematical Society. All Rights Reserved) readonly def
-/FullName (CMMI8) readonly def
-/FamilyName (Computer Modern) readonly def
-/Weight (Medium) readonly def
-/ItalicAngle -14.04 def
-/isFixedPitch false def
-end readonly def
-/FontName /CMMI8 def
-/PaintType 0 def
-/FontType 1 def
-/FontMatrix [0.001 0 0 0.001 0 0] readonly def
-/Encoding 256 array
-0 1 255 {1 index exch /.notdef put} for
-dup 72 /H put
-dup 84 /T put
-dup 105 /i put
-dup 106 /j put
-dup 108 /l put
-dup 112 /p put
-dup 117 /u put
-readonly def
-/FontBBox{-24 -250 1110 750}readonly def
-currentdict end
-currentfile eexec
-D9D66F633B846A97B686A97E45A3D0AA0529731C99A784CCBE85B4993B2EEBDE
-3B12D472B7CF54651EF21185116A69AB1096ED4BAD2F646635E019B6417CC77B
-532F85D811C70D1429A19A5307EF63EB5C5E02C89FC6C20F6D9D89E7D91FE470
-B72BEFDA23F5DF76BE05AF4CE93137A219ED8A04A9D7D6FDF37E6B7FCDE0D90B
-986423E5960A5D9FBB4C956556E8DF90CBFAEC476FA36FD9A5C8175C9AF513FE
-D919C2DDD26BDC0D99398B9F4D03D6A8F05B47AF95EF28A9C561DBDC98C47CF5
-5250011D19E9366EB6FD153D3A100CAA6212E3D5D93990737F8D326D347B7EDC
-4391C9DF440285B8FC159D0E98D4258FC57892DDF753642CD526A96ACEDA4120
-788F22B1D09F149794E66DD1AC2C2B3BC6FEC59D626F427CD5AE9C54C7F78F62
-C36F49B3C2E5E62AFB56DCEE87445A12A942C14AE618D1FE1B11A9CF9FAA1F32
-617B598CE5058715EF3051E228F72F651040AD99A741F247C68007E68C84E9D1
-D0BF99AA5D777D88A7D3CED2EA67F4AE61E8BC0495E7DA382E82DDB2B009DD63
-532C74E3BE5EC555A014BCBB6AB31B8286D7712E0E926F8696830672B8214E9B
-5D0740C16ADF0AFD47C4938F373575C6CA91E46D88DE24E682DEC44B57EA8AF8
-4E57D45646073250D82C4B50CBBB0B369932618301F3D4186277103B53B3C9E6
-DB42D6B30115F67B9D078220D5752644930643BDF9FACF684EBE13E39B65055E
-B1BD054C324962025EC79E1D155936FE32D9F2224353F2A46C3558EF216F6BB2
-A304BAF752BEEC36C4440B556AEFECF454BA7CBBA7537BCB10EBC21047333A89
-8936419D857CD9F59EBA20B0A3D9BA4A0D3395336B4CDA4BA6451B6E4D1370FA
-D9BDABB7F271BC1C6C48D9DF1E5A6FAE788F5609DE3C48D47A67097C547D9817
-AD3A7CCE2B771843D69F860DA4059A71494281C0AD8D4BAB3F67BB6739723C04
-AE05F9E35B2B2CB9C7874C114F57A185C8563C0DCCA93F8096384D71A2994748
-A3C7C8B8AF54961A8838AD279441D9A5EB6C1FE26C98BD025F353124DA68A827
-AE2AF8D25CA48031C242AA433EEEBB8ABA4B96821786C38BACB5F58C3D5DA011
-85B385124615C1B216CC43CEF394B2DC098149B7072801B54C49DA0820EFEB67
-A590BADBCEF9791F3B1ABF1E609238CA41A0D2BFBDEA2A4A3E550F4EF3D49ACD
-AEDBB97DB4FB830D670977546092843AD44E66475E92BFE4FFE8214DCC5B6B90
-AF470619C1576A4E3E32E4FE6EAAC0F10AFA1418C9F992921ECD575468829BB8
-49778B3B48A2E139925EBF3769A0A014A2B454DF930B3D7C03CC55030A8C66DA
-610514FBA4E8BD474AB3F70A533297771B6163967349366D7A0D13EC9A1445BD
-27BF542C6A25EE8AF60E9599CC02F9FAFEAB5336322CD3F10553C45900CA391F
-3342D1EDE7E68B804CA1E4167CD050D326CB99EF6BD40666F61034F59E0574EE
-39478B7A9842586EE7CB6E53B9151C45161EE94DC0A4C7450881A9F6B1C26E19
-1AC4264A9D8F3858A54D376E51E5F862D93F01B8392CEEF88DB77EC229A65F45
-80CF7BC9ADC3E9973756001FE9AB2E629D25CCA56AE550B199A8009BA06559D4
-6D0DE45889263273CD60734D37AB3E0B049B2AEFA0BD28D0CBC4C162E9935656
-F8BE0CDB2604623BF71FB659756B6B309CB423C91CF2A6CDE6253C8D1988B637
-930422AF9A5CF83664B39CF24B23B8CF402441F3B025835C0B0B924211FBFE11
-26F33157F0BC69F8A6C1F0337DD69D01EB157B32A517E674F235709186E67DC1
-1E128CF8840778DAF6DBA6D3B78178F33E1829476D6D73A3D734102FF3DC4C65
-4C628FCF16EFF481387EA60A3FD464C6388ED534FC450B584D94D3E0FFA3B05D
-D016BBC0F7F6071EB24900DBBDB2711AECD409BEA66ABCDF95B8D16F4D501629
-F54F1BA8B55C4C8A6ECBD2C6EF29901355E1535466EB47EF75204016A662C837
-1E8D295296800D2D895CF9F79435064AE5784D7BFF46BDDBE046EC405BCD8F44
-30E19526D02A8DFFDC23D9500FC8F1F60687614D2E0D671CDC5BAFDBE3CB3823
-E0D6F46F042E4C8721C77D95ADBC74E498E12E3263D54E983F29DE1234D5D7E9
-28F68AE25F0A1158198916C7111B430CBD7B7802DA8F06AAB347FD470A961C9B
-9A171CA8EB00765BE1B6A72F8AD605C56F1A60752F18762F7C589219026E52F0
-9955A56B460F2A571852B28EB11F7A025A32DCDD22BBF6124A437D9FF1BE5A0C
-076A8BCD32D8799378DB9C72A9E9B51306F10D332F1D77E148D9532BEC51E082
-879A8CFD1CDD038F9836C954F2F4F6B2693A84916A2EFE02A4BFB932601CB273
-52017449B1F17C85356AE710F338F37AABE20141CE0D35B28C2B3E29FA390570
-ECA6A5EA261AA550F3EC411E78C8E1368D6736D5DDD669E70583452D4BF0E682
-908FB645A6344CE23CDA2BD3CA15A8415AFC0F036C99D08D01D10EF2580F66C7
-16D2B9220B61ADC6351EAFC6E69477F7A1462B9D2974C5252BE3A8FC812E3154
-85310152B2D811D3473D4AF8478CB2D730468D7C556679105F42852419F40C60
-A249D9DCA60604E173AC578C664F5302C12FFEA69E8D52401A7BD49E5A6A31FE
-77BD0265DF35430642DA43A20327A5D9331DB95502EB2417E448E32D75607975
-C3D2CCB006B105759384AEA4B38C4D57041243D77B99687CA1CA4721C0AB8750
-E064E5CD8F41653509B6F61408017BFB1A95F49042025B03C8354B3D55341216
-61F858256CBDCE6867D00DDE3EE6E6EA1F732CDD45DE9F80F497C3A6BD234B0A
-AB0817F0FBBDE91D2763D0A27A94C2BABF3B414C8C03321C2DD379C32DAD00AE
-B55157E8D9F28999BFB1A37ED3D8A8CCE5968610E22827C0DB0506C38F40984D
-C4E3668327AA737F78FBE9D050C5924CE8C9C6940F4DD25619CED65A5F759320
-08815ACC748A4071DA1C6AD52DDB727BEB6A9E7B1EA2DBE3612C4A5253F92599
-2390E84F69C094C124E38A1F5DCB4361D00CD684D8E4AEB02DE1532B5F558E10
-44004BA1C8C05DFE0612910E00021C0166D95064070B773A813C4CDD37057D8A
-1B12F1417C8989A30DB1018B7B4A59024BA76122DB85650E732D17F7AF5E4E34
-6A96EA967EB1E62F44DEF7C5EF430E9C1ADA95668E481B3FE70BEFC0C0F59FF7
-04088B4D7F4A1077C0D1777802B7538EC48F4CBE91198FB6AEF9C5B870B48217
-7712E7D1AC40CF0D2F445CE8E4D7535FC805210772A659EA57D6612ABCEF0285
-8F79921A00EAB3842972C428B8B09F58DA291E6B09FB7EB6ACE1A6757C405188
-DA7B4E6B627BABC41680E4DA4FE52BDF5F26342C4FEB32D37D772FABC3FD73AA
-09F97A4230CA897C26C177CE144FD3A4739A762826964A482A839B5D76C89D9D
-D6E89DB464E0962C04029BA224330A6A649829FA58352A9C6D160D04C0681FBE
-FC3A053A4F8D71EB47632455FA5C4599AFC431C3A2D65FC1BB93
-0000000000000000000000000000000000000000000000000000000000000000
-0000000000000000000000000000000000000000000000000000000000000000
-0000000000000000000000000000000000000000000000000000000000000000
-0000000000000000000000000000000000000000000000000000000000000000
-0000000000000000000000000000000000000000000000000000000000000000
-0000000000000000000000000000000000000000000000000000000000000000
-0000000000000000000000000000000000000000000000000000000000000000
-0000000000000000000000000000000000000000000000000000000000000000
-cleartomark
-%%EndFont
-%%BeginFont: CMSL10
-%!PS-AdobeFont-1.1: CMSL10 1.0
-%%CreationDate: 1991 Aug 20 16:40:20
-% Copyright (C) 1997 American Mathematical Society. All Rights Reserved.
-11 dict begin
-/FontInfo 7 dict dup begin
-/version (1.0) readonly def
-/Notice (Copyright (C) 1997 American Mathematical Society. All Rights Reserved) readonly def
-/FullName (CMSL10) readonly def
-/FamilyName (Computer Modern) readonly def
-/Weight (Medium) readonly def
-/ItalicAngle -9.46 def
-/isFixedPitch false def
-end readonly def
-/FontName /CMSL10 def
-/PaintType 0 def
-/FontType 1 def
-/FontMatrix [0.001 0 0 0.001 0 0] readonly def
-/Encoding 256 array
-0 1 255 {1 index exch /.notdef put} for
-dup 68 /D put
-dup 69 /E put
-dup 70 /F put
-dup 72 /H put
-dup 73 /I put
-dup 82 /R put
-dup 83 /S put
-dup 84 /T put
-readonly def
-/FontBBox{-62 -250 1123 750}readonly def
-currentdict end
-currentfile eexec
-D9D66F633B846A97B686A97E45A3D0AA0529731C99A784CCBE85B4993B2EEBDE
-3B12D472B7CF54651EF21185116A69AB1096ED4BAD2F646635E019B6417CC77B
-532F85D811C70D1429A19A5307EF63EB5C5E02C89FC6C20F6D9D89E7D91FE470
-B72BEFDA23F5DF76BE05AF4CE93137A219ED8A04A9D7D6FDF37E6B7FCDE0D90B
-986423E5960A5D9FBB4C956556E8DF90CBFAEC476FA36FD9A5C8175C9AF513FE
-D919C2DDD26BDC0D99398B9F4D03D5993DFC0930297866E1CD0A319B6B1FD958
-9429B9D40924DC059325D9D4CC0344F3F997A99E6CC0676735EBCD685AAC9142
-08DAFEC78BB41AFC2F1C219910BDF41D6279284EF600B69776CA15BC8A34347C
-30783C52AFA60FBE3E353E2AE354CF87B558776A22C776C7A0B5AB5CE1F941EF
-C2D9CAC37294BF407A671F10E4743BF842143F4F7DFEE643BA3BBD8BB9E3F24A
-BCCF7F0ADF8BA500620C81033EAE8C4EF2C1DEF13AC575F1B3BBB66F093D3B78
-5412B82B67FFA087AF57182B2230F9F2137180CA58A7D9B2C822FF04BE6CD01D
-43B2CA7058C7B953F6D9B5D6E91ECBAA5CDE1159B0E59C83DBAD96D6C8C8BAB1
-374EF652D10C0F3EE7104472C98DD3572AAF2D45A70BF7061447E21EE3C3BF23
-DF39C2D1B35B42CD5297BEBE6BC94F7C9DC6E61EC67E4F677256FED9064BD3E4
-B51A71B1D27CA4E5AA9E1D8080E6DAB5310711EEF87C40859FA935B19524AE83
-63B163FA8397BDFF443227FEDF7DB27DC35D89FB1C5E435DA0619A5C88AFC73B
-89A2DF5E767C5B536BC7167A840A0C32BD57A14DE69A7D0D819AC36FF32F908A
-5070F32983BB007437E3500799DF5E0AD3710A4C0000F0098D5BE99F2EB9C1C2
-C444FD9552D0DCA098A94B3BF176F511CEE13DB7EFFAED7C47B5ADCF8D4700F5
-7A5FD1B49560969BF5C44F3749370663A04776F749DDD7B50674D93254426C4B
-EFE264BEE7810EC93784B7C01A7F29EFD92547E13A2C7851A2E709FBD5B87850
-4A44F08F56A542DBE072D2FBC58D9E6468E1AB858DC35240E30D31C7AC13D6C5
-7D2BB634BEE96FA0E10F842B11A789F72A333DD6DDCB1BC23227EBC406E50B40
-30AF0C48E6359AB0C46898CDAF1118E46BFF8B00F54EACBC2AC262AB898C42B9
-2E080C10DE923C15125AA61226AB19663C9B0787A1CC83385A40ACB33B2C516A
-FEB3BBC5CC72A87261C44E26D9B2EF4014C6AFFB1F37132C550D9877FB4ED826
-F225A6E09835D9E7B2C2DA9AD21C4C11321EB0EFB393767819120FC3F8DFBE3F
-D050415D9AC378C555FA581A7D33C47B5D5CBC1A19657D765A2117E56C156038
-AB3D1F51C0B013F74C3B292A8DE5F5A617025D1ABE830513C48D42A37333238C
-EFFB1E74711B150F672BB28D579F550B1DA075815788242B0F97A9E0DFC7AE0C
-64EB948F8868C3D4C91C8AFB24A6AB111108D6C80A4E4488E6DDE5D2DBB8E79A
-4AAA54E466FA8167498BDE3B1E96F27BB6DBCF8BA083E82368A7CF97C67FD630
-E9E52A71A74551261B5952F2C884CFA4DD404B89F108FA87DF704D04D4C95153
-8A760CC1FD166246CA1CACA107A3BA11E01E6B0A62F8731A9A7FF945A0404848
-A902E1EE5A8CF58C7690A425A5EA995234AAC715C704EED16AD65D97480990C7
-DA1EB8A2D847F62007BB241376BB2AB7084FE2BFEB4E00836E47687480AB9BB5
-E09A2DBBA158C2DB088ED36ABA1325B74AA9A5EB037D652CE9D10166DC02CAA3
-8392395AE8D3FAAB5927594D4BC69A452CC941D9E1545DACD1613BD66152D57A
-9A8649D2F02971ACEBDA90B55421F54343E85B8D6FF7890645DC5BA88D6C2FED
-F85B6D0E5737D9AE9632C6B59E4A97FE9D2D3A6379607EE3496475F3FA70B17E
-C2C64FA555CFF3C7FAD5990B51B433DF42A7C6C6DFA956A467D5F8C405735964
-495FAE1ED123EE002F0C04CEB7ABFD717F43E4026FED05D2A55292D349F31597
-E9C295D7A22A2B80C7856B72FAEB428FE66303C28B0D8CCF4C73F5966491C88D
-9632B8068D17A382C3C0743ADF90222A7CC8CB5AC0B963F3CCE8BFF2BDBAA4B1
-D536B645F59AD9C56EF30C88BF0532D91C701C08C251BFE271B60E2EF82719AF
-B825A0B83AA95E6CCE653769AA28984A2D741B8D54202C501C52A641AE736F1D
-E4F83AEBD9C51AAC24E4736155B243D68D14C5CB24838F31DB2351361D3127E7
-B221EEF54A12F663753FE9968319AAF6C081984DC6B462C1E28AB2E40E943640
-141EC87FF91B385FA373F3FCABE5911444B20D2156D8C51035DF8CD2B2839552
-BBCA177159B0B79AA98014AF26E2211A971A8D17FA133C7E8F04DB58184E76F9
-4ADC974C1F625FE35EC4708C03D2A4D90DE41ECB0CF7A77058B59E485F0060A7
-7E5A4F9518190864C9DC54F6D2BC1F3EB375F49D250D077733C4AAD604B90F46
-200F803E837832F9FFB64A945D8986CE577D2D13D95B8BA0E0F008A4638C5DD6
-D6B8B7AB5024B4B0344973D7ACA79CAD193CF776576D3E1B6C366635769497E3
-42F07B60727C45BA66D6B0521624F7162AD670E1054A2E10AE95ED277A7798DC
-F57B77E1B59829E094315CBF3A346D70E10662D2EA5CBFB9C224A752D7B17D28
-7EBE06000E43F904CC5F8783298FC3F4A4A228CEB28B0D9E7CF9D64A9E9AFDF3
-CD2F33654F54813D5734E7F2F961EF986A004ABC59FBDBFE0D7D9F8D354585B5
-6BD99E8EE1F14EC6D4180524D7193E2852C14D6C70B4FE93BA751C8B34AB76FC
-A1F032D81F2EE1C9159558744E8A657489AA121A1B92F5405F7DFEE9A10BD290
-111ECCFD4A84EA3B4D98FD3F58DD54ECA4248AECEA2927FC34E46E02570F71C7
-11E727EC7EEC0D83F33B98396BDBA3AA7BE326CACA99A093B48479D09733D3E4
-93F1B69C6C9C92364475448CA32EBFBF00A1BE17B292E57990B3AB7E0AF656B6
-0BD84FAF5D70C8A1967AA3C87C56CD5FD2AE844A75A63A6D8BB66EEE599AE262
-8BBE265EF7ABF588910925A0EC71DFA1CEDB71091A34CB3C2AB6F85DBB865A4F
-4B348545E8224902BAE1F1071EBEC0EA7915F2610279AC00033E713F205A45F8
-E0FC6E3AB8EA5D04031397B0716E22E1DE70B65F12E51E39A29B9CAEC6235769
-6BB6FBBA9E3C3AF690D9F9C26E233AD77EF046889FC2FE0634A2EACBA3FE22CF
-0E378CC2538B1E57ECE1A4344A5234E8C6CE0911F485C241712021687C767DC0
-5435A8D64BD44E9FEC81A40B09627186E9D40C945E0F3C03CE144DAF53C038F2
-3556B9F952B3FC6600249196D99EAA7884E91C1E47C90E43FC0C86D6C24DF2D5
-C7B0F764DF52794743ACE14CBD17A8E3A1A567B4B4328AE4FA689EE6BCFB4C3D
-B3FD9D67A65A674731DFBF1B7A47AD738DC54B1885B070C08A458E329C127CE8
-5609E5C60B3F86C42EBF71B82616CE17711DC181E2DFB999EDACA98230EF47E0
-AEBA7DE3381344A797095004952DABFA08A8FD0ED4DB2248BB863B9EC85EB47C
-7985B4FB13BA04B1C489FF1278B8D7CC16B9AB43DB1BA694BB39702CEC80BC5C
-FA8D006CEB69BCEC8EDCB0564FDCBDB13D8CADD37D84502EED35092A49A250B5
-AF4C971B4B3E6E3AAFFC0F82CC44C0F1E9C79F7668EEC958AD4A6645AA2FA0E3
-C0502753687524BB98F557E8528A02EA8F
-0000000000000000000000000000000000000000000000000000000000000000
-0000000000000000000000000000000000000000000000000000000000000000
-0000000000000000000000000000000000000000000000000000000000000000
-0000000000000000000000000000000000000000000000000000000000000000
-0000000000000000000000000000000000000000000000000000000000000000
-0000000000000000000000000000000000000000000000000000000000000000
-0000000000000000000000000000000000000000000000000000000000000000
-0000000000000000000000000000000000000000000000000000000000000000
-cleartomark
-%%EndFont
-%%BeginFont: CMITT10
-%!PS-AdobeFont-1.1: CMITT10 1.0
-%%CreationDate: 1991 Aug 18 17:48:50
-% Copyright (C) 1997 American Mathematical Society. All Rights Reserved.
-11 dict begin
-/FontInfo 7 dict dup begin
-/version (1.0) readonly def
-/Notice (Copyright (C) 1997 American Mathematical Society. All Rights Reserved) readonly def
-/FullName (CMITT10) readonly def
-/FamilyName (Computer Modern) readonly def
-/Weight (Medium) readonly def
-/ItalicAngle -14.04 def
-/isFixedPitch true def
-end readonly def
-/FontName /CMITT10 def
-/PaintType 0 def
-/FontType 1 def
-/FontMatrix [0.001 0 0 0.001 0 0] readonly def
-/Encoding 256 array
-0 1 255 {1 index exch /.notdef put} for
-dup 97 /a put
-dup 99 /c put
-dup 104 /h put
-dup 114 /r put
-readonly def
-/FontBBox{11 -233 669 696}readonly def
-currentdict end
-currentfile eexec
-D9D66F633B846A97B686A97E45A3D0AA0529731C99A784CCBE85B4993B2EEBDE
-3B12D472B7CF54651EF21185116A69AB1096ED4BAD2F646635E019B6417CC77B
-532F85D811C70D1429A19A5307EF63EB5C5E02C89FC6C20F6D9D89E7D91FE470
-B72BEFDA23F5DF76BE05AF4CE93137A219ED8A04A9D7D6FDF37E6B7FCDE0D90B
-986423E5960A5D9FBB4C956556E8DF90CBFAEC476FA36FD9A5C8175C9AF513FE
-D919C2DDD26BDC0D99398B9F4D004D606918A40B8D7BFA821B73E118040992A4
-E1BF99740F8FAA47E4349853C8149C0F8BE2F23C6F332BC0373C867D0715E8FA
-FF163A60AFD0FED665D5829739975C5DE12EB30895604D211F645D4E13330DB7
-64B6E35463C93B752F691FDDC44595B0A0E9E57C6F649809C4DBC7DB58102A60
-46349E9A5740893A1BD4536B99ECE72B147B713619037400669C07291022F84F
-4F3302F8244D2F0F1380466E81E0B5E00AF33E021A55620A7A93F3BD49C7040A
-67C096167F502EF2051B526405B9391B4340A3FFEC103E317E315A88D31661E1
-7E4104A2B925D1DDA9586861904FF6FFCE6A8E808385E4C4014F5A494874E2FB
-C3758D6989AB68C4CEF82F92B9439794FC404A29D086ED6B27997735BC3A24F0
-473FFD74BAECF5282E2EBFCB92D69B81C568D394055E2E30A7E3F448796E4EB8
-019AC2E075377F777183BD87FDD194E855ABFA35AFA73304DBB181C267431B16
-70456FD8470B525011891C1E140B8FF24A474B89F1CEAAB509F91FCAF512E16D
-8413BAC0C664FDCD31245C5996F4883305D3EDF1C8D1E6F0B1E79A06028BBDDF
-6AA5B515DF33BA8FFF2394262F3FE1DF95AD661322BFA5179E325BD1B1EECE49
-69F64789FF1BE8DE5CD7485571A07471BD6CAB4891BAB122BE4C4A1B7176F33E
-A1A434F745811B71EA8AF73407F32E9F4EAAE1C1FAA979523C18A24F754C307C
-CE056DCB71B20292D4FBCBF9AB9E9B81DADAB90E60BE926315049E5BF0F50315
-66D82E4963CB556F19461F43EF80302912AC1168884A1692AC59BFBC431B14AC
-A5FC06C4AB595F9DF66CE5EB69568038445A9EDDE20CF92BA308A235A872B15E
-8EE6356F4041C28B24C085EF70B228149486F1E0C94ABF729645BCD8A06028D5
-2E0D9F5A8E1BEB0724B397828DDAACC2432023A931E5E028064BA6B61D18B20E
-C25E0637B21F856529A1DF1A43D939B77DC0F03A00D9B23964C9F47129F04A33
-35A579B7F07C31384513392F55AE902262CE554E2B4318C5C93A6C934B505139
-4461A84B9C8EB9B1DD76D205913636BB6AA2573738BA6C3D55413817DC394E3D
-1D2A67D6CE019C198843CC05C8ECB91510A022431955273461F2F8A60ECB58A2
-7B587DAD7850AEB071BB908A51AF894298BA04FC511E77B2D4F195EE3396508E
-F9640B89A55C2E803BDFEBBFACD54FD24B59EB708C18F33B85DEA8D574BE1A23
-C66E45CC009F241DC6326ACEF2EB2D06E5013139AF7ADC1F4169AF759803F782
-CA46207F3214EEE7CC8A20076FF439C7C7E677A8DEA241E79F69FA0E17F4C08F
-A08AB475E5100427CC6BBB210522C97BF2577387F52EBBABA628731464988CC9
-84162511A10A9E2B34497E41B1D6B6BB0C1F60A0CB76E8A7D71C3E35D81B2CFB
-01BFA11CAFC84AD4AEB395E11607172D7DDCC82B44986E08E8E53BF75EE6BD5E
-9F957CC7C6D5598DA27BA89F1B2E729BFB8ADCEC8E883A6C6BF5CAB8F91CCE5D
-D8FECC52754F5D0BBD2923C8680D1551578CD2212657507E00E7CA81B539E595
-4441A879E4EF828DAC4165B5DD2DEB41257DD4F5D70550AD2773901B144EC734
-9D621E90B3F8D1623EB8DC7F5C734F485A8A50DDAF59D12574166C992E2E5332
-1F50CF51C9F20BC965CC2E942BDF2593E98050BF63C94048FC4E47C5FC218452
-857831D668A7CAD8054C9AB36C6C2601245B516FF09A0E5CEBBDBDE31114A8DC
-B60FE422EAFE1A626E5E4392281E418438075E9464256F86A50E32D847C9CE8C
-0E410E9A9962D0F6EF195980BA8E269A90B94A1485779E5BE6D436E050FDDCD7
-4D6B14059AC50E66D62531C48ADF954AD90EC245258F08418A211957322EE1CF
-55CAD650F5435FF0C7FC03A9010A3427A92F93DE9E726695806CC517F669D17E
-70F48822E599C8A2A3D01B6A74725CD02577C9D9823F10166553638C35594AD5
-79BEA7FAB8F6DC9341778E66F4107D
-0000000000000000000000000000000000000000000000000000000000000000
-0000000000000000000000000000000000000000000000000000000000000000
-0000000000000000000000000000000000000000000000000000000000000000
-0000000000000000000000000000000000000000000000000000000000000000
-0000000000000000000000000000000000000000000000000000000000000000
-0000000000000000000000000000000000000000000000000000000000000000
-0000000000000000000000000000000000000000000000000000000000000000
-0000000000000000000000000000000000000000000000000000000000000000
-cleartomark
-%%EndFont
-%%BeginFont: CMMI10
-%!PS-AdobeFont-1.1: CMMI10 1.100
-%%CreationDate: 1996 Jul 23 07:53:57
-% Copyright (C) 1997 American Mathematical Society. All Rights Reserved.
-11 dict begin
-/FontInfo 7 dict dup begin
-/version (1.100) readonly def
-/Notice (Copyright (C) 1997 American Mathematical Society. All Rights Reserved) readonly def
-/FullName (CMMI10) readonly def
-/FamilyName (Computer Modern) readonly def
-/Weight (Medium) readonly def
-/ItalicAngle -14.04 def
-/isFixedPitch false def
-end readonly def
-/FontName /CMMI10 def
-/PaintType 0 def
-/FontType 1 def
-/FontMatrix [0.001 0 0 0.001 0 0] readonly def
-/Encoding 256 array
-0 1 255 {1 index exch /.notdef put} for
-dup 15 /epsilon1 put
-dup 34 /epsilon put
-dup 58 /period put
-dup 59 /comma put
-dup 60 /less put
-dup 61 /slash put
-dup 62 /greater put
-dup 63 /star put
-dup 65 /A put
-dup 66 /B put
-dup 67 /C put
-dup 68 /D put
-dup 69 /E put
-dup 72 /H put
-dup 73 /I put
-dup 76 /L put
-dup 77 /M put
-dup 78 /N put
-dup 79 /O put
-dup 80 /P put
-dup 81 /Q put
-dup 82 /R put
-dup 83 /S put
-dup 84 /T put
-dup 85 /U put
-dup 86 /V put
-dup 88 /X put
-dup 90 /Z put
-dup 97 /a put
-dup 98 /b put
-dup 100 /d put
-dup 101 /e put
-dup 103 /g put
-dup 104 /h put
-dup 105 /i put
-dup 106 /j put
-dup 108 /l put
-dup 109 /m put
-dup 110 /n put
-dup 111 /o put
-dup 112 /p put
-dup 114 /r put
-dup 115 /s put
-dup 116 /t put
-dup 117 /u put
-dup 120 /x put
-readonly def
-/FontBBox{-32 -250 1048 750}readonly def
-currentdict end
-currentfile eexec
-D9D66F633B846A97B686A97E45A3D0AA0529731C99A784CCBE85B4993B2EEBDE
-3B12D472B7CF54651EF21185116A69AB1096ED4BAD2F646635E019B6417CC77B
-532F85D811C70D1429A19A5307EF63EB5C5E02C89FC6C20F6D9D89E7D91FE470
-B72BEFDA23F5DF76BE05AF4CE93137A219ED8A04A9D7D6FDF37E6B7FCDE0D90B
-986423E5960A5D9FBB4C956556E8DF90CBFAEC476FA36FD9A5C8175C9AF513FE
-D919C2DDD26BDC0D99398B9F4D03D5993DFC0930297866E1CD0A319B6B1FD958
-9E394A533A081C36D456A09920001A3D2199583EB9B84B4DEE08E3D12939E321
-990CD249827D9648574955F61BAAA11263A91B6C3D47A5190165B0C25ABF6D3E
-6EC187E4B05182126BB0D0323D943170B795255260F9FD25F2248D04F45DFBFB
-DEF7FF8B19BFEF637B210018AE02572B389B3F76282BEB29CC301905D388C721
-59616893E774413F48DE0B408BC66DCE3FE17CB9F84D205839D58014D6A88823
-D9320AE93AF96D97A02C4D5A2BB2B8C7925C4578003959C46E3CE1A2F0EAC4BF
-8B9B325E46435BDE60BC54D72BC8ACB5C0A34413AC87045DC7B84646A324B808
-6FD8E34217213E131C3B1510415CE45420688ED9C1D27890EC68BD7C1235FAF9
-1DAB3A369DD2FC3BE5CF9655C7B7EDA7361D7E05E5831B6B8E2EEC542A7B38EE
-03BE4BAC6079D038ACB3C7C916279764547C2D51976BABA94BA9866D79F13909
-95AA39B0F03103A07CBDF441B8C5669F729020AF284B7FF52A29C6255FCAACF1
-74109050FBA2602E72593FBCBFC26E726EE4AEF97B7632BC4F5F353B5C67FED2
-3EA752A4A57B8F7FEFF1D7341D895F0A3A0BE1D8E3391970457A967EFF84F6D8
-47750B1145B8CC5BD96EE7AA99DDC9E06939E383BDA41175233D58AD263EBF19
-AFC27E4A7E07D09FB08355F6EA74E530B0743143F2A871732D62D80F35B19FD2
-C7FDF08105847F13D50934419AC647CBA71DF74F4531DC02BBDA22AEEA3FBBBB
-407E0ACC52BDC60D01A29407CC4F93EB8BF6D4813E9BA858D54F38918AC82720
-4956D50291F0546E50FCAFA6DBD0099123F5ECD4AB338DB310DB4CAE11337A89
-8ED99B6F483940C97544F888EAF0CBEB11094A13C073D0061808662A04A82BA0
-AD35E8782F854AF66C20C0FEF18D0ECDD1646321B93D327E53D88CA0E825FA95
-05AA57BD7684554506B2BEC1399437F308EDEE32B11A1214CC9BAFF1634211ED
-233D3AB8E7ECB59C05059E41681DDABFC386A0B70937E5BD125BCC8D005D5293
-2FE2C99D33A80ECC24CED23C74512DC8251CCD5FB2173789E108DFF6CD616404
-5D3306DF05AA2CCB2F1EC224BB532B94873F3655CBA9322F7B9E6F310AF64D09
-D7EE394D66EA1F30D68F1A34C90CDED57EE1531A34B518817E4D50B16409A9EE
-5E49BCE8C37EFE55A5B9DEC96872462C08C8A10D8706DB0C45A2B6033415337A
-CF260423C377BF6C034E6EE87D70CF780B726055B99D99A9C13C43A60CD1AE63
-AF58A3C21959E09467210D0160F73B760193671B1746B07A81CE6BB054C43CC2
-7F18114458A57EE800D6E6597FC80FAD301B42FE354197484F01713FA039EE6D
-F60972F3702A30269D8890CD2332F58D12A01D5D4069C07B4DEA2AEF1621C9CD
-8DA5E73920848625B7EC7C77CB42BADD1497CBE2F5BCF60D245BEDD5835AEEED
-65A88701043CD74EEBF9FAFFD36C2FC57A3619566862DF84FBB60F175B5D346C
-93779C3036F4596B941E9A5D119E7B81687C9CA754D315F96AF43553AF413938
-D4486B1FD4F864446FC35A0A9D163E623F9F5A27E302EEBA332161354622075F
-710A363BEB84B0D64B9633D18A0CC69B7179E3CB32FF9F654EDA245EED619E50
-6A2E3B3B9177C9D6949F396A273E451F1DC8C0D18DCB252501D85E982516FD06
-780AFF7C44BC54C427977F505DA065C995FA2C519CE5B7285A397D3AF668F412
-6F609F21E936731F959885591E2E8FB0D11037F54C314156735136D610B31CDB
-5C8EF1661E2652D53B075D40BE900B4C15BBFEBA8F6184CFF107245AF723F21F
-F193C51F5AE04FD171A0299C9B15D94DDD530B923EF645EBF8225D6843271EEF
-4A6306253F04432E35FE5576924B30D54069B0FBFAD5ADEBDD233268E0BED916
-50E235CBF740830E89B01E38AD0B074F6B7917DD10F2D31CB07D7307755486F5
-14244A1F80B560D73499DBD3AA02F7E0209FB688AAB6F67D6AC331D6B25BFCFE
-DB85A8807BE80B1819C2A8212EAADF94F49278BDB9DFB7441D85B16DD619DAFD
-D3CF683382B3DA5DB2C231D93F187D3C402E575A04B6B8B4487EE2C92900F54B
-6A212D9E6C1C996E51D13BF85B266AE4B3312117B3FFD9BD5997DEE5154329F3
-150413B4EF177B3C9A5EE002B0F0C89564CF4DD48294926CE364C7D1711945CA
-BD85145E22032A2BCAEE2090FEE8E912CFFDFDE9728F8E44EC026DD624556B9C
-974485CA4D2DB834CF18512018E57BA8BD661AB81F3958E49689F0EAA8E5E0BE
-0D3790227BE97834A9E9253EAC535E4D1461BD113B5DEDE9493231964166E339
-04DC2DF296CE698665B5C64970D95838BEE04DDA0F37683EBC89DE3672B28D1C
-0C48F6E4017287675B87D7F6696FB64C3B5DA42FAF5FF6650F3335C69E00BCC3
-CEBF665EA7B318B29FDC887E273FEF5B65BA1727CF1DF8B365ED1F8BF321DD1C
-6599FB30DAC0F87BC458CB0FFB8E2CF0FE383D6E3B683DDAA9C2FC40C77770E7
-AAB65C3A0B042E175F7B5D7103BB372946B8464CF6144FAA816AC2965E07B0BC
-ADE20F97AB1BE7D1FB36D4AAD47BF2FD334776398E8CABB59269B3032F48467B
-F3334497A8E823229A4F604B7A8236EA7680D55DD21045CDC9F7C36C9CD07084
-472B918E7CC45BC39C18C7B09A754CD096CEAA6767168557B7577FAC3EDEBF1B
-94E1FD7F64ED91B437491540736AB7AD35B6C5E906DD26C3DE97EBD306550972
-D162EAFF3AC576CF9E6EC8F57FF56961C4D7D0086A71B4A974C8077ADF6C91F9
-0A868951B07CD4AE0AD725F4BA6C478A21B157213A19E0CB97DB5C87DD568BFF
-A27FA431ED7CFF328E7A3B43D8621BFD05EC593A18675EAACA878BEF0B4FE137
-82FA73F07B04A0240532C6BBB348E8F28F341AB4CAB947DA4284A146B4EADF1E
-1978B8D3FB41FED0AA66B9F20F413D06D4E04D47F4E9AA40526DB44FA402FA52
-552F1C66E6E9E2FF239EA41AED805EFBBECDC8377B968E0F26444E7D3471902C
-3D11BF287A47A9CF3A1A374A05B4EB9066C58A297E9B7912FBD2C0B33FD1188E
-BD1802ECF995A5A7400A618E68248627FC9C25C28958494517BFB6B7D57B4683
-D09C1451201F1162EAC960239899F348038164CB22C4F18B9DBD3327D9FE0CA2
-E3DC22DF0EE82E6CBCFE91A74F6218CE280F0893AC0667BBDE048A2090931996
-1A4462A9FE2EC5571FB9B4E3BF232AD028BE25CA5F751A4B61AC051B34A36022
-56A6F1AB431FB9F132DD38922BCF18CAD7C288AF11ECE6F2DEA38C86ADF7A77D
-59F2D10F833329B1DA394A6FED188775F8823D9A23232B5C78FE966AFEBFFEE8
-0652F6B71BD600883E69A726161D58E7AA1A10BACD28BCED69C5E7EAF676E436
-ECB87BD43E8EA5EB243F668B9995D0127234E4503460E4BB6CC0608132C8E4ED
-91C2230C08A720C0751581A24BC1F2E2F35BBC9F51FE3BDA2358F75285636557
-63E3DA75F737250AD20C19E07D2788755E4505E7C2CF957DA01A0BD3806243F2
-CE5290D40615A4E4D194B6A356777E268D0242541F51134A065673887AA8CEED
-85404E129F01C37A99492B5CF425C09A2490AFE9B6B070DAB0B865F6AD2CA51E
-FA7C71BEE1DD9E269B83DB9458DE5022DE03F3A23FAA20BA96C1CF46F233A18C
-3353AEFD852F0DC0C52CA8BBED1DB03B77A8C7EFA3FF609C4B9CA0EAF3C23EDA
-6318BE404C015C3E4659D554BE2BD4746E197C69F728E95A74D18ADA56BD2DB3
-8FC9B27E4F506337501516B352FB7287B94851D95269365BFBC3D44E6E8C71AB
-08BEA63F6AF62CA877E0D276E4CDA071EB5DCD17C3ADF4B0B71080139DC9F7E1
-4CDECFE01C9007C308F4BE39278CC44423B91A884A5E58A39671CD31D24E016E
-6AD544ED03CA17F9D6852134488BF8BB63E58B81DCEE5371634DF78788FB703B
-732BA51999AD7469C7078F659521C7D2189A62D960CA4BA6A1D8396DD54161B0
-E00B88D21050CFC419EC7D142550BC5186F7C981D3A011A6119B08F5F95993B8
-EA0542B45637BECBE88094CB76279C4D097D3080B32AA908DD087D1DA43A6D14
-893F16449C75E3D943683BD3F519478F3E2152DDFC50FB1DA4CB6114D42F0F4B
-079815843AAB07C826840A03D7B8DCEE8156888A49E0F10C00B477F1384B84EC
-FB7F71D615DD93B7EFCEA56EA75E0B54FE9D86764A9E353829DCAABD994D681C
-FE656A0DFC45DAAF8B3FA35374E7311FF6CBC03E1339A36785AE2BE1C9577A7C
-7C22CD0D19A7DA6BE35EB9F410D4766AA8319D55E4E619F97D1497B7A947D66C
-C7BE40B7D00B93FEBAF1AE706366376D893A831EF7885D4BAC409ADC4B39DB45
-F0061BC4156F5EEE6FAB1E3A014218F509ABB8F307A39820B4D57CE13177245A
-AA0FF27E8F8EB9E80168211BFA05233B4DFAA9A64032E41128B095FB7DB046F0
-3DD9518F2F65D632914FB51354BC68974D79F8432EA09ED361AD0EA0DA7400AB
-30D8D456B3726ED866FF71C06E6074E6DFA0F6EB8BD22B3B0888E82128E9F4C6
-AF71C9008B79A16415BE5801B5E362E41BAAABAECCB30B5FC33B3A3E21C1D5D4
-C279C1CF73C12F49DD635B10521423FEB63A0650AB79F303C67313F1D0E9405F
-104F20AA9DFB31E547739A0CD0D551932DB6425A2078DF15C41C9D08FAF5DF31
-B79A37B56437B43B3F85058B47983ABDF974F7B2036031A481B04276C50BDD6D
-65F05F825239F7492980B96BAEFCF1CA319E500393CBE2F6FF232F989AFC5BB1
-98F6CF65046511696A20BC081E88D862F563BF90C0F270AE34EC52D909EFD2C3
-9063D22532E5D4BDF47E82400F21AAC241CABD044E724CE36581A63A07A0BD8B
-D1A57754637C64B731C1A71EB58A75AD04E007D24A15509BCCB163718B8FAD59
-D0AA861C2A7853D8689DF03E52FECC516645CEBBD601FF075924ED516E9D5D13
-98B56877711C6B68517A0BBB7686715257BF7747A28793E52FF4E6A603F853CC
-62DF20BDFD752FC1FCD940C3AC0085E666BC3E508A899149A916A46D727B58F7
-0D893617DC2490AEF4FFBEE9E438FBED4631F6D8A135AC349008566224A71817
-0E64973C6E2DA47ED40226D4AA8BDC958E35C4156DF76C44857C0294ED7A39EC
-6051CE77276E3B8556E38288FC33BDF6C976AFF6B64A39AB0F39D0C0B9F55F38
-B6112961EE57CA58503442E381702C43E2063C89617263D041FD03FB0A1FF453
-3119F355D07F2A1A6491A983B3FBDA5DA7721AEFF17B6CB74605F66E4E5C9355
-7E5F8B7FCC706310A2524814E86036E9DEABE819E869D196D99A077F61C7A78F
-DDA3A7C310B64C8517F1EEC6EC35E8A556DD4675546D4EC683E71C42AF5F3FAC
-64934B979086FC0EDCC73A9F6ED229896D616A0969DAECE368FB94BEE22AE6CE
-EC297471087F7D57C4374888DF5354D5190853C46BF3EBB7F90FF12D100AD052
-FF24FB27E3C585A16DC33F234C26FB9AC886FBF950429B425F8CDB71A470FBD7
-9F44B6F05DAF13540426A43E67E57B7C62A94B09053FC81EBF68BC3D6F5ACBD9
-E4753B3050A25D0F30C7DD714188F5A2F34E6171CD10C5CD784CFDAAF1046037
-8435E1A05C8AC81402362B19941070175EE0D8B7B6E058669E3F1803325BF396
-82EC8EBED5C18ADEC40EDEBA88D766635F76CBFA092162360D806FF721E1DF49
-65B64860BB3C14D889F5F9E7724AAB0D496C67EDD5DDE9A86BF99BF89BF4FFB8
-08C816E79287F382025F118D8B8E0428DC3A6171C181B2C9A45D4EDFEBE40BD7
-A387810248887C0371D64BBA1FA33FB9C27277A372C92FAEED68322B304ACA3E
-30467A05C9D73331FCD9CF5E8CDEAE2FEA2F76AD0DE6494608746106D6E8EACF
-FB72869141C7828FD218026F9A239AD7B3160482802285EFB9C0BB538D245223
-B5364DF6237123E8B7E725C4959CEAA3989E7D98C5613E76A9616EA0F2EFDCBA
-BE32BC99D9739249ABC901EE3A2C5DA96279DBD183E355E0AA4B6FD9C29D3741
-4EF4CF3048F21FA9E06353C221D971CE2098138BA89C2A76DA29CC61B34388E9
-A15BD58AE95BC811BF6EF8B770F8D237B5EB8E22482F5D7DA9DC18CD6ECCFE1F
-D470B92EEF1AAC5FD9FF1E28E58A49BF94E0FCC4E42581A33126AD3D1D4A9505
-999DC33AFCC019C692326E13358BBB6EE3E911E19864DC1AFE07C88E3C223C3C
-AF3E2AAF6F8C78E90D0B3E420C7AD33ECF20DC67D985B962CA68A115A8D72544
-486C7CA4112A9CFF817E095A8EB5C9A7A320988588E03F7C2BF66CF9EE72211B
-FAF741A66128AC55E39FD08446C428631F5DEAB90EB74050F7E9030D2E66E830
-BCA19C2FC207D27AF3FB36F71170DC551CDDDD5DE8BA14B9354592F3E3AD218B
-DC2749D435B2DFBD8C4CD8C885B3884FE054DA51DBBB07D2DB89AB8869F879EB
-D79E64FEC1C08DB3D85CD55D90EDDEFA3B381388F422BD8E51477A5FF223A70E
-49D80F93D8A17E2100A67C80CDADA3BB629A8C594FF095F7527389552CD1FC93
-124BAB568F6C15D7A17E1A8CFAE9EF5092947E36297F0F5805ACFF3E896BC7BB
-04D4DF39EB2E874F5EA30ECBF0F9A77AD371D924D564599A3B6CFB4A5CBB9751
-A31287DD41782900722B264E927A725D22F78C457472B9775565540D3AFC2DBB
-9B4BB7B17CC0C0D003FFC89D6F25D4315880BCFD83A7D8D8EB0CAF0271BC68EA
-AF33D9BB9101C40A2D6911CAE1A8868FE311798EF7C43F2C1246C21C892885BB
-44254E408F2F50A03F4AC0B06927536058345C76C00FA5FA257EFE82CB3F9FA1
-03BBE8B6819CCF1A6514C80C2BD2E4BB15832AB8B76B0C24527D26C24775F287
-4962719B9F3008A2F886EC759C29EB75D212AAF2B9B7E381C834A78DE7368A6C
-0783DC3EC479C313CCB0491224D92E1906AC09C2843F9D44EBCE187709E91E63
-4E6C532EF8A79473626FF0F74F28167C72769070322037A43A708DF429D0774C
-0AF76A644308CAF789D4893CB159E836B4F864C0F53B671CB98CDC81D7424D4D
-A2C9F2E0321CDF449E8341F7DF3DF721988A05756249DC6C8852A288F10FFC2E
-6B9A0D22C97505B7EE7AD33AFCE04F0F8474A95A3A1DD3E0F22EB84037EA35D3
-B693E6C21A9B23B1B52C69AF37D277D7C0C44AF1A05B9B87276813952951F76B
-1228E74B51C592BA5E8F8B45DCF39EB3765F841D6A96036C2153EC0B88E4E776
-82C6DF97478C2EAD289A31018F1CC8EA3A2F189D38ECC2B5A1C6CB0283449C98
-19403020CB59FF334058A8830D3E4881707C47C77DAE1737926F9DDA13096E5B
-41E7AAA72217098A3552769B8F2871BA62E05EA346AB13359533AD2EEAA3338D
-8F00D3DA5B6F5D96729BEC2E7558036CDF779B2528B9107287E20D46294F5F63
-9935D877FA9FC05C4BC191F6814C6A3730D288163DECAC6EBCAF5C219F2CFC4F
-13574511413644952B9F481274D0C78421AC5F313C800958FBBCB5716BCC40AD
-90580C6C46CA8EB4CA53F39AAF2596687F027546EB226CB664EAC600E9BADC70
-A89D526FEB51F6FB86C6793D551B680ABE57756FEFB5FEDD79408821B5F4ACA0
-8A72B7D14A735B4CD72EFA121701E1013D41C03F4CE966A319103277B14AC5F4
-442BEC4391E443AEEFDFE63F5F203C9A3C73DEFF3C679CD55B12B10738743315
-0F0D5300AB89CC3CBC60FBD9940BFAA891EFD0CD483881EECF9C311D31D708CA
-92723EB7F744685B639E28DB289D013914E683EA1DBA7C945AEC4F67C4D7ABB1
-AF70CAE9B693F74D02D6EDEC25508F6F29DDECC13CD962C9122B42BE66444F7B
-B7625E945DD0DBF846DE09F7867CBC3B3DC40ED55648ECBBBFB6960201B415D4
-0A5067A5E7BE9D06D825C87D3DA3F5BC63C3F03D9116BF03A0FCD0EBA3A032A3
-7D35AA538A1FB9E04EDE6BBD0B5C4F1CAF0B4EB41699C877501D1EF7D7C0AE22
-D3A0FB3823ABFDA3A21A2DB1112E649A1028A8698AC4A62FD30D1F38FDE2358F
-554FF8A50A3CA829F343761FA6AD28250FE0D1A9C9EC969780668B45B7A78B41
-45A24DA2AB10BEAD6E4B9E5E23B4BB2A0328AF7C3615AFE8572BD50807CC9354
-9FC7B394B57868F44B28BA600EA659DB36830DFABC09DBC805646AA82F1F5519
-12A8F8BA2523D8368DCA11B4B1BB45B1884926AE9B02BA2AA812DE8F5E6DEB3F
-2B21ABBAA4E9E7398DE308CF10672D3C7A33FC1131297B73883B9C3396B2E4CE
-4A9156146093650513CD61B548A87FF126F734F64E9359F4F978AE515EFF8555
-F4E7E8842FEE8B2E3EEF8CAD4F664ED53CBA30027C4676E3B022C59F1BE3C91F
-9A4393B24B727EEFE67DC1E46B1155599839FB528320E90E271E9781C5F2183B
-3E2BB3D135ADC660CDE55758EDF4D3C1B53CEBCE5BD66CEF07EF424BD9230B29
-7E71A4CF8C125BB05F831669B0CECD3CEFA899E86C35550C93F2C17B84B82F09
-C257E8505ED45C9FBBE55A9AB56DDA42D9ED74347187DE6B5695865A5012FD17
-7B695E316A9CA4860556633F0081B7C52A32A28946481C1AC8A8C5F7EAA98FA7
-3C90A615546AA10736E71C47C74FE3D733E77E8924CE72C45F91ED1EC4DB062C
-9BFAE302F4CDEBBAAD423D0039373714DA09666E8CE42C3606E3F476D374A78E
-1F5C4E1E7594A408EB3BD9EA3567957703E1FF12011379A81C18E4EC0A4FC105
-3C988412FEFA730DDC7095E9EDD721ECC688A00A0E093B4088B3FE24BBA431CD
-408BCBA6404CCB6E9E38A19CA6311BF768CDE4FE6F517E1BA1E0EF2B2B9C982D
-4D3C6FD40C4DC5155A549256FD3C196C68D8A291E5EF8560966C522FA5DCDFD9
-295991CEA8B1E5410792D598E5B9BFF3CC352677214B479C15D8B596346E9082
-9A426511B7E5E9473335C44EFEE05F57EC0054331B4821E636FC8D26E176ECEC
-B28A2F8C686E97673F33B03387710D198F140F0780E71229945F027C766CB5CC
-33DAFC7F75BAA9343D897AC7384D8DABB323B1A9BDB9BDD42D101F1CEAC44EDD
-0DAF6EF5E74DCE4DF75444503E9C82564BAD9C9C85F73D8755EB29598E75DD2D
-693CF8A4320A0E24EAA682D30DB773FE53190FB0D7A7D34E1A1DA8B626452A7F
-0C721C5D34D70CADFEB94731E57355514EDCDFCB1140D4810179890BB445930F
-6C47BEA66B3E8F7EA36D015846CA3148AF83C6F008DC2D6A5D2BC260A37313AF
-CDE7FD93B30B16F4C113C8320CAF73ADA4136A745BA09D7DB6884FB2CFE8769E
-BCAFF8CA78E2E5DBD8C40F1854DDBE276544757565392753024A54B42AA3A3DD
-C8F6CE4976955A24D9C8DF8E721218BA0223F8D6968ED22703A827B2490C7B75
-919E294642B4FB3186A9CE80E57146FFF226AB4BF71EE2DBD81051D55E4C1C94
-BF8A70CD59FBC881E82ABC535EF44BF43306BE5C72DBBE402EBE58C84A8A72E6
-24E5A0E2E8D6078F0BC773093A7EAAD028810BA8C99601665B83D776EA5EE51A
-C30CCD94305B80A56DDC8A1BCE5047F3362479851348D58EA5AE996230EA2E9C
-1323B7184D0DB489BE2913FE5C422E9EBAFBE53A37523DE54281E12F86860C22
-F2C809230516D70A72A608016CDB2FA8A20DCE123E2F68C1CC751A649EE8D051
-7EBF61D48E4196E2C987AF17BF0DAC0DBFDBF520BF382BC85D693D11D9DD7A54
-9E723E2C69FA5B14E3D9083FC626B1B40AA9546D4BDE905CADB7BEFEB9D7FD53
-3E33D03E1215B0CCBECD89D5E8000EA2D8B1414592EA81348DE1F8887B3197D8
-01235283C9F8746FFCF072E51EC21EADEC476CBA755D1EC81100CE81E0C238C8
-0F745F186BBB6639A6D91A92E106C642E0DFF2E245A04273031112AF3C23BEDC
-F1351C34E79ECDE02E92CAC7AAE01488BFE59BCF9F6B5E471F57C6E5426D2DF8
-F29EBDB434D99013A26DF0617EB123DD85E6D94AAB1A979F6AA368146833335A
-7180AEB4AB1E121B75860AD31C7155667C7BE24AAE64426BF38C894BB5161CD6
-5C253F41146C7968502F6D21D6BA91A0A38188DE4149EB0833758A65E2620294
-3163B9A246255AFB31A8A8E2F50EE98B3E2AA0F2A906AEEF239A78E05CFED5DC
-3C39D9A020478F32D774692420CA7EF658585ACCA4CB0957C66630E7C02C3968
-72AC1F6FE627DF08688D7E8DC24A38AEEF421DFEFA1108F759D81BF01E67B5BC
-B2E3F204F1ABFF2BC17B6A991C60604EA78AFA6AB8B3BABBA7D88EF632AD6276
-4529591093FB83A93FA0AE627B910BF94ECF2E5CCACD1DC68BFC4BF4AEE4CBEB
-5A497F7F60E549FF5C530547CB51C1334B06D0BE2A62BDD1F80619A1F443F99F
-BFD019226F6B729A854E6A167EE6FF25C1EA4F0CA742C7A6F3AB3ECE0CA14F5E
-E9B9C46572D2F5C284F3AD78E917AEE33143E698DA02A1BC6ACD35946BAA9940
-81292609F841BE5576F7A19A9FC7056CA185F9AD1CEB3AEF0E461CCB5652AE46
-B3300432B831C616DA6A77E1183A7C547906F7E8B6B6A73B498BD2F28AE5EB22
-B8FFD48E60DAB1A06C63B5BD582EBEEE9692B4A6354BA97592B665D0A89CF839
-669E321EFFC773355042F2F3E1852E9C0CD82862C02C465EEB9F0A847B445B65
-3C63D4BC4305A39C4B30E11F4ECF0C80AD25B2696BBF018BA1F34EAA6E98843B
-8A8C55013FD096241882F1791ECD2B1BE0E7F4D5A21EF9545CC87080896E6CAB
-61FEA357C6537AEA557D48CA81B90F8E5B485F3D9AE787E7166F772489A2C978
-BF88328B6B3D0147096590D93A83A1EC41CBE3EBBC1AEEB8335F8C51F2251F64
-326E1B7477CB59C18207D3BF91F9C7A9C726722A89EAB8B70922459F59D3776F
-7366B3ED41F7F9B6D7982D6C63E6D85CA237A35088F73084C48D79FAD48F9EFB
-19EA4CDDA99B47EEF4173AAE9D817E209D454BE3D39E0015FEC7A1ABF39596B1
-054C24B5A798A7192CB94ECC33A336D643B4E7AFDBDF44D72D54EA2CB0D1BBC2
-C48A9F681BA0F79E8F537CC2FDC1CAA465FC0DED6FB94AB3D67671017145CD91
-0B0B1F662C7C77DD646D545CA8B16430EE2C698DEE47370AF09BC94493C8E3A8
-38DEFA2B106F123EDBDC0A18C7F230747C6EE75AE288A8635191B051FCB13279
-8BA18C7ADC200EFB0506FBD267CD90A37E1F642C8D77384BA6C3AC2D746F7453
-2C242DDAE0B9E5A445F6AFC7D205F3903BCE6E636D249E45D17ADD40D1352513
-E7649B035B0EA9F342E5D0451EBED1A2BED99BECA2C2C03F8F5B4D4A952F28A7
-BB243BB479D21753E48B22175F65C4D299843FB92B1511CDC606B03D2A539CD7
-19747F0F378E8585D289E43363F28A9AB2B818360C5EDED3690093FFE5652498
-93BE83789DC81ED2C9EAD6724B11DFAECB2377F66515C7D96849E23389E2C77E
-9E5B3198DA4A7E84E6E11B930E6599E832252914D0F673F3CDCC79508CAA5BDE
-483BAF0E2AAD64C76FDD8D62C74EF79394C307741EA29D1C410662224D239E36
-174D4EB5D4216E8047E22EAEADEBAD427CFCB437CDB9757B65857C887EFC9D5A
-8736A028A36F0D423A456FFE10A9F2FCDD3CED2AB34A5E01A0203495AB9DCAAB
-A8407E41B5A838EEBA562CB1C7F984F6902E49C95394C26EFB45A08A812B9A0E
-57B45D8807BBB3CDD26645DD6FD08857D3AC421384F963C8405F638D911E76B3
-957FAE4BC672E80E091100121869EE9D7FCB5F9D79B3E2E2645B2BB356820A3E
-54A63E499D4ADC6B3DF0A2781CD364DEAC773D89DF2344FEC68E9E51D3E06483
-F46BF6FFCE30E335EE96E877C857819E25BABCA033EC6C2CEA885524D40A729A
-B92253A2B2753FFEE8271F2096C6E54719CBB1BC9F42408DC0ACF5A7AE1B9B38
-ACFD6405E0C359B72C2C626772F42B702C50B6CD208158401286E841FF05128B
-A13F3381C8B25D46E6FDACD10BD35EE9DE9611722D720C4F54CBF1CC8784C62A
-584A8C68C23D348EFB7D977C0A40025099E50E89215F4AC4BF9A6095ED130E7A
-14BC2AFE02E6F1B829EC149939E781E7DB187CB327EB12FFE5193E9CD00E1967
-886DB02C16CFE330BC070D21ECA037CD321756886D37BB75EE38ABAF75632775
-216CFEED021857D36DA2017B74D04A5805049DBBAB699D11D87089B49413EFC2
-D41EA9C841AD1D5709C10D1527663153082A4C6A313325B41852335EEFDAE715
-BC6B487DB5B8814DDDBDBC6A3837163DA3366049394CD42FFFBD3DDA3D0482B4
-88F6DA79B3FCDF5B4EFA6995E47333ECBDC6AF80CBB3C4C393B56D63977494E2
-65A3444C734D69375CBA6AE9CBDA1E8BF8AABDB2005963A2EFA04A5AB2E40284
-4436137322694D0D2366BDBC35AEF7B40A38F1E8546C1AEEC579383BAFB94DC8
-2A1F8F45FCB999A06B3A9007CF55DFFD563217F43E861A6405D75B3CB79A7F4B
-44EE3CD2FB15EF0DD10CB3831E24C3EBFEC47F695D81BCF3AABAF7F50468CCF8
-27C77FCDD01F0061A88670F8621100E5D7AE5938F62A3F1730E1346C2783DA90
-5787530CBD22BC2BF742C71B66367764C9010134985D2DB74901E41AA9DE27A3
-EAEC869D0BE4918F6E3D71438DB16CA71E9F28629601438BBBBC44DFA4ACE474
-37F3C172067D5768F7A363D1B00B71AD4729724E1AD4288A26152C1FB93F6041
-60245C6252EEB27062B381B5AEFFDBFE3BBB700540C7180C0BA624557C5FCDE9
-7EF75E3ED016960745AA8C99416621D634192D50847C211873B441DB79073B2C
-7BE5E58DA4DCFD7EE4668DD9C9068DBC96BCDE63CDE93FEB93EE225A21231D8D
-9465F9528C10ECE4F0F12F3DEDCAB6FFF4DDA08771B2B6623915B81A6FF36F78
-5C6215271E686B6749743DAA069603AFE2563B68E716C175541373D3810DD14E
-F927E19489A95FE33831AD4F0AA64A475A385E7DB0E0BA04503F3436664827C1
-724B52F0AD613BBD51F0E9C1862B66F9D472FB6EEBA71106FE0EC17DB8FBDFB0
-4F5E302AF4937F55ADF6D2086E798B3502CE1A8617F0B1B1A60AD2DCC43036E4
-53176351541438C005143E4471120261550FCF74C2F40959D5EB92BC4FE8FB5A
-4C9F9F6363CBC53A588C0CC62ED2D57EB10B7279AA32F13D1312726A27B9A0CE
-80AC5F2C69A89DCF4EB9BACEA23BA566498D5355D2F109E0AE5B71B0F05C0475
-0BFD6B787E6227E7FC2225E47A5B33E03FCC46633FFDAEC1AE8A243A971C0834
-D95FFFDEE149537E2B51985FAC21E67362F6EB3B85F9131E0B375BDAA7A5A60C
-F927596380DFA87CCAF4308D9FF03E1D42E56FDC7521A356CAD5332344D99A44
-BC9DDED79E19EF2D740B4651A1A5A41A2E04CC7C9DCD8C4767D615E73F1AB75A
-61E3920418063090FE03F6690E5E1BC1479BD88F5A287591639401708C527759
-9901ECF10EB4EB7C66522B97A0620F5B01C0C695891722C30F8CB81D0F8FD4D9
-8A1F09EB9066811EBCF1E9470718CD98AFAB55B5F51A498D304D614610E722F3
-62A8049D1AF9AB35668D7ED6F172A4603F746FF7176275CCFB196AFDD1D56D77
-84FCBB6ED8A8F7E776780762C737D1C456866BDCC8337F5CA0FB4779BEAF55A1
-51BB1F6AB4B7343F6DF4A658CA579CAC83E888DD0E633FB9874F2E68FA30698E
-F0FE9A9176754A5E3D1DFA2DD2645F18397EFEC47062386FB2071FA51208F1AF
-1FE02AAD0DA958388D605A12BAFDE6D0B0DF7ADEE4F54655578244D33C464CF9
-7D14E3A54E4498D0FF091EA28F680D73F01A8C84F86BEB4FA58B607529121358
-7E2E7197B056A5CF74F5215150ACBF833B2C1787C505E178D2E8206B7FC5E7F5
-2A5D79202EEB3F12182472C322C5D131F5C85D507CC2BE08538323DEE11991CC
-8830ADABA736D28F3DC12C893D4F28A4845CBA6D2F2C7CA5BD547ADD2ACB136F
-72E527289AF34D16D09570E832834AE038731A49830D0023B8894E50A032ED0A
-914135CF712B69F7B6DA5AA3D81CD96921923832DFEECFA45D840D1E69252136
-779570D355500D1E17C343BEC6BA0BA66EF7ABAA9271AD305E6F0A50971AE8C2
-DF4D3F4B05136E86C46A85FCDE3366192DA41904469AD6AE4D50CDB640C86568
-DD8FD5AAA930927B6294F4F768F342D582375B6552FFA7E6655F196843824926
-D5AFE1DDB475B1239C5C20132DB5E5128F05B61827ADBF0C18EAF71E5E616A46
-AE18CAAFAF8B94DF
-0000000000000000000000000000000000000000000000000000000000000000
-0000000000000000000000000000000000000000000000000000000000000000
-0000000000000000000000000000000000000000000000000000000000000000
-0000000000000000000000000000000000000000000000000000000000000000
-0000000000000000000000000000000000000000000000000000000000000000
-0000000000000000000000000000000000000000000000000000000000000000
-0000000000000000000000000000000000000000000000000000000000000000
-0000000000000000000000000000000000000000000000000000000000000000
-cleartomark
-%%EndFont
-%%BeginFont: CMTT12
-%!PS-AdobeFont-1.1: CMTT12 1.0
-%%CreationDate: 1991 Aug 20 16:45:46
-% Copyright (C) 1997 American Mathematical Society. All Rights Reserved.
-11 dict begin
-/FontInfo 7 dict dup begin
-/version (1.0) readonly def
-/Notice (Copyright (C) 1997 American Mathematical Society. All Rights Reserved) readonly def
-/FullName (CMTT12) readonly def
-/FamilyName (Computer Modern) readonly def
-/Weight (Medium) readonly def
-/ItalicAngle 0 def
-/isFixedPitch true def
-end readonly def
-/FontName /CMTT12 def
-/PaintType 0 def
-/FontType 1 def
-/FontMatrix [0.001 0 0 0.001 0 0] readonly def
-/Encoding 256 array
-0 1 255 {1 index exch /.notdef put} for
-dup 46 /period put
-dup 47 /slash put
-dup 65 /A put
-dup 67 /C put
-dup 75 /K put
-dup 76 /L put
-dup 77 /M put
-dup 80 /P put
-dup 83 /S put
-dup 97 /a put
-dup 99 /c put
-dup 101 /e put
-dup 102 /f put
-dup 103 /g put
-dup 105 /i put
-dup 107 /k put
-dup 108 /l put
-dup 109 /m put
-dup 110 /n put
-dup 112 /p put
-dup 115 /s put
-dup 116 /t put
-dup 122 /z put
-readonly def
-/FontBBox{-1 -234 524 695}readonly def
-currentdict end
-currentfile eexec
-D9D66F633B846A97B686A97E45A3D0AA052A014267B7904EB3C0D3BD0B83D891
-016CA6CA4B712ADEB258FAAB9A130EE605E61F77FC1B738ABC7C51CD46EF8171
-9098D5FEE67660E69A7AB91B58F29A4D79E57022F783EB0FBBB6D4F4EC35014F
-D2DECBA99459A4C59DF0C6EBA150284454E707DC2100C15B76B4C19B84363758
-469A6C558785B226332152109871A9883487DD7710949204DDCF837E6A8708B8
-2BDBF16FBC7512FAA308A093FE5F0364CD5660FE13FF01BC20148F9C480BCD0E
-C81D5BFC66F04993DD73F0BE0AB13F53B1BA79FE5F618A4F672B16C06BE3251E
-3BCB599BFA0E6041FBD558475370D693A959259A2699BA6E97CF40435B8E8A4B
-426343E145DF14E59028D4E0941AB537E34024E6CDE0EA9AF8038A3260A0358D
-D5B1DB53582F0DAB7ADE29CF8DBA0992D5A94672DFF91573F38D9BFD1A57E161
-E52DA1B41433C82261E47F79997DF603935D2A187A95F7A25D148FB3C2B6AA32
-6B982C32C6B25867871ED7B38E150031A3DE568C8D3731A779EAAF09AC5CE6C5
-A129C4147E56882B8068DF37C97C761694F1316AF93E33FF7E0B2F1F252735CE
-0D9F7BCE136B06EE967ABE0C8DF24DCBBF99874702ED252B677F407CB39678CC
-85DDFC2F45C552BA967E4158165ED16FECC4E32AC4D3B3EB8046DCDD37C92FDF
-F1F3710BB8EF5CA358ABACA33C7E5ACAD6BF5DC58BDFC3CF09BA2A38291D45A4
-C15FF1916FE2EC47FDC80911EB9C61F5D355BEDFC9DB17588547763AC5F0B1CC
-12D2FFB32E0803D37E3281DA9CE36C5433655526ACFB3A301C56FAB09DF07B5D
-048B47687348DEB96F3F9C53CE56DDD312B93D3918CD92AF53FB9461864D11B8
-0138918D0B1270C54873C4012CDE6F886DB11BCEA04B023EBB43E0D0A06BE725
-741D08B9DB688731A6C9886C15A83C28DADCC81385EA239E045E8F3670CE03DB
-9EE77ED067036595C9F3B1854343BE3A12E486B6E5A2F8AC44FA5378D28DCCEE
-306B0E283AA444423F9A4FF38E2B56DCF67A39CEB2C643DAE86865517D5D0371
-CB8797208ADEC637330A3A57902C9A88EDB75A7C16FA9850075D9F19578EC666
-1353CC1FC512D59DFF847ACCD04CF9DFD4A2852A700FD18961F9C616F7F372E3
-62908D305C43B011B4324935801B09227D9CAF8F150C6C22B91B53500000AF28
-05CC714C186E39B2E0FCC6EEE6147B9D05729BD422F1BBA3C846DC9C63CC717B
-1FAAFBB5218D105ECF34EE24B62F8FEB85E66DD884F9778251A6DFCF7636B2D6
-31DAEE5764CA1845DF8E28F12C59D62A5E5F2B498F25A5C3A868D09C7324375E
-41B70FFFC8BCDD1767B77E2781BDA283B091DE9D68047D0C8F70851B4BD08A80
-E21ADC13BF53660ABB0ABDCBE66306B581576F05732CBB700058C40D14B3A9C6
-9D2C4DC308A2EE4DC19D9E7BC02BBF32A5A67078E31DC77D7706FACA6085B56B
-5D806452132320B6292873094A5B0B16517F45336881E59459284674C162D1D2
-63B40119B7C243747E11ABDCE015A348E9C260353C4B824B4FCEEE4EF1B9B048
-E2194EBA2BBC72ECA840CB7FE2BB26337B35EA52F1237A0C33F8F5273613BFC8
-47132C47A67E52C48C85583133F44736CB9407F4B0F3B93B4E790C3630D3F893
-F33C0D5AA31812AF682A81FB9C654AFFE2BC5495EEE7FCA7A5392A1590AC8A8C
-322221761544309C1F63448BB3CD35A8CCEA85AD8E120DEF630C51804DAFC38A
-0DB278B8F417DEA9504018FDCB2C745653E0AFDE27C2A7D68C3E0DB09E431FE4
-C7248A6A45ACED94CD41094806AF0ABFCCAE08206E8B93988702F9277CC253A0
-64F1E489AB70D612ACBBF8B082E949C976D122708C0AEE85752D8CD6FC8C26FA
-1BC2F8034D44254F12E31AA730D55310D0122C5888CD6C00C219EACBE8643773
-42974DF984EDB5B362EAA32C58C8599BAA126E970BC1B47EB8869E3E539BCC84
-20BED887C8FD24544438459321C50B97D4BC6379356952E6B66DA707F0D4EB33
-202524D02214C1A0B3BF5FFFF38385B1530CCFD6ECA216BD77C5B7BD71711B3E
-D9D4FFD978A89761C5D66D290BF4856BB4C4DF7A6E8B7E4B0F1D56281ED91C48
-023AA63B4939FE0650290AB0EC3F23BE74323AB3FE45CCD5F63D953ED61EA21F
-3DF1A2BBCCF605111085C886B09E8B1203E23E434C32787757D3D4AB678CE1E1
-1330B51CD48CCAEB50872FB7C8372E7A80AAE401CFCE1D9063538896BA47A48D
-A4C16F067C5D9CBE202B4816EFA0DE8F57B3980F7FA1B70320B446622B4D88D3
-CC4B47EB3B20CC7B2050642D68D69738F22D3DB36084DC8455B637CA23D4A584
-D299240072BD1583C0A2B8090D67641A2EA82AD2A341567C590810CF6504B384
-7B5B7371CD840F981DE413BA8C0BA9C6C4B4F7E9558118C684DA64A44421C43F
-FBBD57054EF4640D38585C833C805593A2860AADA5EA707045A45EC850F9D6C8
-785BE8EF2E4191A60F46B3231A2863DACE6D8257D9A7A7A331B30EF48840FC7C
-33051E8AE40FE88D39C09C20DE62226B4B6353A74813F4915D26E84139B72CE1
-61322BE724D254AB02DA12863E8C48E2F754E6286FD593342E1A3B8FD4A05225
-DB78A2B4DAAFE6B6CEFF2EB108AC62AE42996C25A972CAB8D2E7D7706D59A1B7
-A4D62F1F219B37DD15912F32816112B7DF4042B0DCAF6F529BB9F02FD864AD31
-E02B9E8F9C4DEA24DBFA648EBAAE74878F5CC30BA79B5EFF0F027EDC05578F8D
-7F3E3FE30BB3B067ABDA05F661B714C20328F231EA84F5966748A92FF6D84150
-1AB7DD1676F1B0B693C4CB818A11626C4C096F4868637807C5C23E6E49EDAB6B
-8E0B0AF6ECFFC00EA6BAF2A1A5EF93CC6F9ACA2F891B929F6775A6C363D6AA20
-F0C78E245BFFC86D103FD3EA40307182B033895695AE72B82765E5DCF7130F8B
-9C28B6DD3FEC623A7BC409C6206765AAFAF1FD7E3B2A69105FB116BC49374133
-971D7CD4885DA539DF8F4EEF04F63DD66777D3CAB2D831F677A322CBB80684E1
-13BD1A6B6C7E9C086937D08049DBCC211F133500815AB6F7CB32ABC33E3CD985
-DDAEBA7F10594D5F3A3AF6A5D3D8DA76194F80F07DE28D78FDDB69AC1B2D37C6
-988A003583B2C161A2B01E899A12880A33964D26637909D0E8B53B284AA2F894
-274C91F38144E576AC614B465A8AE629E6DC379EE54311604AE63B9E109431ED
-A388F20E374011C319E2DA115534ED4C575C5B88AF2821975BE9ED8D2F697BB8
-0A0525253782198523B62BF7220E7153AEAAD5403AE232F266298EAA5F376CD7
-CE7F714D66DF9834E8390A2B2BA5967BD5A70ECBEDB7C19EC3E906751BF96258
-D08AD753D00F4658D761DE234D0419D50326C51DDE3075D57742CCBFE3EE496E
-958A278835D42434E1C5BE44961E748D611CF1A0406816BFA134065A81C900B7
-48C829FE8BF11F9CB0D4B7A91534319295C67416870FFCB789FF4EFE4ED0F10D
-FC3CECEB00664431504E9451E9852CB5242721A932FE58858B79D2A45E3FB1FD
-48FD7430526E5E5BAA26C07CDAA0E709F650F365BF7B4C32DB7E443F90664B4B
-4CBB604A185F08A2223EEE7882CF017ECF63CD8CD61B6DC7AD4D8142CC0DE847
-8B5B7A8256D912A4BC52F94D0A8E9D1B4B555A67273475D876C8C4C4AD49F3F6
-E63A6AAD450FB504566368ADAD094AE6AF144A092435D91AE8E4766978E6091F
-A609F7D1F70A7D70C1C4D8CB36040463B0756E4AC357F2B8BE3B8AB3FC3F9DEB
-3143971D139AF15A2665AF96A227FBD34D0F401B25E5C6BE4A51CDD0F5CCD243
-8BE242B282EA140A1D05A72C7BA629E8B958326F7050793B4FA62911337CBBDB
-B947EFC351439EC93EE359AE9884BFFF0E4771CDB2BC41967CC1EF1E7C9E6739
-DF965BFB85A182D65E3226C961A8959FAA2946501103DF4F50375F49AB83AFE8
-AEC58BFDF2C9EA4211F5FDC48FFCE745421D8C798678EADF2044069DBCB5D2C2
-4789985A5D9598765C9BA2B1054A929A7D7FDDC352547644799965E0B088C3E8
-51F4052A705903AE80E0E14C046DF36E52501B714B564F21FE6C27FB22A538AF
-35EA9EF97FACDA00B07AB99BDECF31BF666BC5AA31A482958474AF939C1C1A3A
-572DD5B72C03116A550FBD2869BBA5E92567F407EDE9AC13872BE3E67BD57CB4
-772C53ED8D5D9A131C80797A38356E159D4D7D007DCB0DCFA6BAA373BA3AE396
-E5433AA42B12179DD60A781885EE3E0B29EB4A7CA42957F106811C3A9B46BBFC
-F200244420A622B5CBDFE61E6CC12788E6C34173375C5D6DCBC7277B4D40A3AC
-51865970AB4079C892931D7C88B5C6EAEEAF057936A394A2E79B5D62877A0A1A
-457B2CE506B75A543CF106AEC566F2D25D798F21315E2B5527A376CFA08B2EE0
-3A523E455B7C2179FB6B3DA5D6CE46BE7E2CC0AAA26A677FA8BFC0C11DBC9FBA
-D5C51FFC71C53C4B5317A4D92BA2CC3FD976D92A4B184F762A0FF05CAABB2EC2
-320EC774DF2F5C4B98DBC5F7163FE01CC0CBDAC29329CF7E86318ABC9B2DCA80
-254700B0894AE040C6CF9DE28F0045141DCBEB7DF7CB58BC5CE4F594421903E5
-E129A85CE3497BB3A5A5FD338B69A6724986FF95705618D9A26492DF9EAAD942
-21708E009CF765542ED29DB1B2B5F718AB132F3BE3EE63312A15225B3B559D61
-90A6E17BCEC6FC3355A834524DC38AD8EB5D649362EB33E9FF09E1C96D0891F8
-70C44804D61BE56E0AEFFC2E3FE124927B1BA09F9E1CB8E3D83D6D847EB11548
-8EB7ED2A20680170E15CF0076C9FD12478EE5ACBA1937E7E5A78A357119D58D2
-A48839BED44B961314981577E021FA2C87BAC8690E0F4997D068C08D8A859349
-976B5480E346C498ACCE2F928A322AB4525465F5E14E7B83857BE428189B0DBF
-8200A28DBE8EA6B68C48678F179FDCF0663006658E7957DCA81AC5BBE3FD0D76
-249104F7104C2142C7E767B60133D3057874094ED8BDA094A9249B80A53776D8
-2442E233F1CF7647429420711E141C1E254B113B6B1FB59BD4B9E1EE1DA6BE1D
-3F7546158FD6F960047DB1C812758C6E587B26EFF4DAD15A850D5513B24FF1A6
-19B40B0C8F3DFC729600DB76A94D582F940C12C219863B341EDDB9F4EB7BFECC
-2CF6A58C2BA1749BD99591A99C436EF998AD7B847358101FF24DCC93D0909A12
-ADA3F135C4E1B325452FDB7DA39D63F19CBFE4173F0E3534584304DF748E8BB2
-6F9275F767AA632C86C3DC7A2ED1A540C3515C30736449FC85E5C3C7E8A780A2
-580E504B9F10A4EE7D755A1723BFF4C0FDCF85EE31A27CDC09D9C5EBBFFC3C23
-79C30BEB53A8C18EE383B7A511B5F740A4B35539D23873C324488043BD9B72CC
-06A612E939E2AEB42BE57AB5BACFCD976C85B4EA86A9FB8D53EE8F8FF5371A0A
-BCA2A8603653C3BB280BD5549FE3070EE0231A735353CB13ECAEBB10868A368D
-7D65C2288E99877B8A237095C95572834579B63A3B1EA2ABE8AADA496AF24C30
-BF2E6B00930D66899AA7B035963A807FC652A2137EB7A4E7CD96E573D104F4B8
-DCA6935ABCC39526588B7C3C12E7F58CCE5FBC2A36D8E298633CD145139F83D5
-49397E6DB950853667D24D78D28D32C48AE0C4A94F79FDF4A700E253AB23F59F
-EBACF444E791C933E6FB666679CF26EC814E6329D287CAA0D743DD249FD2EB7E
-A47243DAA835A74876EB31FB1250A740AC792D3977AC2FE566395D97AD48A9FA
-1A7307092D540201D0D22ADAFCCB403FA0DD1CC6EE354872535B36CDFAB80107
-20ED3C5C69AB5F1CAB20CF761C262727310AEE68DC7119CEDA5A0C6111759484
-B23AC3BEDA964CEE416DCB911AD4055AF0D341A22548D52CAA7DE7763C565EEB
-10D1CDE0DBFC7EA3D47F5751F4CF11D068258E0726CEC4E573662030E34807CD
-B85B91B00F609CDE16F5C00723EFA89675161C38AEF8E2181D4D98DDE4AD2296
-9A7B7322D0944665F7E47431FFF8870EFD520DD5618345EE538AF9A98CF4DB1F
-3F9EBBC87FE0EF4671336532C09F2E25D73D9957C91B2F7E92F1941A0904902B
-82B54B93706DC114E1F4271926733B0FB55DED191996DAE505AF9AC148BB539D
-EDD819FC069A130E49AECF18D381B99E7B510B3BC981058179B434DBBDEE7BB4
-049DB869C4CAF5FAE4536877262EC3459CF45E64A03589D55C0C3905C032987A
-61F3BDB82FE3CD9E88CF0C149939C07CEB7381C254A62771E47FB33A6FF3D520
-9EC5B90CDB793EDBE253417DECFD2B7D4D3A01BE7B608444253AEE0C6942
-0000000000000000000000000000000000000000000000000000000000000000
-0000000000000000000000000000000000000000000000000000000000000000
-0000000000000000000000000000000000000000000000000000000000000000
-0000000000000000000000000000000000000000000000000000000000000000
-0000000000000000000000000000000000000000000000000000000000000000
-0000000000000000000000000000000000000000000000000000000000000000
-0000000000000000000000000000000000000000000000000000000000000000
-0000000000000000000000000000000000000000000000000000000000000000
-cleartomark
-%%EndFont
-%%BeginFont: CMTI10
-%!PS-AdobeFont-1.1: CMTI10 1.00B
-%%CreationDate: 1992 Feb 19 19:56:16
-% Copyright (C) 1997 American Mathematical Society. All Rights Reserved.
-11 dict begin
-/FontInfo 7 dict dup begin
-/version (1.00B) readonly def
-/Notice (Copyright (C) 1997 American Mathematical Society. All Rights Reserved) readonly def
-/FullName (CMTI10) readonly def
-/FamilyName (Computer Modern) readonly def
-/Weight (Medium) readonly def
-/ItalicAngle -14.04 def
-/isFixedPitch false def
-end readonly def
-/FontName /CMTI10 def
-/PaintType 0 def
-/FontType 1 def
-/FontMatrix [0.001 0 0 0.001 0 0] readonly def
-/Encoding 256 array
-0 1 255 {1 index exch /.notdef put} for
-dup 12 /fi put
-dup 34 /quotedblright put
-dup 39 /quoteright put
-dup 44 /comma put
-dup 45 /hyphen put
-dup 46 /period put
-dup 49 /one put
-dup 51 /three put
-dup 58 /colon put
-dup 65 /A put
-dup 66 /B put
-dup 67 /C put
-dup 70 /F put
-dup 71 /G put
-dup 72 /H put
-dup 73 /I put
-dup 75 /K put
-dup 76 /L put
-dup 77 /M put
-dup 78 /N put
-dup 79 /O put
-dup 80 /P put
-dup 81 /Q put
-dup 82 /R put
-dup 83 /S put
-dup 84 /T put
-dup 85 /U put
-dup 86 /V put
-dup 92 /quotedblleft put
-dup 97 /a put
-dup 98 /b put
-dup 99 /c put
-dup 100 /d put
-dup 101 /e put
-dup 102 /f put
-dup 103 /g put
-dup 104 /h put
-dup 105 /i put
-dup 107 /k put
-dup 108 /l put
-dup 109 /m put
-dup 110 /n put
-dup 111 /o put
-dup 112 /p put
-dup 114 /r put
-dup 115 /s put
-dup 116 /t put
-dup 117 /u put
-dup 118 /v put
-dup 119 /w put
-dup 120 /x put
-dup 121 /y put
-dup 122 /z put
-readonly def
-/FontBBox{-163 -250 1146 969}readonly def
-currentdict end
-currentfile eexec
-D9D66F633B846A97B686A97E45A3D0AA0529731C99A784CCBE85B4993B2EEBDE
-3B12D472B7CF54651EF21185116A69AB1096ED4BAD2F646635E019B6417CC77B
-532F85D811C70D1429A19A5307EF63EB5C5E02C89FC6C20F6D9D89E7D91FE470
-B72BEFDA23F5DF76BE05AF4CE93137A219ED8A04A9D7D6FDF37E6B7FCDE0D90B
-986423E5960A5D9FBB4C956556E8DF90CBFAEC476FA36FD9A5C8175C9AF513FE
-D919C2DDD26BDC0D99398B9F4D03D5993DFC0930297866E1CD0A319B6B1FD958
-9E3948FFB0B4E70F212EC976D65099D84E0D37A7A771C3101D6AD26A0513378F
-21EC3643079EECE0C9AB54B4772E5DCA82D0D4ACC7F42FB493AA04A3BF4A1BD6
-06ECE186315DBE9CFDCB1A0303E8D3E83027CD3AFA8F0BD466A8E8CA0E7164CF
-55B332FAD43482748DD4A1CB3F40CB1F5E67192B8216A0D8FE30F9F05BF016F5
-B5CC130A4B0796EE065495422FBA55BEE9BFD99D04464D987AC4D237C208FA86
-0B112E55CE7B3782A34BC22E3DE31755D9AFF19E490C8E43B85E17ECE87FA8B9
-1485831624D24F37C39BF9972D74E6EC4784727AC00B9C4A3AD3DA1C22BD6961
-7E0ADAF55422F22ACA5E4DCD4DF9FCD187A566B7FB661D0530454D0DD6C6C50A
-7A3875C6CBF8EC7769F32A1F3F7FC1C072BADEC97794D4E90E0035282A170402
-356E5A9CD9ABD80AC4342A5283E458A7269252F4541CBB6452B39ED54D336D0B
-19928E9CD1AB26AD83EB209E2EC75011A2643813053B5DBB0246097C4821B5F2
-C92554E9140BE35B2DBFCD98809A8EC9FC910FDE9E0D86457C70ACB056EBF90F
-244DC0A5BBD455E15D6E3180311D52CF50B0BF7D0A7F64F3A1821E0AEDBC2E7B
-AEB549FE1D51088C153799C6E089B5D5D65E1C4E2D2B430CDF1FFA23CCB25D95
-5C4DD885310A706B320AB25C8D742C6F29953254FA54DAAEE60ED477877D19BC
-D28E9AB576B0EA088171FD000B60D73B3C57F754BC07EBC9BF751B7D2B32459D
-993861B7C4B0D98C422A11BECEF76F4EFC0ECAEE89723E6CED53E3678D733363
-2DF068AEF0FE7DFB57393BDAA439A6A4C396F86032A98009EAE1247B7DE83B3B
-E46DF2898598FF5E6CA6953127432A967E4FD41CDD60D6E413059A58FA556EF3
-309178B57C16A763CFC9BEEC276944BDEA255789EF4E1ECDE1EA43EEDB955513
-F42EDDCF39AE522A1DC2DC523F046EEC4CCAE25792B702C288732F5B13B5CCE7
-E8B6A1A1DB86B1EA38883E481BEAB54023EDD9BB94E7780DEEA577ADAA169E66
-AB7D8607B409619E79F242CF52E618AC0DAE43317C507CDB27EA8A1472D4E8D9
-17E62C98DFB049C78AD15560CE44A39581BD6B555165091C5D41071212A9D51E
-6DC3005C821622476DB88946944FBD830DC0293272497557825CF153F8E257E4
-1C9A2C1C27CB7610BED918021BCF64795D6571584830231C7EE85AB23906C085
-B17C9070C59EE450E6124FA3488AAF61751160F6CE1A0618FEA94397D1EFA9E0
-621AC7E9AC853CCAE73DEF3F7438E921BDD42D7E139C431530AF569FD8592D99
-8DA4F085A207616874D71D6005F57219784B5B33CDCF2CD8F061090E46E0AED8
-3063FDF0E57BACE8CA49A148F35674D09BC0E0DF348A4C699E4C124BD349E1BB
-57D26EB43B1B35213BB612B9E011FEAD57A8654671AD663C327C3077284AC6BA
-130F486A332EE15C3B8AD603D3EC8EE45F16CB58973A52D05020653D9B9EFD10
-D74AA2C4E35656CCF2D901F87B041B88BDC5D9D7FE7A6DFA47708D61E1794C27
-10A6C76BE888E107E31BB3E496986BF219AA557D692B071ADCF381EA4539BF84
-8995F1A178F7A332B954DBA3A3B39839AECA02022EDCAACEE87BA717711C2765
-D38BA776CA91B85FB10CBECAE410C4CB7C660F95751B24A17DF036EF09CF6976
-E2A57F58AEB69CBC167B95E0D770A91175EA47653B052BD4AB24F5AC5545AFA7
-0C11292E3887D990977B338542E1229A8CCFD8C0E569BADB5605DA11E1CEC882
-B56DB7410C0876AF7D322540656D470EC16278878934CDBC9AC70059EB738B06
-76B7A7F6AE8A03895386CEC5C04E4466234DA674E673D68B69D8960409BF9BCA
-6FF50BB8DDC7A3ACB3EE60F34F7D43C41BC14352EB7C8D9CF3B7A162C4EDFCAF
-4E14E837DA0851B75E31AFFA052374B060FCFDC55E5DDC193765E863391D1E4D
-FF932F6A8915BC5636AFF782C93A7E6262B9ADB11C2992DC6DAE4B651679833D
-C698202035FC4BBF4AB03591B29279BAD772929660EF28C160BBF499AAE52DCA
-22B129F7E74694ACB5ACE86B606AB5B3691C088DB9BB8B84531607D0EDB8EDD9
-8AB5C323E2666FF4C5ABD0B555A526BDD9FCAC1693530DA33354EB942A0E32C6
-CB68451FDC59C7021CB2515A4CCE6425CA698AFBC8C13F312AA0BFDF84CACF02
-6538BC2C8875FFEA2B8A39768A0F6BD256D92B30798F398B60BA289C01C04F43
-2E55137362A1F987B40B039ED2672D858F52B14D718C18A11BE736A0B22A81F9
-370CA99A50204F08247ACFD011119EC1D50E0E2378B2903517F5012F48476D45
-6C5F4C9BB93D53F712EA103D3CCEBC64457BADFCE85E7441B74BC0835674CD5A
-98E03DA0A78973E464F962B26ED4C5AD58C72B8450609777145341CD841A91A3
-93D93ADA15F56221BF645BF622CB8817C48021EDC41AAC01C56A49CA7C89871B
-A98DCB0E30B5989128563999CBFC1FF9C7542E451342CE5404C27512F55DFE38
-5BCA044EBA25734570819756D567D6576D6A3CE3CE8A988857E520E7BB640BA2
-9624FE93C933A134E9E3ECDE2619C47E20BD96D3FBCB73C8CA3B8433D3E6F113
-52FFF928BC7B2641395AA81045C2CE6CB3C17A4C78FE9E0CA5A3C78C6448A7B5
-11D068BA4CF960D73D3F84774EB444C57BCC9BBE04A02B481F3449F25CA10DC3
-BCC66B1307057546B7FF211AF227D326CEAFF5230F27D7D92D1387064577B49F
-F71BB4CD5C6F4037BC5DDDFAC58EA79DFAD68220DE833F6B9FB60D91B3152CC2
-A93320A177A0610EE8B6FE569B53232162A0189322F8D212AFDC31601EE41B5B
-41A011A804BF9545E2D56367F9A3B21063AAA0DFAE402843AAA4D6C8AF8FF215
-751740DD7278D5677912FBADD43273B113BE40C94727B7FAC2362A1D56F10264
-BF60A3F13CC0095B85CF45D75C5DCD5D3FA8FF52E8AFD5AC03E3843C70DE9128
-DABA5DE448119622FFB49E20E252BB90C3CE53B0E9D1AB0141C6667526549F36
-29A68080B2ACFC6BF06AA77A99927A3AB333B17C59AF626DF4F4058F2DED886B
-5A7F5C54A5DDE271605384A57D8B91E3B9F566AC44FE0941DEC83465A87B668A
-D9AEA1DAA547A1770A6B86321C50EE9DB4160E255EA25B110FF8A97C4E85C2AB
-FFD0F86D58860EBFD2FE5DE4B2EB82DC4D14A151CB82074CC0E08E384BA91BF7
-7DFFEDA1A55279B9BB3E05733C622D804B8480E3D5334F46567E70A96AC02DF2
-1A7C840CFA32C9CD9D559963A8BE7A253AC4A1E15488C0D905C2867D7DC719D9
-6F503361ED81CBDAE4E56B81E7847D5AE5CCA57EC28EE3287E682A31D5142F68
-6084B8BD7016D7B2422D731B9C4A98194AED311D49AA8AAAF4240F0362A56C19
-52D901DF14FDB88E265C68006CD53D7813C218D7F7A5D57B1AAB851546D414DD
-970CC7E567AF857BA1B8FEE20C0998F3507C57077CAA563E85D71A3365B42047
-AB39679BD00AA143BA3CD83A449C365760788AE6A0E129DB95AF91FF2A7B1E93
-8228D01473A18D9AB7F4E518993DD0294A2EB2BEBE1843364B9435AE39469E36
-E0F72C9BB78A0A00E3A7951B26868E321DDE8D0B71A470746146664F8D2DAF5D
-07A202A2FE1F3FA443B5C004137F4D3CC33B3E77D09AD8D4C1BA590D4590EF49
-A210B8D28616638D30703A21B8D2DCE2E41B025160910E58057FD11B57A43BD2
-5548BC9530D65AE4E254DDE7D28CEDD78763D9EAA91EC60EC8DB3D22D7AA3784
-C9881299BCEA8A6BDF7AE933B9D33584A0C0347CC03A63790D76F7F0C1031429
-F9584188435889C9C2DBE03F15ABB9A475FC555F835DE7BCBC4B507DC2CBAC96
-5A970EFCC63787B4FAC5CE6DB77BA6CC1A7AADB061FB7690DD0ACCC5DCEA63D4
-CA61F076B69EC0B645447E81BDD9B4EA5BA6335EA82B75623FC2A89E1780C623
-6487E611137A062FFE5CB6A33C489FEB948F231D17E175DAEC5787B8CF65FEDD
-A35FF72C6A4C872F0CBDDA18830D4619AEEB23088113696A9DC4BBB8687CDDC1
-9EBC6C084F45469D9D660DAD5C9BBC8FE37568D32B9526199509572253EF986D
-0993B3B00AF560AD0FD40703591F2007523CE415D9D1FE76AEAA81365E8772A3
-76C140AED2FB22B009DBCFC93C74679FF1E9285B992C54F02E5AF8BE3EB59049
-870622F905C44321B6E04A3D2DF2EB034588C139AEC0F63A86AA5F2DA4E58FA9
-CED1ED03EB57283B2717995BD2AA4C8CAA3F6F9BC53BEFC28CD4A22E66B65E3D
-D4350CDC01E3C4AB499521F5019DDBA9BF5017E0A16E1A9245C4D053C959DF82
-10A9BD2D5EE6D458DD3978C6048D8C40A63202B7AFD55A87FF7367FE9540A792
-CB65AEB47A73AFCD2AD1D72F8A67A170CD8920995FF584839C850F9E29F324E0
-EA714E76795F5940A22C2CEAB7705C3F27D131CD953DD55FF34947EB607333A3
-FF50EB23BA60997CECB558E328ED7219AD25132210247DBD21BAECE37758136B
-54B3758CD389521CA2ABA4D5AC84D518AF62309CE4B464A02A871D9EAF114E4E
-71C4884E2808F39C42C55F5C0337CE739CFF00237B77FB29A0E463AB4E6C0A60
-C8AF1D919A82050BFC9D03693507A57F113ABA9944BCFB5D316191339F605789
-39FEE83BAA0B518BB597D2BB84C26C42B708E0D2E6BB23D1C8BA92EB9B6D29D0
-35160AA1B077308F223BB01F4A1C0911776B1794DC0D1CCB7884720070097073
-670427C487452C8D925F701FE08A63C83B8A545ABAAE387308D25C10C2689C92
-8DD203E28173DD1E185D8FB10FD5F557DF729C482377E0C46EDA3C27D7F1C2B2
-84AFA058EE3F153DDF4633EBBD1AF3A82AA0B03792379478B04085667330CC4B
-0A824CD82B7C30AF73CA72A63F10438D386EE816A23229F6FB56244DB81730CE
-EB0020FDA14AEF63C1F435EF0534F894E0BD46E5D027F49B83086412F011316F
-D415B3DA8C5F9343C17F24AEDF062FE3E3E7E9DDD52B4033DF0C2BF1D24B7A0C
-338BBAE6551EE4A393CA2B7C1672C53AE5F95D11C2E41EC4C578F67CEC69B7AE
-B7DF4A0A9F3D5EE70D4042554F820483E9F17F7F09780E486B3C4D84B6874AD1
-D33B1B08A398C8DBF03A280AD69234F6B282BDD0092424F66F54B982F6CABF51
-E92962EA8A6FAC931FB0867964FC6170E597A4FA80CD3DC73BC48384E17D0F64
-3AE4B59879B97353ADE232E5CE6165079D091CB30EA8D9BFD710EA7DA0A26F9A
-1E48990959978DF5424EE13E48B4110C97BB0BCED0292F0AEFB3D7389B2C1940
-FF933DBC8D06B27F1D5E468B2A516C21B95F476402B1049FA057C819AA8AB444
-092C013EACE3DF02DEDF0FE7741B87D41DEEF6E28972D82C279237AA183AB0FD
-5840EA184430273F29E9141DA210DA2B40F76D47AE25CF31E693ED04F65C1D73
-219E44216DD709887D96F7C0AD501E031738E83E41D810B0C76792DB933C2A4B
-2611C3CF12D4EC6EC3BC5A873AA18C4E37A9B0B878C4DDBB753A4B5D6634EE35
-D51EDC4AFB1BFDCEAD07F6EBF23937F8225D82ADAFD68D21A1879EF8E906FE7D
-10607C103751D5197AF61C6318AA4F1FB712CFD3D801D4F470615E0E108F795D
-38316975C6BA07F83512B8AEFCB5D568F5B2BE3063C16DA807EBEA6B633D29FA
-BDD2C53A730B7E610D08EF1471F38D51B86D512F3168116E6A22B5E0E6A7B6F5
-32AEB9619FB938142468D74230D4C371F9C5B7FB323F81219FF880DADE927BE0
-61CA572FEBC1DEBA5CFD7D9F621BB9EC9D07D21AB7082A0E325C4FC1F28F079B
-77F358FDCD2CD544C3F3F158AE0138A759BEC398B77668B49E791CDCD067DCE2
-6B52C1EEC694273E885ECC7A80483AA1DCF76A4F08C3F76F96F289E2BD77D44D
-7643F3B716A5B7478E440091A492CAE6810FED1DEA6A7436AB01F807A4AF1573
-F7B53934F0F43EE4772DAF37BF555A779F3CCFCD302D767D76A522AF472E19B8
-FDA4D7D235B112D7516D9BCF7CABB231C8E144D7FAF017BA9E40BFA00B6AC8C4
-76346C06E990DF89A6984F87DB7E009E18FADC72674B6BF0C1841225399AD1B5
-239C7D1716CCC83D336FD600D69CBFB73853B692E9AD090957B625B62FD46DF1
-7586AA4160817D445DEF4B5934B7CFFEEA9263F9666652AEA45830D2CC122AB9
-777EF6CCF7C78BAE5F5CFE747A4F24B2EC4A90A66773F14F1EEB76AF3CB52A14
-F4AE221E55DE9508EACEAAC84D38662F885FBE11DDA797111ABA33BD4252B029
-9B8B9D93C0B761C4B4AAB4AE8201180DF4C2FC3FF6962752551F459116B797CA
-F085D987848AE3D92AA3EE9598D182DA5487EBC5B156A53008E66EF492C8AE5D
-A0D75EF8E324F8195EC8D5A10AD5765BC679886F3F45CAF28D9B846AF1A6068E
-CBFD79F22BC57251072F0C66963CA6F05CAD9D088DF8DF349C8E7BF3C739330C
-E2939BA377C5723B44737026DA467AEEE225221CDD9B9D31B812C03C6AEA0179
-BC7BB15E8E5F3281BF04437D81AE128A6EE26F14B966354A2BB7B83FD6E9E922
-5A1199C94DCED377A15BCAF0EB11901568F7D15DC784B473B771E332E071991C
-D8686F5A07AD236D183C2A7E1537420FCD8982AB95929690B6C987D35BED2ABF
-7E0F18861D10FC30C79800EF47C2C67CD5999E03C2BCAA3EA01105894B3FEF94
-D1C402253F288654D08476AAB61D0F71A90A865579E54E877B023941DF7044C6
-DC1B48314216004D3EB5AB86D547E707700D68A88CD5F91A3798CC6686600DB0
-6BC097EF6F31CA809D57CB64FF7C1BC23D29B23995E593E7306672F191BB8AFB
-D0386DF6974A9A5440CE95DC6A82AD0FF6D87D89244B00136CDD155196F5C8FC
-7ABC496FC6B93D6F511A3760ADBB3C985AD889DC4D0B19EB361462C831C57A38
-B20B691D6504E4B41413F5F6C779811EAD9DCD4B5C093CC0A847070CBA26F24A
-10D0DE5BDD012F5D6C2D5ACBCA1EBADA749DAB78CC6E6C292DCAA402B4A3F9DF
-018C2253D59E51C6062B78E457EC5A2811067EAEE082AC93486AFA883557F7A3
-3E9982B04E7BEB3A80F00353CA9D918FE21C384FB9A035A3485805E0D9F61E63
-74969C3EC95910A8D35AD696A57AAC3AE554DAF2DFF0B8FE3DB2C1BFCA8776C0
-240D30513E2ADDA29BD1650709FDCDA07B5D925F7712058AC70968225CEB97C8
-987E7C523CD2C65DD2D8D92F7D08971B7346F921A496F4F164979F1385D3DEA8
-F19D0C34858B16FFA6E168C68A5EA1D3258BA3D3112328B387AA2A74171C767F
-44070A0AA7724E91623D1EF679C32374D2D3E9DEF5E9E4456656BA4EEB807F52
-991AF24C55F3683B13326E1BB696E04728EC73E5F1498564C7157189B48F6DA5
-04A3A41F4B6138464B362143D50281DF039B77F0D5EF65CA7CE1021AC046D452
-7684486FA59E2B7210E7152472796E016CD2A9895FA90BA3D2C829B8EB083F87
-C4E12B55CC3EB723C225357B87EE089EEB66E3A605347BEE111D2551E8FE24B7
-F69BCFB4C6B723B655C8A0983677FD3CF70FD85A2CA88807A3F62E9C9874664C
-E2E0DA604E4180D50CE83FA777D758B8A70D53B0C4A7C3D868D31E817F282F4E
-027217E35BC50DDFCD868538B617A7E15E93929DFA2DF4D0EDB672361DE3E265
-B087FE9468EF566DD0940237584EAE657B9009BDA4E89650960DBA366BB1DE8F
-294E18D1FEB51CA310B8317B74065EE4D421318B1D2B795FCE805A0509F4B942
-D511DFB161D8BCD8C3B48CBF1D5D83FA9D3DA6704B7ACE77492324B11358C713
-BB4B54AE83C5F7C833E1343138A53DF8F0A6A5D77AD8ED8811BF368208794E78
-4580118EA799F5E2A7F6C3A1872788AA2CE1C554CBEDE0E6501973914A28B60E
-8652374A4E09570F497DEBC7C4587FAB7EE9AFF34F3B6610B807DE79FB3C4D43
-E69054C3B888ABA6763C6E6D4B2A29F1575AC5160045D0DACECEA6F098BF1FB3
-CE1EC0F7609C1ACFA5E09250054E51AB15C6E883C6E33F3728938136E2B5B42C
-CC7FD4E6F80FE2C99E59F2BE531F92E69B3BDCB449EB547D9E21F8D2AD1CDD32
-01951D55F132622AD49B3231A27666C1E730E2DA227CDE83C6C4460FDE3EE2B9
-4B0A6C31F089A9FE7ED81134B7EF2CC9E304B9CD49DED99F796D78EC826D35FF
-111E765C3F6777F260E226DF26151860B4B712A544BA10458D9DB989B621A91B
-85226ECCD6087C168973735F021D14DD25F0391F58B9889108E9D06846ADAFD5
-56E8AFBE2D90DD7BADF2A7995112C8241829453EEABF8C1AF2C0F9DFA80FC924
-31C4223A05B839CFC5B6B7E99FC12CFF8C7C85945B5351C109DCB8D70A55B27A
-82B494203E319374EAD84CC896DB29750F0C9174529EA856099924EC662C136A
-7E640D30F3390EAF7E982F73C507FF981289721342B75F9A4FA94E315D9A6AB4
-B8A1419FAB45816B08F7F89FCBC55D64B4CD94C6C5B72EEBC223163327E6F1AF
-C4E9C288978F78932220B491DAD5A79032575B5AD855ED2C3808399B0E4C85B6
-85C1A5A450548FABF82223EE6C612FA25510627A5739D5AAAFED56133CB9C335
-403F9FBB9138567B138C934B9DED20EF98E8DA9E5D925491186A1E4D25067E42
-A706333E2030341FFA2DA7ADC856EC643FC7421153A2D6A36532FC21DB0E3DE6
-196EC6179345B5F82F4E051F6A4F9AB535E0D47EC7648FD0A6AD37DEA6233C2E
-F2D877F7797FF3D0F7F4C05EEF4D733CE11E6212D6BB9B5B93D49E4470C6743B
-C0E1CE7D3E712EDF12937AADE07637DD9A3E29DC9F50AB77A2A8073A658A447B
-750B87CC50C23830AA3E60E35B9952D7370FAA9FFAC27A711B6F3CB0E97D32D5
-1EC0346FB0DF80CCBA7A170C4378953403A60E753E53E3F84AD091FC5A18538D
-BF9E835123F20D6EE5F7F99B855086467E18AC2098B981EAC35B8A97EBC00A31
-C64DB3B1C5E6FA3AAD820FF451A2D4309FC1A5540923994FC6001F8810B4BDE5
-31D65CBDB711F766ECCE71BAF8811FC25760008485721D94C28EEE2DBCE0CFAE
-4EB166AB627A3A9E1279DEB5D5DBA64545D43C16DDB7A11D91C1FAFE50A75872
-A10F7BB7CC881B49F401CFDD8649DFE8F957B61541C8FDA471AE4D9167862AC6
-EFD74E9D7C5F18A0477757AE2F80E27C0B982F994F235F89EA3AC2098A9C6349
-E3CE99935D7F22E39E6EB9BAC2627323A95102AC8AA7A619A665C08FDE765E20
-CBB8F5B1F72996B674561139CD8ECCBADF147083695360D1FAB8372104D2BFA9
-B72ED3D69D4D4431AEE1F7B378DC87DA1DAFE262C0D32A6C284F148BEC02B7D2
-DE043C77CF438D9FADB23E00EE11CACF60B1DC9BD8D2821F65631B5852CE00C4
-74018BE22F51EACB4263ECD4BF4460797EFEBBB2D33E83C666B37EC1B9AD82AF
-A4218550D46F948D9961370B247616DAFC5F8ADEFF1D2CAE6BC313D614ECFE1B
-93D6BC69864DFDEC907C4090A148C725F83E01D304A40579858E9A2DCC9DA159
-0DB4439599D12873C2437690E77F7A09422A598E2B16553A2ACF11107E131E43
-56D78D13A421A81A6A5CEDF25D21B0D08496B5DEDA173D7C0B19002BCC2F31B3
-8718D0303D3F487FE7B1828F5944827B77061CE00E8D75BD687E78B0473DBCD9
-5D272DF3E8EB0940723CCD16B87F758D1F95D3BC0D5FAE302CA0D8D749A80CC8
-D21B12713EEF51F64BDC58CB6130C946D1F814D7D04AE6B658BE0FFA82A4CEBA
-3A7E86E7C8867DF62A2244D7F8465021420E1467E510412F6F473EDF6C87AA7B
-2015E6DAACE3EB9284C4996D045351A8D8CF6D06F2A1E34B2152CB0CD30C5AC5
-8B83B20E299942D4D42DC0F6E5D0651617275C4BA779BC7D320B49FC995DC8D4
-915ACEAFCC1B95E39F70860E23EF7CF55A48AACFA7348CE3FAB25C36D9599C42
-3F7868118A9E95B3486DD38B678ACCC0BBF47305F87120F5217480028813D7A9
-731FB2982E1EAE65BE2F6704AE181C0D2BB3337D0E2FA88FDC8BAF47458AEBDB
-0A81D010389A5FCE81F9C37E63BDEFD0E9AAF6CB04CE7A5516ED5CC4DE192349
-5508325F95174ABE64348408136102E0F5EEB91BE5B2A13D3205079F7A445AA5
-65D5071F35AE26D652B86C7ECA31FE913E87DC9D9FFC40CE93BC86296F6D335C
-1E6A830A39F379DD244CCD20FFD286CE91A4E04F10A5C33C3E36A4E00BEDA830
-E914E2C6A8F13446FC9DC349A9C497227178AF6513277A37BEBD8F61DD51CFFC
-7CD5241DE20F4A2471A154405CE41A3C884F6F55E1BF854774C92BB0178A6C93
-28ED1FF08BBBC3864D521518651C119E215A8D079FECDC9F31C589AFE2D92FC4
-3F9F0389E5C5052B2C0A18E6ADBAF12DE06B2DF2E4F37200A88F091104B9584F
-3637E1E50681390C67E2D6BE6B644BE03A6308B4CEDBB735770927C043AF2647
-A0BCBDBB0846E9B35A206CDC792EE3871448BF4E6224E0971F4C26A2494847E5
-F15045FB85976693872F5D550BAFBD39F885F97DBBF4D02F4469B0E8494EEA91
-09A4AE3850E719E106320B84399D50D8756222F0B098F700B87A062F7D7B1AED
-03BDB573153B32DE0688C23E73FBA61FB6431A882CAFF8CC564A216682913ABA
-83D1468FD6D9B3016501FEE5E4F5B885E1E755F0FD135F3597B8A02E241F0FB9
-FB0E07215D0016CE1550664A192EC6F73609077C162F22823E1132EB5E4389BA
-1CF11E43D0D90BD185506FDD712C0C0CBCC16C4343A3F6DC55CB1F1524032B8B
-1AE23ABD86A40731273455CD6F08702A5462265B2077FB73C1FCAF89E2709B33
-7B4036B69D63B55D1F2709DFFB610F135E94CB16AEE5B63D318E94CDF8D8C8B7
-9B9CBDBFBE587A94F8F0CB7236F491674D68C1335ABF7AEA140CBFFDABEA270F
-7900D4F8CF5070B675B0C09E303C176FD6883E0BB67FB8F1167837A335D2AC0C
-040583C2E5E47F6D118ACC965C35D525730971F00C306E7BDA5B1674C333F19F
-AFC3F4B365539048DFDD09758980C8EF7BA04CD80A9CA5B1989CCC48AF710C87
-BE287779CDA58C6E950B0E25DFD0CE899AF9A2BE760D9C9F1A171B550317A0E7
-46B70E3FF3DB5A48317DFAB744BA6F7BA427D855D07F1E09AFC296B452C2FB3A
-21806B5093904D11DCE9F12C5ED690FDA311DC60FCA3E4034E9D1DE1FE70F5F7
-DF5ADD47ED9233EE15BB0F58894CE3E06A07E65E1F0762D057C66582AD1F0A15
-A1C9E6B013DABCFA96A8E4273B981B4A378CA0328C1E2C7DEE5A1BB3C6CBAA56
-2A06972BBA619DB7DA5B853732E85A5291D87414C4EABCA8C3DB8877F1A97F29
-B4FCE238F571E2D2083EB8B9D001D4A047A4EC356D83717AA4B2D7CB585F2A0F
-6A86717731555BB3F615B038C1054BC1960C76DDCA88934D09FEDB57122534C2
-E1D439A4ABC7F8AA4B5153ECAB74BB0F0CB6A0688DAF206AB8679C84BF9903BB
-37594CE6FEEDE981BD4FCC99224CF2BCB6B29A06198AC50D34E1794D41C6B401
-43857B656ECF4E0219D79E7C43C0A33DC309FFDB9FBA56260265952FB50E1D8F
-4CF2B2153C76C4AE233D7568E8CECA9FAB4FA520F9C76E68FD8856D57112E2BC
-2D938ED8BCEDCE3096996E43DDDD37695EBDE0C342D657D25E05CE1A7242737F
-B9F4FCE76149696C3751D5B2DFCDC3F5837457698B6025BAB49BA8FD5E001ACD
-0DFE485477F4F476FAF8A01ABA6F45847C087613E28B39F31D20EBDBBD6493EE
-6C19ACC243F4665FD2D99F30652992BA6D51E02A7DDCBA80E7B0D65D34E0FC90
-9F72AF8CE66C094B3B65E707DD8DFD3528B122BED1DE026CB95A76A8EA2A844C
-6446F2A52AF24AC2DF52099B0A3DF6383D31C042877D862F31E909808610264D
-B102747C5F2D2926EA38CEBA64CAE9E6E0A9E27991D0DAEFE0077C38953EE185
-8CCF6B988588678944905A3E18E71855DDDE2AC47D5833752BC6478408E8DB0D
-A549EEEFA5D0D5E0BF323C7E9129C0E29972F46B3EEFE7EE4D6D083444A0FFFD
-9002D48AC000F610742079A6E4A28F8A1746BF0B3D118AE50610FF8E9C1089D3
-8FCB65114E260A20003CFBCAC6E1EAD303F266ABEB366D25BF2A7F3B441F44BB
-3E6AB8CD3C2798FE5FB33BC3D7B8DF115E60AE0E27858C0E33521EED904E8AC4
-1201AFD5C8F3B9B489D1680250A4AEFE6BE04847701902E208718A6D21F83CAE
-B051DB7D4C56AC99F9EE23EE705BD501CCE075D4D7597D1B64C3F3749344F95A
-E536CB29239744E798557E8395268C3FD4F5C5CDF452EAE377B58F07A17AB17E
-7F3298D04DE285FABEC7B75CA4D7412E48B9856AEEDC683596595AFA8D58A37D
-45917B4E05352C585BEAF6EC2EEA2FF633E808B0F2EAFA4894D8EB42D58DD478
-265AFFACFAB4940B4301BCF31698BF74FF1B3E4E8A43E2A68A7A74F061D838B3
-A94BE957BAB9947B017BCB441A28A87D12A1AE7117CC643513FA1046DC33DF0B
-A09A5F9D7938C95214AC128488AD3E61B43D2881CA864CE0B4B1B17B3CAFA5F9
-ABF681A5BE6721B716328D35AF3469C6E00F6CAC886F93BBC77A380DE9D1CB45
-F8BAF0D4432CE0561524E40C53CF245130A95D0D0CFDF20AFE2ED9E49A5718F0
-2C1278DC6D33A81ED5520B16B91F0092E2C75F9734980842B27DF50A7A363B73
-06C29D7B97995712A5F622B4378DA9CBCC56A60C4BD48E7AE0B5EEF9C00BB218
-A2C6E96BED088CE74118B3C1E626F3F4F4B6B71293CFE711746CFEAF2EE7589D
-603A3AB09489419FF46AC8C4A59AAAC6B435D3B6303CAAF50C4B07BAC9FE263B
-907AFE986A1D35499402545DC7D8277FA764CD8D1CF893685F2EE11F0B90C7B2
-E0AE125279A250F095CFB2B6A340BAA287031B5815847FDC9F49CC0C5120A82C
-39EA19E8735A4D3FC1C5886E38BAFF64DE551D50950A75B744A38E4C09767E34
-A18CBE49D5A0D71D6D3D5A95F7CAA5EA56295044A771F6B8C344860095F8DF42
-26B3E40E6EB2CBD2A3937FC9EED0A362759C5FD03DA8D9CEF08758D3D2F2ED8B
-1B78BCF1FEC970AE4DE04359DF29CFCB73C3710E103A6C0CCABE8FFA1FFBE1B3
-5FEA2043506CA42104BF74E1537FA50C615A9C7DD03C071EB816541D3A43A2FA
-292EA929CAA2E74C646E14B293E8926FEAE3F7A2F3E42CCA1830E1DC8F498486
-5C143AE443297BBD3CBD38780160A804DDA303ED6D11A1237EE1E05BCA109174
-CD2E6D530FE3DB2E123AC2F188C4C4669D67DBEFBBADC06AD133B93171B9756A
-3FA15F2C93A83A91E17E16ABAC05E1FA24EEBE30717A0E263C46E5AA4703D742
-BE9D141316B9B814E3B9D8B484900D51BFB242F9068154E5379E6AC446CB90F4
-F6038581F61F5B022B690DDA23A38B626D86D6AA3201968D0ACE21AB4B0FC411
-B140C6D525711C84035EDAB53845FA7FF99C4464ED3A8E099331E5F55F034350
-FF47B6A1F03B33A33F178B79ACA9633EEE8D3AB8B337220CD76CBC8E877CDE29
-F1B5417725FE3F86D0F6A1FBA84B9932AD363BBB89021A095F25C09CA4117B55
-97EB0F5E3E0758812DB6AD8454ABEFFAB92A69EAED5782504BEF2C5D041919C2
-A8993E1BD9CC4D811D2A155AACAEECE21412FA3DD6B3C136169C322D053D1D66
-C4D4CA5B0FD34B256E1E2787356722C1A65F74B4E91D327E0AA956B7D65C1B38
-45A8E53F483E112DAF377F14A6CF329B4D5509E9CBACF84914CCEEF14AFABB3C
-5591B1A7D81A200294DF86BBA169FAD546C1B566F61A22B093A48423130A81EB
-3C85DD03E411AC49481F286F86165B7FB35CBA33FBA71DBD29C26F5235978175
-E722A38F7D71F07CC356C310CA2E16A7E8D3BA2E11D68F761144F6929BFE8595
-3BFA867307496176CF59B55A9739F9E60683AD6C5A5C3894086BAD8644FA3677
-FB04D47F413DF63359DA7AF269EFF011B2316339745E87059DB8403670C09143
-B0A8C78DDA27B0F6E00DDE08830FB22FF8A0467F707AE5D668C8333BB1456333
-114C71A1059427270C2077D7CE0A46CA3AB2D90E00D0919A54EA5FDF7C0EDA65
-7EE6F0EEFD8E6167F0BD1EF51A8E67599A546CA4CC3BF6E2516FB44DCECF1EDF
-097CCB84AEE983298EB791FF86F46D4A6F489BB2B8D54530F7153252786E8089
-0E49B190F7DE35D671238A85F8CEDD5D5FA3AC19C6CFFCFECC063DD36DE8F0FD
-689F4BEB91F99D5A29E79C2C95E0F53A4DFF0EC21CD8BF12281C188483193EDA
-643DD2B75D4C59A1C80EA3C2135B0E0BC69825AD14C38A699F1E900D7602A774
-BD8BC43F8E64302D70EED03C1C23D0B8054D1F3CD3632FEDD35B2B020A7C32E9
-388EDEBA339A8883A0F5094B2BEA1A5E790F949B6B742DD7CDB44C4D2CA022FA
-140A64CDE947938BB6EEC375B17F0D0E34983DBA4713B96CFE92956FB9EFFB24
-FB19A2DBC3171038D939F6DFD83B47C15F5CD6C27C5D89F9680E304190CD6D2A
-BD48F57FDB707C6914C364786DF317621409AF139905193C035283598EAE247F
-77DF1A942F0DF0BAD2F07C01770ABD8E7991389669B01107F81190F5BCE7B421
-9EBBD055E4F6CF993A6A30E2E21680173F3D1CD2EDA23E5A9C1C913C12CBFC5F
-2D47D55EF31820212A36D8DC3063CB6BBED676489FCE509E27F4F2C1E4CD5650
-3935C19F3465B913142FC2C5AE1B82B82ABE136B3513F61EE49CAA651BB81E36
-0D6B5FFEC7778D3B8ACC29CC48570C4B406ADFDECEB976C915305F822C36307A
-73A8036659FF7816A96CDECA1A6EC05C224A95FADF6AEBD047A728EC0B9E9D50
-E0B0E0B84FD43E36F9E2B499807F2741DDA0F4090CDF30EA28484939DFF8A55E
-24BF813EEB0C32DBD09366AF55827A9B36155EB55656A25499C775DF429D0FD1
-5011EE720405AF88A8273575F9E67875F509876F14B858256E9C1AAC27082CC4
-012625CA090BC40BCD4D745C81F36C07EC065FBEB3218107A35DA3160F310A07
-F8807C2F45222084EB773F53D7FFAB06D4E97C2BCE586C4BE81AE50D0208406D
-8EE65905945868319C2B244E922D17ED9175D5A0111901F5E24D843D20135943
-AAF62946651B1CE7017002516437EC94BFDC15FA6214A826E98C22F80DA0ED91
-F3637629DB2CCEE08F4BA5928B2C78880C56931F027C353F106F3D76E22CBF40
-44B5D45AC93D7BD82A3D8807F98FBC39796DA996933423C4FA3F3BE7CEE54815
-02E5A2A1513B18A0A8D0C0ECC21F780E464C39D4D24E8FC608B51BCC8A4C1A20
-A3CC376541C63216AEF3D8AE08379E53B1C66890A8AD5FAFDE8093C73A620B49
-C7CDE99DA05E8F51DD63C4E216FBBCC2921079869FF018D5DCB5075A7B902AF0
-4AB4043526BB03C345AAA4E706E5209F777D7300BC28F725B7E80DB1CA543005
-19364184E5FE1C9222DFE81F8D61B05C97D61B1A4E0A4CBE77E1772E7FD96205
-D9AC65A5B487355979C2FF754CC559006D848F562414F2C279AC4BAF06051479
-0A3F942F9DE11F29C09478AB45C94135D7F92D967E80A71D7E5E2A52F655133A
-C3D5EEDB00AB66F26919F301294E199AF67BB0F0FF7485DCE7470B7B65EA4E40
-E2C591DC9D03AB4F1782560BC04036EA7DD06FA0A91B1806791A1DAA52770296
-BF5DF0714AAEDAC6E34BCE80B0D634AFF088B6680DF491BB2A61195DF3D20C38
-230C80126A3EE21CA4C7752E6E05A6BFA11009C4A15C7C95FF8D89CA71AC3573
-8F7D2F4E363B5B4CD050CC5F6ADE7131D2143715DDF9FE5A1C5D482D11416E69
-8375AB7F2252F588E20F87C86A70C3B58A243306296C5AE7CDFB62C401B84F6A
-85EA9ADDEBE3F5A7A924CD4C68624BCDA20ACD64C244C0F7D0DF74A248FF44F7
-A9743572185FDEDB07724A0DC04CFDFE1CED92C8B15CC872582333ECDDEC1DC8
-343F07B0F06DCFCAD7C93F23B5D80AF37C8AC6349F6BF0F945D1A60C13B8D858
-52773276E3E89A39AD96D26A4367DC408D8CCB8436AE5DF59067C37BFF63425C
-2067E441F6C69F3E4229C469CB3563F2642CC641F277EE6BC43A67E4553063D2
-6D1B92908436E8A74D994B54F09D242B045E19F8FA037091660B1D35B8D17FEC
-DA39961845A1589F37CDC12F352DCFE1BF4FD20A4ADB8881F8402732063F6CAD
-81DEF02449F18B6F94E8DFB751035FADE5C5FA4EA1BD6B2BEB40758A004A77D1
-724204CD349DA3F5067098149AE67CED8E206D1976FDC78646CA50C9CE13BA3C
-3AEAFF566001DAE9CC9701357B341BEF429481D8CC9DC8BD49A72B8AA2811D0C
-D6B028FC73B061AC59A8868829E60FEABC8FAC72EF32D14C291571E99F20A92F
-8CC37A8CB83B39459FF71E1ECDAC8D0D15D1BB19BBA9B70E69E9522CF1C645F8
-B0B1BAC2F9941BBEA4B9B802E21715436227079574CBDFBA313BEA7FFF1452DE
-7DD0134D440AF050E753AE094D482D385E7B865F5D39DE31946D30C92113D2C2
-2FC862941D6E30C49E949E68732447CA6892E676A226054A91B81DAB0C361237
-8183D4E177FF3584213A43083B368F4AADF30C391E6DD2DD2B4633A0A663E574
-7FE3551E28F5E31378B5804F1AC52D90CFF9E66FC94D91C889E2D809D265D8EE
-5F800054C40EEE222ED014BA4E18655CC4C05F749AB1874238C7CE4E1D15BF0A
-0B93D8A49F036F365DA3D1C58EAF8462DB98B420DA267B342592E5D9B4FBBAFC
-9F75F67A2F4237BA0C306C0D5C9925246FA5AA9ABFC110CF65941A866A2C389D
-3A5C9AE18187940B773F2FA95EA42E8ACB517B27B24B4894C8D390AE0DF1BF9D
-31378AC13658E6E04FAF871B0C4DB11BBB40C19D6D24BC60B5C073CB1200A303
-1908C6BA595B44
-0000000000000000000000000000000000000000000000000000000000000000
-0000000000000000000000000000000000000000000000000000000000000000
-0000000000000000000000000000000000000000000000000000000000000000
-0000000000000000000000000000000000000000000000000000000000000000
-0000000000000000000000000000000000000000000000000000000000000000
-0000000000000000000000000000000000000000000000000000000000000000
-0000000000000000000000000000000000000000000000000000000000000000
-0000000000000000000000000000000000000000000000000000000000000000
-cleartomark
-%%EndFont
-%%BeginFont: CMBX10
-%!PS-AdobeFont-1.1: CMBX10 1.00B
-%%CreationDate: 1992 Feb 19 19:54:06
-% Copyright (C) 1997 American Mathematical Society. All Rights Reserved.
-11 dict begin
-/FontInfo 7 dict dup begin
-/version (1.00B) readonly def
-/Notice (Copyright (C) 1997 American Mathematical Society. All Rights Reserved) readonly def
-/FullName (CMBX10) readonly def
-/FamilyName (Computer Modern) readonly def
-/Weight (Bold) readonly def
-/ItalicAngle 0 def
-/isFixedPitch false def
-end readonly def
-/FontName /CMBX10 def
-/PaintType 0 def
-/FontType 1 def
-/FontMatrix [0.001 0 0 0.001 0 0] readonly def
-/Encoding 256 array
-0 1 255 {1 index exch /.notdef put} for
-dup 44 /comma put
-dup 45 /hyphen put
-dup 46 /period put
-dup 48 /zero put
-dup 49 /one put
-dup 50 /two put
-dup 51 /three put
-dup 52 /four put
-dup 53 /five put
-dup 54 /six put
-dup 55 /seven put
-dup 56 /eight put
-dup 57 /nine put
-dup 65 /A put
-dup 66 /B put
-dup 67 /C put
-dup 68 /D put
-dup 69 /E put
-dup 70 /F put
-dup 71 /G put
-dup 72 /H put
-dup 73 /I put
-dup 75 /K put
-dup 76 /L put
-dup 77 /M put
-dup 78 /N put
-dup 80 /P put
-dup 81 /Q put
-dup 82 /R put
-dup 83 /S put
-dup 84 /T put
-dup 85 /U put
-dup 86 /V put
-dup 90 /Z put
-dup 97 /a put
-dup 98 /b put
-dup 99 /c put
-dup 100 /d put
-dup 101 /e put
-dup 102 /f put
-dup 103 /g put
-dup 104 /h put
-dup 105 /i put
-dup 107 /k put
-dup 108 /l put
-dup 109 /m put
-dup 110 /n put
-dup 111 /o put
-dup 112 /p put
-dup 114 /r put
-dup 115 /s put
-dup 116 /t put
-dup 117 /u put
-dup 118 /v put
-dup 119 /w put
-dup 120 /x put
-dup 121 /y put
-dup 122 /z put
-readonly def
-/FontBBox{-301 -250 1164 946}readonly def
-currentdict end
-currentfile eexec
-D9D66F633B846A97B686A97E45A3D0AA052A014267B7904EB3C0D3BD0B83D891
-016CA6CA4B712ADEB258FAAB9A130EE605E61F77FC1B738ABC7C51CD46EF8171
-9098D5FEE67660E69A7AB91B58F29A4D79E57022F783EB0FBBB6D4F4EC35014F
-D2DECBA99459A4C59DF0C6EBA150284454E707DC2100C15B76B4C19B84363758
-469A6C558785B226332152109871A9883487DD7710949204DDCF837E6A8708B8
-2BDBF16FBC7512FAA308A093FE5F00F963068B8B731A88D7740B0DDAED1B3F82
-7DB9DFB4372D3935C286E39EE7AC9FB6A9B5CE4D2FAE1BC0E55AE02BFC464378
-77B9F65C23E3BAB41EFAE344DDC9AB1B3CCBC0618290D83DC756F9D5BEFECB18
-2DB0E39997F264D408BD076F65A50E7E94C9C88D849AB2E92005CFA316ACCD91
-FF524AAD7262B10351C50EBAD08FB4CD55D2E369F6E836C82C591606E1E5C73F
-DE3FA3CAD272C67C6CBF43B66FE4B8677DAFEEA19288428D07FEB1F4001BAA68
-7AAD6DDBE432714E799CFA49D8A1A128F32E8B280524BC8041F1E64ECE4053C4
-9F0AEC699A75B827002E9F95826DB3F643338F858011008E338A899020962176
-CF66A62E3AEF046D91C88C87DEB03CE6CCDF4FB651990F0E86D17409F121773D
-6877DF0085DFB269A3C07AA6660419BD0F0EF3C53DA2318BA1860AB34E28BAC6
-E82DDB1C43E5203AC9DF9277098F2E42C0F7BD03C6D90B629DE97730245B8E8E
-8903B9225098079C55A37E4E59AE2A9E36B6349FA2C09BB1F5F4433E4EEFC75E
-3F9830EB085E7E6FBE2666AC5A398C2DF228062ACF9FCA5656390A15837C4A99
-EC3740D873CFEF2E248B44CA134693A782594DD0692B4DBF1F16C4CDECA692C4
-0E44FDBEF704101118BC53575BF22731E7F7717934AD715AC33B5D3679B784C9
-4046E6CD3C0AD80ED1F65626B14E33CFDA6EB2825DC444FA6209615BC08173FF
-1805BDFCCA4B11F50D6BD483FD8639F9E8D0245B463D65A0F12C26C8A8EE2910
-757696C3F13144D8EA5649816AAD61A949C3A723ABB585990593F20A35CD6B7E
-0FA0AD8551CEE41F61924DC36A464A10A1B14C33FAFB04862E30C66C1BC55665
-6D07D93B8C0D596E109EE2B1AAB479F7FAA35279ADB468A624BE26D527BFF5ED
-E067598E1B8B781EB59569E3D0D54D8EFAE0F3EDE26279776ABA15341E42E636
-6E02817082BE6FE0B04249A4840C11F95F8ADEFF72173E9A5F2AB2F62C427E5B
-DC010E18641EAC906A5EF0F9BC2108062134A7F10956219C5847C0D82F0E8663
-12D963E012DF0DD899911EC5D8096F80B49CA3444CF1294FBFAB57DFACC9D01C
-46F3BA2F3D1C14EC30CBF83E5729F1C074D4F1665405C9AAFADB8BE41EEE43AA
-16966E2C0CCC853C4C09F245ABFD4603C4AA55EADC0A59AA6E9F5895FAF3D3FA
-83EDC6E2540417530AE7DDA8EF33DEB81444316FB3F93EF944D9FB06745BACE4
-848398BEB747E58310BBA39C64E341185C82CB77E9D4439EC15BEFF1335F22F8
-F036517C436225F4125ED67ACA7A84230D4E2B6CA713FD6B3CA54BEB540D4604
-D58A8335BC20052440C4903786FE3E335E331CCE36A13F05F71126F680077AAD
-ECAE10CB7C057C2D55F384723D58EF3AAE83E9E0B39D6A522667CC5B3257DAFA
-AC1C3C981B9415967F7F4DECD492A52D35BDFF8A83E40438B3B35576A12BE3AD
-BAB149D495329FFE2ED1F3587EB4BF6B7C1209F279EC564EB9E63BE5CD767D04
-E2D4193954C813AC49CEB1E84CE72CCAEEC6FEE3C2E374A2F9BDAA5DB3CE37C1
-09585F829065A21C7A4F51EF1ABCE3E576FC6AD6BA4FD4583860DB2865177411
-A3BD996FB749D5EB4C503C7CA2D05701B6A4CB7EB81116532ABA80FD024C93FB
-2F64DBD6B5AC9DB5361326C148ED9F5DA2B712B8AF9A3FFE6A603B11969D3C95
-DB1A817CAB8C445CA24F1F7D6633D4EC54A3CCC7EDBA2453DDB389C6A77C199B
-F2A6F7DF0D5B8BBD40BB5B5B79B339E216DC091CE6C8C6F52414CE9479817B5A
-719711AD80B545A47D4119D363B0AB38167648FE10D77380007B41AEB7278609
-9E1698ED5180568011401A64784F19610298DBB1EB1FD9E60EE5FA79EB0CD328
-5646912949915FAE50258417EB7EAA3117838C020A6F50280BA7A2FD240E5FE5
-C96CC8014006BDE686BDAF094149DAF305BCFDD19C10C508E644D0B153F33AC2
-DC02E87E22EDFCAE0CBDD9C92D9FBBD0570EDDD8A90B0393B608CDBB43318DF2
-1DC3C429F670DFB19AAD421304BACF5044D989BCAECB8AF16D38DAAE54270D94
-048A813B56025D1B36B61F15A3F0EEB9DCDFAE3D0BD0527016D1A0A97C99EDB3
-FADC694C5FF0B09DB190A94207C45390BF815FCDADDE0998495FC60B49B66DE8
-D0AFDD2AB60D7A00A2D1EE340263BFEAB4C75EB7C1C8DCFAFB3ED411F44E0041
-98E4221454EB7DCB07DCC3FDBC30EAF5F568B21048F325F95AB5F5B11C33DADC
-A31A2CD474FB45DD38FE8DA8ACD5916260000C47C5B55E39FB3A468DA49B9BC2
-D5B699B1158F4693FBC314E7CE38984DA973A10AEB2599B9ED306E8DAAA64CB0
-6EFD691BF97D11F132914B9A9C7F07E48A48E44CB9074B7E849CCFB180D831C7
-44F0DE5448C2617D0AC9E0DC5DDCEC6A826BFAE3868112C2C8B5CE3883EDB96A
-311FFB45AE24E121F147CB6AAC217E5044E01F53D03F07A7CE6D15841A902119
-B337274497F7E064724F0DB92AD6442393E4D67B4758249035E23CC1F87FAE4D
-4700D7E7D99897A6890B2D67CDB5D08FF4E34702EBD5FA852001BD2E16E51AE1
-0BE32CB723B636DEA87054584209AD287B990E0CFD1CABB7432BB44FABFE9E13
-B8BC0F48D4F3C431EAEE832EC4EB20A1A8C48830A459E0C1E7CBC469FAF57900
-CB7E5D026A84DBEDA018F49AA3FED849BA7E35AFA2EA21A0E5068EA07800689A
-9DD31ACAC0F25E9CB64AF2F413DBFDA4075AE3BE74D3A48BB3247262019B5AC0
-2E9CA4CCA095E4367D923879D7F22F1BD73CC246382B26F38CB4C0E01084EED0
-BD63DC4358E1B34094ACF9F842171AAE95C230DC0D8BD0256B327F31B5B5FDF8
-1CF8FAD8ED8952A3793CFEE78647558A1318D0435E61D4D31B151E40A8A8C21C
-50CA74642E5386B7DC26802BC33D5EFFB7A311353982E2C0A24C04949220CEC9
-87213B37007E37A56833B7FDED1938580BA31C9E1CC14F6E0CB7B79E68B6144E
-4CC26E402357D3398FB44A8B85AD4705A8F7458B8ABC858A48B99F096E7DC4C0
-061D840BE9AAFEC41F815EB5E7F7A0A246CF50466C45750401E93DE7A89D31BB
-D7B556509C9542D1E5CF22D67BB13755AAC2BC6CE944DBC45557106CF32A9764
-97D054BF00670758A61E087D473CC524C7ACD6ECA2AA64405B05D590B318F7BC
-DC9D3F6B08A5A8B30C1D7B31946693338C330864BA25CD7B8AE3226F49373229
-59A694E48E4098082F99A4299C735734DC3DA8E6878649398A6B8CD636568B03
-A6A24E9FD1F23066FA451C5D289A9EA011A098CFF3D568C74B8330A234D03F7E
-F3348FCAB03AF8E29FD3CE9DCAB0043825245EB21FF2E0917E9321F68AECB3EF
-221420C81E43924DE248E1ABFA4095BD6740506FF5BC70530FED3CE90DD75CDF
-B6F597426B831723D08864B88F3581A48596EFC175F6E84047729BCD7A004CE6
-62F3F0B3F4CE2442715B0FA9D1D0CC410A127E476B7758D015E1D88D7E64D08D
-F326CA9CA91F575A2F64E581DC50DB66DBEB7FE6079667D96E1085D0561DFD22
-CB206070A5CEC8A833B2B57B899893A1061E9295DDFE3E7905F3D3CDCF87C71B
-E2F7186CA7A9CEE9C73CC1667D5EEF899F888C406D2B3D80AB71ABF0F11DFDE0
-AE74B374E403242022B1610E407DDF22AB2AF3F106E2B5D260A160687427BE6E
-2281649365FC57510A334E81B29F04A669A99070822AFB06B720EE082EA551B0
-EEF64218C09E7BEB8029458345C69563D5ACF180E655859F305B86517C7DC9B5
-3EC3C9494F96793CCCE2A77F9102086B1FA8512CCD08D2F1FC3BC52358E263FA
-0488BF7B099C997ADEEDB8DBDBC6CF729DCF517B2F5FE77BC02A19A5BF822B73
-DAEAB9E69CD901BE2D38946D93E090499D4DA23ED8341C123C2E009C7FEFAC81
-DEBE8ED1067CC23E6DF0B22EED50DCD9247037866C64FB7D19F7E3C26CF66251
-98354074D03BDF150890D2AB674FB30A2C475D9FBCE2F2E2985E24958C559F25
-47916841A3283943F3079384F0967721F6A939122726DD526D522E5EA6C54509
-648EB6B1E9B426D78652E65A23665F1F489D052BADBFF190DAC5A0CED15F41F7
-CD035E87108D6BC30CBB68FE8A7F62C1A34FFC6C61A89E38E8D78DEF555B782F
-7602659C91C59E98CF53D6B35159AD5C19989239BEFC67CF55361F5A486C788A
-2547C979CBCC73CC4E80C17A767BC4770C2DC924AACE3296E60BBF9AB6D5D6CB
-9C5298734AA73505D76793F6EA7D41B994EFB898E26FA096BE34E6C3B1D57AF7
-FC66957CF44F93BC8706B344BF067575480797ED6531E7A68FFCB22EFFD0C7E5
-A7DB521AC0B0EA82FE89B9B4367BD59136AEE5534A6D4C7E48550098EB8CC83C
-720FA116E904A88B9C994BE2D548DB1645388EF86AF28C6518B37B77B2EBC2CB
-D81FE678E935E383F31F335E0BCD906A08C2A5A1AF13F1FE0CC95D2EDDA4B7B9
-4F09E214C5CA50D246D76AD58106A3D7046504F189AC7D53C0A5B32A5498460F
-F77C98E78CABCCAEBCE784983760885D2468FBA2D14CD6ECB4C796BF4BCE0765
-EF41B4133013572FBC3C3234CC9327AD68982871CBFFEB8AD9876E2F103D39F2
-A221E09642D6AFBE7DCEE2DF7B1FCB8A394632EE637D8B86575321AEFBA829B8
-CE3CC20B2A82939823DF3CE3AB759D65B054E16991BAB9C7A4F4FB6ADCFA8427
-5AB50B35BAD0AFECD0A15F032A14662F6ED447F72D020CC4F1A6F92AAC89DC80
-A165533981704FC17384149B0F5B66F4FA351FFBD0C394AA48E54925B02ED9B6
-6F779EBF303E2B90BED52E133FF7B6ADD2AF38090BF8C5C7608DED5655A8E237
-35FD8993275AB841634C4DD89EA465E558F4605E565E17C93C929D9B03A5C15F
-31EA911246830AF8473A0093E7DD4529C3B9FD67FE533D0D2BB166D698A0F2C0
-87B4C9AA3D0DD497423A0C333F301313243646D763DF103632131C6AE33C1D0E
-BFE8AED5B873DC9A7045FA84AEB505743F6DCC490C33B7A0FF9167673E3E2C7E
-E6DDC3B9D26CFC46D6A6F070AE8635C0F02A5BE349865C910E2F0B4D6EF59E63
-893FAABF7372CFDCEFB6C01719FF2CE449ABB6E1AF4FC23257585CCDE24C6D43
-43147BD5355259BE69F24346B92C6B4FDF6BFF195C1F9977BE0FC976FC58CA40
-95CF70FD29F05EE0502C9C576DEFE0378595398CBF23D8871F9711FFDB708BF6
-4F423135AD1E9371CF2226B7632DCC139C17110C15C437531CEC97C1D4718B11
-A6A9C738E691418A38B50FD90747D1E87D0AB9783CF51D61827AE979ADC676EE
-1D32A2E9308EAEEB49C98D6D0D050880890CAC2D13A3C7E62B8839B26B6A858C
-42C0CCB1D5B86AA3CDDBCD5AA051918F47A73CF54664B6B17BBD7C9E365904A9
-4706FC9917434FA7C8EB9A1D69A3254976580A457951ED607EA61873A187F3B4
-D9111D6AF7DF77D113F3A4590F32C9F0EE14C6C22DA0542321739E90EE6421FF
-EB48F3E7157BE658CC74B449D83EC9F6B831B9E832D7C3E829E4C02B8728BED6
-3DA37FEBAA9148DA0D34DD35168E09172479F98BD579D357162326F31C8F3C6B
-9FE1ECCB3576E585CC939B18D45F87DA789E784E47E09A0094BDCB0264898613
-A75F6D7C99092AC3C0CC9408BA32233B251746E0C5A2438014687988EAC638A5
-E446D177C56618F6D17511A7F6A343E00F62C9EF1EB0E6BFB5A282DBEA46C5DB
-6029381EA124707443B5E152A806ECFC390F6348DB29AC6855D312FB08DE2E30
-FCE5F18A36467A38ABB3B421B954285DF5248031DE0708F7123ED63E36D8085F
-88BB3CF17888EB95E2D5D564A46FBFDE518E5E44FA14877BBEF3716F1523740B
-BB7D3D216D8E5DE5F7BFF55EAE18DBB3277AD640755AADCFDEBB3AC048874A94
-433A1201A729938091B16E6CC52C52B27D1E82274848EEB667028A92089860DD
-64881D8714CE74D51AC155227C1547D4698F1F856A69032FD95F31523B3D4D13
-11FB3DA58D4C8B1D052CEAAAA844EC73F9D2E60025BC2717EFC5962BF63696B6
-D09E2E24E4E3AE152D15C0C8A080DC00D4BB60A3CC26DDEFD57F578B5AA8131B
-853ADCBBE6FDAD6A8F6F7F1FED88317A98534875C7A7C97DF020D938D1712433
-01EF4D3C9D9D840A3CD02EFBAC10F00469D56BC1AAC506E694EEEA99EC5E49F7
-FE2E26BE95127764D6B6263E86B5FFF4325B73018E00C9C3531FD38BE368A476
-BE362270E1109EC79B5434BCC545504D41FC116F4DB89751CD8E1B0F22126951
-300890D49A5C6EB5C84F2C51FFD3CFFEC8509BDF002006BCFA0A08F40C618D70
-5E42A43AA625028AAB0C05E81644ACED42AFAFCCC0E0C5D754BB7E533B8C2F1D
-CB4F9DCC4F7D301C22A9434EC019A5A978A40D378A22818322CF31B06D624223
-D4759BD350CA8ABCDBBC3BDF0F1FD6A8E5C177EDBA5829BD86813BFE5856EDBE
-BFE78214A512B97FA15881CB1012E5B86CB07A7A273F81E61B6179EA567C906D
-2CC03D229F7BB1C4F5E7C803590413F7F8DE8502718926F66EC8B4252B5C8FE6
-2B4AE5C14794AFFDBCE4400719BC1CDD050FE8EA5B5EE4AA06406620E5DCE9C7
-D4EE82CDBBD6B829D5B8BA4C787EC7045A7E05F600955BE9356F01E1511E343B
-9346B263B49482543258A3139150D644C8B975008A62FC5CEEAB90904AB820C5
-8B5B5437EE0EC8DD71B6768BC72627E05F82AD6A395A935BD1CCFA34B1C0ED18
-941C0164D4C3BAECA3295449BBE65900D185519624C8DCE48191815BFB927B6E
-C50CCB5A4F35777D1BB3D8F01B4ACF1CCB4F5916CA1BB7BF001E414BB60E1A15
-C2664F93D8628EF59913D3B2D5528FC4F23505A451ADC1E02A788049CF44D225
-6CE3824A0229EFF3B9B2AFF95BE8D6A9D6A9B4D05E1A0C425A49E54926A46D1C
-BDC325AF7CE0B1490BEB2D23B8696E1E7991B7E1CF5E84F77F9C4D3853519827
-2169CF1715E0C1CA3A4E4463062B14B9638E38CD6A2C5D7459F426870B8BD0A0
-7F5F6250078C1304A556FF24C9C4D01933597B97A6A295101DB0D57449E62BF8
-6B3CE19C1045D3351FFA33EF48555DD5C7617AE0A125B5486EA1A472115C99AC
-37988DD49DA7A7729779154C9F93776216AD00537F72820420B0270EAACED438
-DC514D6A9FF7C9113540202E2AF3AD2426C05A93ACB0BD8EB3B3031C9FCEBC76
-4675F5AC45D20A80FF47FA956B5965F8BD2BEEF69B9550B66CD0EE5D3DF3F924
-11D1B8142F0D4F4267E13065C64DCF9D49E8126FD714F98F1EF13BFCDAC0A61A
-3E38EDF2389A3977C637F070E0234391AF530B6A2F86B029243D2033DA7930AE
-20ACD871EDA7C0DF784344291DE5FE19AAB9ADEBA9C44725D7DCC251143ED469
-CD58472BD2709798DFB18667FCB6FDF85E380722DBF296DBEAD94123F8591A57
-63F043111A6AAA22289C584736584A97B3B13EDD492893B68A7FF59D370ACFF1
-A7CEA4FDF248AA152447892D1CB8618B27FE1D8BB62857A7CDAAB029CA014085
-C894C6DB3B426D5DEEC4F925F158B23DA69E2197827454D8152521DB43253899
-7F98C2DC5D077AD6EEEF23E45694952B34B5EE2F1B344A2C0EF7526540BA57AE
-FA340F67FBD39A371A3EFDE6826DDC2B362B2B75C47DB61F9127239D0276FB76
-52E026477E161C4269D0B1522E7B287F0FEA328AE93946AB92F48FB4F8A298C9
-FE97974176F463E9F84D4396F15C0A6346BB2994623C015B6D44A63F918EDBF8
-4BECF7185A599AE11989D4533FC81F550F481C71127AB9FA1D7E759A2921AFB8
-2DE068616A97D747AC375F64F5A050AB4CDCCA07F5109B65B0118919725101D7
-6EAFEC140B144DB745A24A8A43DB5C97D1219EC9B5C5ED39A37A7E2B040838E5
-8129B0CAC25F4C5F7475E1A38785D483294C1195AA4137566BA3F0843EC2E832
-7EAE710A369C404DA748C57283603BC6916FE3077516CBD1803E78FCBFA0E6A7
-111C02242EB154EC2D58942FB0376A494444682C6615907CCC521F94297CD468
-EAD7BDED52401701EE9FB6198626A1B2E4EF7896C2350BC80DFE5A9650BD96E4
-AB81DDE50C3E2BD23422DDB936706551029F06E403F47D5C8D16A0D7D4A902C0
-A0FA8C04CF254326F5BDF7509DB78B03BD91333EBD1012A062ED0A61D043276D
-AF83C1E0CDF23CBF77E5F478523FA87687A001B2EEAF4D3DED0E09BD3E510FF8
-43782C9283FCB3FBF1A93DA3E7130C93D35A1EEFDB85C136D6CC2A3F06B682D8
-41780381BD1224FA8CC72152E24E63607D9FC70EEBE1189E61798999E8439B54
-DE1E57E1B76CC863AA17123BBEFCC4B6A991FBCC890921B4DCC39C412399EF26
-6B1695E30114DF63C07CF333AE99A5EB2D81EBFEEFD0DF7DC0E2B9884A1C60A2
-52A2FA420BDC6050E976B60A34DABC5D192285D293C83FD411CBFC1EF8F10354
-23BA67C7E0DC286AE224102BC6E6D9742C13F0893EF5C887F93A4D0DF3D96432
-A57413D6BCBDA7B19E04C50CB2D37A45A250C70D5FC213594D1B616B67B0C69C
-518AF42387230944EBD16B36D7A21F52FBAC6104BCE7C2C88FEF155E28E7FA85
-006CDECB76406E51F3EC50A9C5C04C7A9222E930652D50C26326BB0155A6BB75
-3BD7D445623895A94AE1A6DDA1AD1F7B6906072267DB6872500EF3BE88996A23
-E3359765C00659CAE1BE9FE17D3B45BE663BE73D1C95B5237896528C3047D413
-24C70F8680D659F27E5155315656070A8BC0718472B2CE62A7716DF6B04DC67A
-A5694702731DCC948357E25E080D910D9FF698312B6C43F600F1911D53BF8E32
-2E00204DBE46F997E7EC7711C3C17B45A044431702ECB8508D976979CC98EAF1
-9A2893B59EC97A0E9C9A0A202287507EE839E3C52930EAD47A706BFE17200B8D
-20B64BDDB579A3F2F6A3A6E07128C27BA866B7C9CB6C26618333F4BAB06CC61A
-FCD823DD3B70FC0C24CEDA30C9E07CD4E24F6CDD43D139E38546EDB04ABF48A1
-4F0F474A3A4F79C4A1224AC4ABE74C15F7D437560FACCED0F68645F8AA1DDB9B
-008D86B439CE08FCE0008465057C46678EF7F236294472034AD47DD60351BFC9
-7E10B1BB0A65AA36C8FA2395BB3BCA4C399C5B50184E95950E8368A1063D42E3
-00ED60DFA28D421E5B42CA03C4D459A0C446B752AF164869D727639D7E904C69
-9C95421E0635884306A278A5FB535F14C045B19577CC7A6CCE918AEEFB110F72
-565B6F476A3B3BED91DD86DC5CCE131CA19C66BD5197D3319FC2091B400BF738
-7565094003EEBF93A294DE8C30C48CC36D384640BDB176A980ADC9999DF9D481
-2C89C91B650BCC77EB66392530EAED3A42D6630D3B2CBC9AE8172F07675F7B9A
-2FC4CD39A4B7C053E4836C6313581EE6A8A22A5E217320B402BE735B08943CC9
-59CADBDB5B1645CF62279E9EB975AD20FF621827FBDA115B48448A36C82EBE9F
-C100DFA4B05D2665F8F13DB22AB36B9306894BDE4899405F42AFDEB8DBB1644E
-0FCD20C646EB887F1868A8A9B78A1E7B7241B4EF6A8ACE40EC03C208D7D9B19D
-F795EFC3FAEA0CA268CA4BBBB1316656A7F6A00E4E17113CC6AA977036044CAA
-B1440B6C8D448AAC1621200D4F1B770154DBC5215EAB4EB75ADD6D63617DE5FF
-5608F7B64CB122A7BBA62EE36C0E310C3023EF3C769862D9F399BBF92D3C3523
-CBC57E54E8D4319545B37442FA8DDD1B025DE54D9CF5B4929EB6066450AE3E86
-AC89D7983592F6E6ADE8F1CCD4295DF459B6C7AB1FBF8A653519BA5E4227BF9A
-96577D24D7459FEE6F2073B2FDDB1FCB5ED308200DC5411E3C0EEBAFBE6DDE32
-952ED238392C6209A3CBD65187FBD3527A44C4A9FD3866B654537924B66E4DFF
-4F04A6F2E2852692553DD69D7BF4962DB501B806FC08CE52B6BD6FAC6BBC75A9
-666DBB44B12E20C2340F4D4BE3C2F5C80A61864CBA8B7F5AF871FEFD896EAD8D
-55C9DA729D06D0EEFC293BD50E88DAEE36AC9C8E92985829EC1B11193569010A
-630B20988BC5C263AB0D1F874B9B13248231BF164F2FA78AD4E6DC724C16DC1E
-AEEFFBBEFE731AA478A6990A0CF4DFCAEEAE984511396FE3FDAA3CD7D5793C7B
-06746EF588DF2DABBA4204EC0312735923B7A853B412E53FE38DEE28C3710611
-46EADD8D3795ED768C48BDEF95B3027E1F04E16422C8F95623742DA45DE0D9D9
-9F92598BCCA9FB8AB7ECA452D16FD6980A0EAE534A7647FD7F3FCAE82637FB48
-92D9EBA06CC8BED180F5B3B818450F58BBC4DD260A0B4AB17E9843DC3BE8C1E3
-32523322E68A907C4226D3DC99D536C948A039C3F857623527D5A3707DCD6957
-5C2DD266AB5A0BF5053069CE43D01A1703DA521034D46D4258952E8D39B5542D
-4E04F895255B1A684A8F53FEE90945E602092D36895D589B6E88BAE441231F75
-21B8132A1F1673A95C841CA202E3490FB00D3F145C001F1B4E283F79B0A62895
-29818F6801E3F3D8F8776014BF9630288A984F8A2F79999D6409065736F0BCB2
-0B515DE045A1FFB54B2557B75562B4A9C72B141463D390665551311008D8CD0A
-C7B9C2D42AE8A2EA40514953E518839C7EA2A51E1DF253D9942C64E049310748
-64D40F98F84ED0F16E43625DD422BDEB1DA47E48D5C74F4794BD4A7DB6BFC040
-6D6326349CE704F0E91C1C0F9C1BBD0EC2BC50A412F2D054E234011CEF11331F
-525E05D4090C80621F52EC5DD428138A17EF4A2824ABC6755B9A10AD239ACD59
-E6776B6AE9D830FCB408730D9BCD9195A8EF3BAA887598BF169132C70B5D3CE1
-343E7D45A8888ADD14E6D0905BFDFD4AEACF17B93950212C764312DFB69F9CB5
-6E4F23AEAF5E02EEF87086BEF127ED93E779DE216AE73489F5866E826A88E532
-4611B04BDD6E3C3C276A4635121406F5516D62EE17AF6E15BD57DD7C8316ECA4
-51549E62982D6E12E59585B493C6CA1DFFD500879C3BA7EF295714F15CA1E1A8
-072CC471856856B3E3CB8F521831D41B644273460227A8B70590B9AC314B9C9A
-65E627CFCC46E99303CD79FF1835E6A840DF13D76F9A0B71F9BE11061519ED85
-BF5DF978464FD80DE51FCC328F0686DDF05B9D86587649289321EEFEB8AF74C1
-345E276797123D7455932B6D3F46C7A606B903CF75A537534168783D2D9A334B
-056BD75C590D9543552CA8612FDD102B31542E81E81F0422EF4062D1940C5419
-B55123E2E54E5BF566D69523065A41DE92FE06CFFCE6A0F0E54EDEBBE1339033
-96FDD46C1B59990DFAA56B1BECCE73937859092E811253A05E66248103D1CE64
-BEC99B21F3AAC2F6F0CF14C06C3B0C6829C804040CED09D4CE0790493311762C
-AA9936FFB9F7DF9FEDFC9E816E4D53E98030C422CCD885F813C6940667D7FD8E
-DE2D685C435A67226FDD3ECF15B0007FC46C75E913A91488B843C568A055AF1B
-425EDA80F0AC3BF025DDF193594CCC8E62F942A6F0042BB5FD823768EE3B2060
-A3BB775085FBC7807B274107FAC9DB957731B11EB6015CFC1AB9027B60E28D0D
-B46FF0B8F8F307403488C8AD37F0BBB510C2B0B073591992A5DC2372426282EE
-28750022F56A30D45F274021CB2823B686A15E765F5CBA165DA8B4E2DCB49437
-B2BF3B5380C22246359A02BE2C3EAFE3CA777287DE5C83FBC4CE9DA5CA17F345
-8353AE48B86BF4010E6BBFC0B3B1103F56580F01C7CF03ABEFDCBCFA563BF0C7
-43F4E6683D81BDAAD6346F9EAA415101D8DDB79B802F576AA575BE0DD5FE62E1
-A3D8AF9168D209FC13BE69EBE4CF61B824F9C80455B467C6E95D187C97B39022
-961DAE47C56177BD2E76513A795097E0B31B1AC983A80A19238D34733E1434D3
-BBF63C7C7E73C8AB5ED730260846EB84DE770EF22B0809EC96D3A99AA866C9E8
-5997C29372CFA03C1ED63927B21248F10B0F2D1ECCB2D1B1310C55A8CCE0A077
-32E04127A86BDF6B1569C4D80A516E0410A65E1F0F21BC957C0E8C21328C79FF
-B9F91117FAD7CA85AFF138583B7202609C94DD6B7816CB8C8C43D04F1DC806D6
-2D49AB01B88BD1B8C943EBAC5972A43354C2D61D14E8CE87CFB09371299CCB10
-64F6930D74A5DE7D818D365EF6AA3DF81FCF6D7E988FA1401C7E329B3589CBC8
-8B0540CEDBEB7096BC55B8F560E8AC0F391FA54AB85085B68B27E0D83199107A
-46F71593AAD53011D7909AE2E452A0A59B56AB4D0FCCD9B750E7D620EA5C4367
-754800FC5B163B78763833A1EB138B3E49695F3970DAEBFCF8A5FD29896F476E
-17947DA59249ECC9A5C02F760D32DB541F7011D9BD8DBE2B758977F465D5EA92
-12E5C307DBD0AFA887D5EE4501369F2F6B8F02C25F59F4D63F9BB093D86300D5
-B5EA2293EFE31D504B82FE8237327DE9321F2B057C2F72E5BA89A6E29B2A8C1D
-E24E6FE8A599683B60314901B55824AE29CAEA2A6762B1C8CC43A457C0629101
-E0BB830C2197D744BA4310D0B6E911A45E7B475D8C2C7A5A8334D6195931C267
-018B771EB6D9AA645E8E9EB04B1DCB6ABEF9A7D83DEE4D38F1A3EFE21B78063E
-2D2560561A28548B3140DA05BED788EB77AD085B16034223DD1DC9709DCFE8D8
-E14D635C9791D52CFE7071DC82FCF5E2B5B8D1A5A4F030628EADFBF8733C80BF
-9E10A6144A5713487D45169D2AD2393AEDD246BEB394BE0618729C2A6EA22DC4
-81EA3796BE9955683C57DA2E47DD8436699319305ADE39A62E8B2900CB3E9EB7
-8C5EE35F9AC852193574C57D724BF12B4ACD80290EBDCE30F6A54DA883009259
-B3C769DC0782C33281814A0D46A88BC00712078242DDB7D4569331C8148E5157
-D62EE1BF42EC0F90C1F6A34D91AFF11595B2F33ECD57D283F6C34CC0DC7612B9
-A65E8C33AC8F2EE051ED07CF8DB6C1F6A077D143EFFE8F4D2359068F066DC509
-9B0FDE75BEFD64392A404011FA785CD6BCD90EA54AC660BD17D2C8FC7D0CE5CF
-4D87D96ED9291F2238E62E3550E3B51F007C0EBA6E2F1E2955A674A737C58138
-DC5820C73C59A00E0D3010D01317F3821CAFE1B41E678EB77AC0948919A9810C
-3B7D094F26142553ABCB1D6DE840606577CF082D30A9E1CB7AA3ADE3BB1DE349
-9D277F63BE2136132CB78265896E641A138CFC15AEDDF2B5A8531C2C470EEED6
-70829387D23B1038DF2D10535BBE0AE9FD4D8CB5D9986AE4E52130A7CA97FC08
-ED9427F0C9925A84AB83B6724AB7447D8490AA57F82615B3652686E3B1F23883
-716C0AF10BDFB9107A18DC7827E854ED8A1480E987C9D10E39F9F2039FC0A067
-EF11F0375E1798AFB9549837941CFEB3DB2E17394678AF83892736E12100BB63
-AB81856880F075733C685D999063F81BBF4199495B5175628B625650E10321B5
-9E0527917233F04C1CE4AA687EA11E946708E86E9DABE14855CF21BA129389FB
-F160F2BF70C59AB41C3864DCB0242104AFE412E3B5A1C882A020A3ADF3A064B3
-D89ECEE0B4588496305AD6B758F544BB0AEF9D9D0A2B3B69C7D91ABFF4083542
-12A6E4F1B42182F0004EF241A8486EC072FC04E85E6FC5B8A7410E9A2B69999C
-B22416583CAD33096C892604914B0FA077398D458A8C1233DEBCD78B0CD7A5FD
-2A5DC9D1314BAFD2C1E589419354547BBF6327B1CB8F24FE593F8993D3A3E3CA
-BDAD7B29631FCEC99A072477646511ECD58983C465319FDF1DF48C3C8D132582
-51958A804600CA6068B54BFB9AF0B8F53D31AE39A066B7E28042FA5BC8055581
-B522C20873A3648DD34A9A6C775FCD12B7C13AA07B70040C8A031760127E64C0
-A0856A5B00ABD8D9B68DB8EE50FFDE5D3D4907DD330F7F6AE85F20D288AD4125
-380D552C412FD8F5C6ADAA6EF2A3D924DEBB043C70673158D8C65365DDE09CE8
-0DA756924CF0B55A4DD7932F1734E30865A2595DE4E00519E73909B9B92D4493
-BE450930D0987BE710E13503D0EA0F7A0631BF09C3A4B59A7275D74081ADCAED
-70AE6F3AF53C04A879DAAAFFC7E3C19ADCE0983258FBE0527725333DE45A6BC0
-46C3AE80FF0B037F5C12ADE3FDA5867F584DCA5CDFD4B8487A3DC97CDD0858DC
-4C3E0B6F18B2ADA37FB14F971EEF4BDF66198E09723407F5D56B6D329ACCDDAF
-29B168AF0523475CFBB6038D9C1D4DB26B3DD7B4E88636BF9AAED057D0234D64
-0BB214378A6D063AC5E38A368FE1498BD7BD2F0EFE19EFC5E7D9ABF7C9024790
-2BC470165602FE960754B526755CAB96D6D79F6F631C99FF2F168EB7179E2AA6
-C828B55D0D776DBF087E6204BCFC806BE8501758F72331FB48A2D15473CEEF7B
-89F0E07A604336AC3C04257F7D5D6D64DED5423EE776100BFBD88C0DD8835809
-BC08109FBF0485B730B9D3A408F21B15E0811F36C96A6EECF51FB1863CE98676
-FEC14D2D78C2A55E85DE49BC0F35B8B55F350552F01AADCD34618468B83C41BE
-4A94F981C2987DB59E06B0073BE5004A9ED15F8D411224E14A105471B99BA027
-F802E30B72F524EDE3C5D4579E6B4BA65AE6ECC9D485A82F9CB2A6FE5D17C834
-F0CEFB28E1F227CF0A9986DD400B38546BA46EE3AAD43F8BE63B65E445E6973E
-604BA5BB79DFA4BEF73C0B7523F2D2A4A084CC3DB8FC067E9920D23E77BEF1A4
-C5F79686C15426E495ABED120BF9802EBE442AED181AA5AAF3C0523BB5D3FEE7
-0B9899A39B2B559A76B0ED160AAA98A167C9C72325245BBDDCBE8B0A33F2E8A9
-0EB313A36BAC2A223C801E2D4073852E4EBC94C91B319B59F322D271137D3F2C
-E8DA5C66D28E3BDADC0546FE5239CD1763C233181B302AF373AE20B024AC4C16
-D89A6283F10E1836A48AF39F264C8FE14ED329C4F1574070AA8F388B94974FFF
-4B776374920D792FFA882A828560D53AC318ED15B0DFDEE1CC32DAE6E38CFC74
-B69A1234F99B40B48AF2F52AAD962415315100E9D820883F02B9EDC0B29EF123
-4F0E31A0A9D40746997D1C710FE1D0A35096B6181136E5352D23DECE2BA5CCC9
-6C7DFE1175E20F7BC59F6E343E4A2F8030A8C8E0C4538C555D30907433370CF0
-C12B08C1424ABC5DD3FF2C113F804D7294790943FC4A4BDDF7543ED78238619E
-68B4E33753F698D2CC0E18FBD4209D3CBA57866EC422113E072D06842F3DA398
-EEC0E8B636AB88497803DA7F111D68CEFA8921BBB541EEF2B6242A1D7C989C85
-FC9EAD28A5F01EB9CFC9C14CEA4D5BB21CE33E46EE0C4F71EA624C92DE113A45
-B4EFD8D4487A360FE55106EC0341BEEA78B8ED5133617EEA63A79314965418C0
-C10D3057467BF83F6DF0CF2154478FFEDFDD2C96AA2D43501E98E63E01606569
-ECA6386C3C90A3E86F079A2EEE882D3A7C85AD3F35628EDAB6B30CA0790B24CF
-2A13CEADFD1137E4693323CE5EC95C57E441B333DA96A798A39AC22BB1985D59
-3485C4700AB90A90E87CEF9ECD3A5DAC35029BFBFB816D311CA8B5911E0A3FCB
-7B4033F0BD504A3092F3DF3EF06786C61280A1495D7D6EEC45D613192F94C043
-21E23D437A635F9C22791BC8B3A2C2DAECEDC206C8EF3CE3336F27C1453351A6
-34277B5878599660A6BEC036FF603D4596391C9D13F722E0B1BE4CCC669F50E7
-8EFF9F33B81C7E9C886D42874EB6BAABE7DEECB973EBDE83BDC273AA1AD5AA5D
-F0700DEFD901F5E193A75EF525C4BCEBEB21D6D7B01194549890957DED03A2C2
-57A8AC234E9E96190F51F936526D099C08E7260DEA82D58A6A6B9C45CA152C60
-833E7AD12CF1F5D864BAC62B61AC530BD0540F9DA2EE4CCEA22620144EDC56E2
-015F3A1B
-0000000000000000000000000000000000000000000000000000000000000000
-0000000000000000000000000000000000000000000000000000000000000000
-0000000000000000000000000000000000000000000000000000000000000000
-0000000000000000000000000000000000000000000000000000000000000000
-0000000000000000000000000000000000000000000000000000000000000000
-0000000000000000000000000000000000000000000000000000000000000000
-0000000000000000000000000000000000000000000000000000000000000000
-0000000000000000000000000000000000000000000000000000000000000000
-cleartomark
-%%EndFont
-%%BeginFont: CMTT10
-%!PS-AdobeFont-1.1: CMTT10 1.00B
-%%CreationDate: 1992 Apr 26 10:42:42
-% Copyright (C) 1997 American Mathematical Society. All Rights Reserved.
-11 dict begin
-/FontInfo 7 dict dup begin
-/version (1.00B) readonly def
-/Notice (Copyright (C) 1997 American Mathematical Society. All Rights Reserved) readonly def
-/FullName (CMTT10) readonly def
-/FamilyName (Computer Modern) readonly def
-/Weight (Medium) readonly def
-/ItalicAngle 0 def
-/isFixedPitch true def
-end readonly def
-/FontName /CMTT10 def
-/PaintType 0 def
-/FontType 1 def
-/FontMatrix [0.001 0 0 0.001 0 0] readonly def
-/Encoding 256 array
-0 1 255 {1 index exch /.notdef put} for
-dup 34 /quotedbl put
-dup 35 /numbersign put
-dup 38 /ampersand put
-dup 39 /quoteright put
-dup 40 /parenleft put
-dup 41 /parenright put
-dup 42 /asterisk put
-dup 44 /comma put
-dup 45 /hyphen put
-dup 46 /period put
-dup 47 /slash put
-dup 48 /zero put
-dup 49 /one put
-dup 50 /two put
-dup 51 /three put
-dup 52 /four put
-dup 53 /five put
-dup 54 /six put
-dup 55 /seven put
-dup 56 /eight put
-dup 57 /nine put
-dup 58 /colon put
-dup 61 /equal put
-dup 63 /question put
-dup 64 /at put
-dup 65 /A put
-dup 66 /B put
-dup 67 /C put
-dup 68 /D put
-dup 69 /E put
-dup 70 /F put
-dup 71 /G put
-dup 72 /H put
-dup 73 /I put
-dup 75 /K put
-dup 76 /L put
-dup 77 /M put
-dup 78 /N put
-dup 79 /O put
-dup 80 /P put
-dup 81 /Q put
-dup 82 /R put
-dup 83 /S put
-dup 84 /T put
-dup 85 /U put
-dup 86 /V put
-dup 87 /W put
-dup 88 /X put
-dup 90 /Z put
-dup 97 /a put
-dup 98 /b put
-dup 99 /c put
-dup 100 /d put
-dup 101 /e put
-dup 102 /f put
-dup 103 /g put
-dup 104 /h put
-dup 105 /i put
-dup 107 /k put
-dup 108 /l put
-dup 109 /m put
-dup 110 /n put
-dup 111 /o put
-dup 112 /p put
-dup 113 /q put
-dup 114 /r put
-dup 115 /s put
-dup 116 /t put
-dup 117 /u put
-dup 118 /v put
-dup 119 /w put
-dup 120 /x put
-dup 121 /y put
-dup 122 /z put
-dup 124 /bar put
-dup 126 /asciitilde put
-readonly def
-/FontBBox{-4 -235 731 800}readonly def
-currentdict end
-currentfile eexec
-D9D66F633B846A97B686A97E45A3D0AA052A014267B7904EB3C0D3BD0B83D891
-016CA6CA4B712ADEB258FAAB9A130EE605E61F77FC1B738ABC7C51CD46EF8171
-9098D5FEE67660E69A7AB91B58F29A4D79E57022F783EB0FBBB6D4F4EC35014F
-D2DECBA99459A4C59DF0C6EBA150284454E707DC2100C15B76B4C19B84363758
-469A6C558785B226332152109871A9883487DD7710949204DDCF837E6A8708B8
-2BDBF16FBC7512FAA308A093FE5F00F963068B8232429ED8B7CF6A3D879A2D19
-38DD5C4467F9DD8C5D1A2000B3A6BF2F25629BAEC199AE8BD4BA6ED9BBF7DABF
-D0E153BAB1C17900D4FCE209622ACD19E7C74C2807D0397357ED07AB460D5204
-EB3A45B7AC4D106B7303AD8348853032A745F417943F9B4FED652B835AA49727
-A8B4117AFF1D4BCE831EB510B6851796D0BE6982B76620CB3CE0C22CACDD4593
-F244C14EEC0E5A7C4AC42392F81C01BC4257FE12AF33F4BFEA9108FF11CF9714
-4DD6EC70A2C4C1E4F328A1EB25E43525FB1E16C07E28CC359DF61F426B7D41EA
-6A0C84DD63275395A503AAE908E1C82D389FD12A21E86999799E7F24A994472E
-A10EAE77096709BE0D11AAD24A30D96E15A51D720AFB3B10D2E0AC8DC1A1204B
-E8725E00D7E3A96F9978BC19377034D93D080C4391E579C34FF9FC2379CB119F
-1E5BBEA91AE20F343C6420BE1E2BD0636B04FCCC0BEE0DC2D56D66F06DB22438
-452822CBEAF03EE9EAA8398F276EC0D92A7FB978C17805DB2F4A7DFBA56FD6AF
-8670EB364F01DE8FCAFBAF657D68C3A03112915736CEABAA8BA5C0AC25288369
-5D49BD891FABEFE8699A0AE3ED85B48ACB22229E15623399C93DE7D935734ADA
-DA7A1462C111D44AD53EA35B57E5D0B5FC0B481820E43222DB8EFCD5D30E15F9
-BA304FA879392EE0BCC0E1A61E74B3A1FC3A3D170218D7244580C7AA0DC65D19
-741FA5FE6F8CBF60250ACC27454BBF0897CA4B909C83A56672958752ED4B5E79
-E18660764F155E86F09EFA9F7685F2F5027EC85A775287B30E2069DE4E4D5712
-E7D033481A53A2702BA7542C71062173039030CF28D8B9C63B5596A9B42B33E7
-D922944A38713383D3648A4AF160A3B0C8F3379BA4372BE2E7EA49AABA75AEEE
-C5DDE1D8BF68483C3D21271280ABB91D54CC819680322EAB72E1250A760BC8DC
-FF798F2ABFC4F3539392985C4CB324B00072295FC160818BB0355FDC4F12E39B
-984826450553E3D271F03D8DC2D12A92A4D32034FD16DA13B876D88C8C097384
-46D8D7E41CA1A8979F9B07EC3337E70CBBE3A377235B04C79BBBDB66CE1C1A41
-89DAB7CE91F2FC0CAF6DDAD09992D56F72299068192610EE3DE5DB7CF6366B4C
-D74F414484DCCDBA449BFAADA39D0F27574E604E31CB513B18E3821A33076151
-C2BCB6E957C77A0AECA48C587ABB5E8C7624D56B32F80BBCFDC874AAD6EA5119
-C9B06886F08CC7DE5400E0F52B07483FD4BAF26C1556CA27B259FF3DDF71131F
-DFC05D8B14C28F2073C460B5011B76D84F7917E919E50FEF563B5DEBC5CE6923
-ADB72392C98D03CD978D3FC207A52B91E267E7ED8BB4531E8BBAC113DA68765E
-E23FA502BC71CFB91E4FDCA39BDAEB7FEEC3588B1108CE4A1652B770375724A6
-508376586216289093485CDDBBE68956210B6FFF3953D097D66BA31D19CEF2A4
-35A33AE97547B81426E58F9FFECAB633C6433E86C32130665210F44F10F3A2F4
-EA31540D0BC08EA4DA2DDE3E8CAEBE52A3E8B037632B235D4ECE3CB797A5A939
-12C45C282783F675060040FFE2676A7ED903798EE3B86644EF30D3B461D4EC3A
-A1D2E95C02FF1531D93180F66A13E868C9E1FF1722FEF6C4F304921961D4A10A
-6AE943157B1B0E8871BEA71162E5246080618A96D5B23FFA8F420F2AC74BFB60
-BFA3BAC4AC3A320887D4090FA3EF7071D2E1DD5D70DB98A01B6D315271D10F2B
-3D9256D96FFE8D8BA0F4781B74490C63686397241640B08A08FBE7CC9B1FD0A8
-21CECF0F994CC97AB18411EC8745F5A6AF56010C22E73CFFCB45B82DB68E6552
-2E57A4C06B96C55031442EE1F53373C50E14657ED320D9EB3820144C7EADD2B7
-564578EE778AB577C5BAA6CB7F9884D91F1EB53F032AE4F0A8F47A7636AD0573
-00083304E10F77C0B5C7C390F436CB4C0E68CEEE4B1DECCA113BDF28F21B61C5
-432899378C52824F854212F8B53B75ACBAA50F74868CEF45E8807CF574DF2B71
-D37AF61581497D87076740A67F6023199F3ABFD651B2944306176F7AB6659154
-7AED74DE897275A2033C35108B1F9153B113B15926004A87B2E9415DC4E3FF43
-37E1690D9608655858EF65FC29E1909B2FB2EC1D611A14B3227111E903F1534F
-B37C2EB3064720BB08497C43D8C0D163A9C07E6B8574D344B27920DF3978B879
-308CED51A761149CA2ABCBCD1503985786DBFEAFF4EF1AF192A50441359290FA
-8741BD4E2536E91D7E1971394982EDD6C9E170D09105B0A41BBD869AA7FDE2E9
-A06D02BC72A3409F1CD66B21B52D234FAC72D9009F61F16ED04682A87E2A7C1F
-C9063DAD66B0C47C220D4E2C4255994BD8590F0A9B462F009704A3C86D85DAF2
-645485ECB452BD47F68274914AFF8A5FEAAC476AAFC75F08464730643E8F28D8
-4D5BBDF1E56D39998755FD1BBCC94135A8F3412EA6B6C94B3D18B74E51C5A36C
-CA4831E9467D177E74AB213DC8EFE5B29E8FCA1EEAE8A4D5D21D50BCE3BDAE08
-E1C57F839812325BD054FC65B155DE7EDEBBDC6FCB029C339B18EA157D09D9CC
-F9C5B44B947AFDE8BA8CE20CC7A2B8D46A8510A7779D80B15FA260DAC4AFB3AB
-7FDE8781B64AA420E914C0AF4740A5F4D441338D4F2FE24563C79FB1B5FDA10B
-0EF257DA2FF13CB87571CA89855424BA69B2998864B445CA79B3CC60AE0D99CF
-9BC0CC8C312560D3AF86325B7A1DDB74C4185056474FB9B4437AA0D62090A864
-5BB95C5348AC9F7E86D65596B51EAE9994C3C824874B8377F6D266B634DCE8EC
-F857336A6629D4CEBBA0CD0FC1D972DD5939364DEA16763D2B289DB24C20797C
-26606CEC9674562C06F2159E5A7D8DE25624F01D198123928B95FBA02AA3C1D8
-EDED3B6820975A8210456AD00419583338658A9F9930D1D5DF859127EEEC2163
-D3D17229362781001341285F2AD5FE5B2021EFFBE11D3BDE2A59747A9ED75ADF
-6CCA61D95CE0EE67C3E8182EE1FC4A4FE8A35F77D1D504EA09A7125CAD876ACA
-5AB639476AD272487B86E0E20E88BBCDD48D0E77B37B8BD4A9B2086AAAD0CD0C
-4839E1E126522A3F4329CDB267EA63756A38D0E24FE6546837266A1FC11BF542
-7127CA2DAB3AAC2968658C60FD90FDF456B3EFA33DE77AD676B79746927767A5
-021B15B2E434C3CB9B07E3938DEEC3E959B1F348A313E60E4BA3291AED5DA9DC
-AEEDB9EDD586AC704A197EC8BA3FB63E7B84D5E23DE51695FCE783F8C2EB941B
-BB40B846C12A4D5C965C3516D7F264A013C9184FDAEF144F7260A4354F8BB396
-525A786496A8C55E3AFD4ABD80D994FA67D0EE146E9842221B0F3C114D4613A6
-221180E57C80B5858728627FD394A2A3FA4E012966E97BD3D08FB7BF0C74DF11
-A39F4F2E946DD667A68002EC297E424D963174BE43CA301B5DB1A2F4B7DF7470
-44E4396137951563FCD59A9EFA6AF8EB446FE8EA707DD86FA8BA0A78434EF884
-CEF5B614DA335FBE9DC54648614A8ED7BADD1BBA9049BEF948432B407B9650C1
-843D083AFD085802C4105FB6474D0196026A477DBB1E7D584492199977B66E41
-24E6714BE0ED5154E3A5FBEEF3623A2B37AD27DC863927F5DBAEDC19AEB7FDA6
-ACE7B9007006B8FDDB6074731C0F378E4BDAB6554A243A6433C25165E5ACE1BA
-AAEE10F9905A6F653C7FA1805DB7900D852320A9E2CDFEA1428F1B2CBB134B1C
-741CBFF2CBEA5411BAD850EC38AC118F0AD1568F09912BF192455B49692317E0
-6AC44BE450BF34A8B92AE8089D329FD0D8522ED1FFB4127E327604BC3A74B92B
-92BDF6B3A2B768CBE73BA257610FFFC3CBBDDC3305DB15C5F441E984841FD3C8
-2EE7CF78980361E287753C10C9D8BE09152D51D684AC7934B84BF3F54A0DBCA5
-D182A0A0BE44C566FD84D5CF9606E25BB66E565A0BB044AB724A7F8A4CFC0A97
-0E1AA7EC8B71EE845AC9A85DA8F8C7573B03BA90FF8E670BE8E45D362705794E
-B3139E26D939B5C2843351AA99C2139CC336CA12AC770984240A855EA2B6077D
-2A285D524C2E7ED1BB2224E7E5CA064B9D46E163DA5CB9E2695C1CF39AE00249
-C1A885BAD2262CD530FF1235101D1B734AE28668432C218556F8D708269E7781
-49CB4A91F25533F90B082F7B029C14EC80EF9BDA8596054E5F0CF135E483F63B
-AA8C701F3813BA73C2EE6A090CA3D0D544A2ACA6D4DDA8A3DF98900945ED994D
-C30DE735AC86496439BFF9F55C3C29D0EB5887391D9E6536587860BA53426A58
-4504D571CD0423DF29D8ABFD2634272682F24B6F9D1137E2A3712505F32CAEE1
-B0B1C2C3E5AE2F21FB94A7E7322CC1D232D8BD8797AA8F95F122EC7DC4479B45
-423D85E790FF2FF25015B94FB3D16876998A425C7975BC6F7CB79FB1EFED64E5
-B9EF9CA704C9D349D7A5BC25FE8BB6455499349E51C09394B8BDEFF511792D02
-A97200DC096F62DD6EFC594F6CC10CE1C0997B9736673863EEA5027984A83E1F
-E028A9DBAC54EE9A9D14CDE884D87D7A1131E4EAAB999FCEDBF63DF533B8C4B1
-CD5BF5FD913F915D92CB13921F2BAA27E0520532EFAEE6CADC5ADDFA9639630E
-D840968C606BFD9FD465BC379F551D4D27845099A1431A8DBF88551F0A9A459F
-11824C044D8050BF0872D767A158D2172A78126878FC52AE0B916FD7FC7783BD
-4D56FE17E5CA045DF84E908A5BE8CBCE1F5EF40FC20BE8A5159BFF08B5BA5F64
-C53A14CAC4E43D5020EF632608BDD4DE3FCA54CFDC1A6BD6BEE999EBF8F6A0F5
-89AB9ACA92763B4AF8CA49A93800A706531BA591FCA03DE3C0C514AB15CB18CD
-09ADA954FD08B538492DFB03C2C640DCBB64A4D4B36D151EF86E67547F75DE87
-8689592D83DFFF32EA4B786620758E98921F1CE4D68D3A1053A8722067FED386
-9020B120CC1E6DD982014D259348FAEC050BC08B8CB891268B54B109E60BB866
-18BDAD39CC4C50A39B29387C79353016F1F07882DD9520404102A9CE5EEA2C14
-2B9E9E64014A41D2F5CAB91EAC0650D7455548F963A0A178F4CFE0B2DA5FD65A
-866DBE06EB648BB8607E71880321BF5BE133E43831C5C20B14ADA034EF68AFE1
-5011B743B96653489CE0ABF7EAF6E06BDA9D329A3812EAB2A8D66877015376A6
-7AA7FFACC3DEC390F3AAA357EF552D0F30E25C4703D38D96F50887F3BB4EC89E
-17B9EB3A3C8495E1C029F195FF36CE4FDEB622925DD42EDC91765052FA70B545
-FA5CD8F301D54AD50E2003452101FBAFA5B46828BB8CE68DB59CDC3C7044E1BC
-79252F644FC74079B5C8631CC310205764CD1D8831E2B8284F59FE7EF46F1D02
-87D15501771F6D0E2E71B139F981FA53E5DF584573B94A2ED6C04A81B2FEA834
-841C371A6B03C1BC2EB6D39421612A4F5B0608A66042DA09D68EF4ADD27062A7
-BB09C290EFEF751AFF9B24E1783705B47C2D52E0999FCD4A7531F0D6583D8DE6
-2A4AA43FE4F7C3BB86DDA92DB675721C5A19D9CE03080AB35F1E16E75CD1F012
-6DFC8661C9BE0D7CF3DBDC0767936EBE664F308ECECE8D19A165595B305824E6
-E439F6A627B751E7F57D2A72950096EFF267232752E0A915B81B24F3BE798684
-980D8F99D3F4127D28F5664A048BB74B8B1037CC8BD30DEE498BD4B759163477
-9D436A0B59212068C1FB9C2230232D1B967FDC5FCC7E42D13CE749257416E55A
-8FAA84E6FB0C3253DCC4FA801118AF3ACFC58096BE0E01A0AE0E67BA70E27D3F
-4EBA4F9229885AC8A925D9536CCF79B62FBA9D6DC857D5D2D8A6CEAC66572469
-12A0AC1CAF2462E01B4DD1674FE992BB0AA26AFDE447EEB5635BBCB92AB07623
-2ABAC3A763915417DBFCFDFECBA75A15A8686CE9F1F2CACA6BD3A9FB9A9F0915
-A41FC64FCBA7CD364472CE8299E8BB3549389B40E66B97F24ED17F9D27A6F9AA
-70405B58E78B9062CA2D42FCCE381807B07A20B8085254D2E3A6FBA4E0A02209
-452A850DFB7FD9FB717E1327A9FDA54F7DC15539B97DA1D730217EBD8F943EF2
-89432FA1DCDF94B6F81683C8661592FCC8CCA9BC7E126A6D97008FA0C58D7181
-844E5321B03C1EC01623E666260D1DA98C9F4865720131F7D14B31704F162BBA
-4B549B25D5A294933A072AC6AA6135B70F3E0A8CB64BD1FDB17543A6AC661DA8
-6D99F9C6D06EDF4472EAE0FF694F9E8640F97B2F40F9621DF92656600B14948C
-D74C4428EA0BFAC972F785885864B76D651A7DAC0B5E0A4C631B483504CF0125
-2766FE3B9AC7AA861BAD19DBBDF74F306696D1EFCD7A6B7C8AB9F7C2B34053A6
-2D517E7D8B338441BE7E46413C1AED3C1CE4C960FAA0F64F243BFBDD277156B8
-017DA4F55C9569E95210D8560FF5CF890C1CD71FCA1F60EB6B3AE882D98C5158
-74DEC0294BFA4DEB9D41A84E266069C096BA3C17F6145CCD2894C081FCB0BBCF
-0E009CA6DE642673D434738D805A69123AA289748E65AF60465106BE59F46314
-C5328BFD79220D220C910405BE52AF6D2CE2B838F4BDD93D87F29D736F5DCC31
-F2AF943C1AD452954E471D1392163EF8D8177A7FC7F12904E30E5AAEEACE294D
-BB51708183535E26F1810A77D2B70E87CC7D3CC5C117C2572188CBD55ED96FCA
-CCEEB0D9982AF0B38183EA92D0485D2B3D4791B92EE759C39C9B343086747CC3
-CB28AE8157FDDB6166F859DF19C55A8B9BCD54C7022355FD955CA9FCB2EC957E
-A5508EEFE9EC461E981C3B2294EC4B839E1E2EFB9AB5A4C23293A8B7AA983594
-752620AD96E08597EF3D41F42207D3683981A22D3C1B64376091B0EEDA7D3AFE
-E9858C9BDE56BA8A166BC2900C9A4AD4298F9EFFCF8552478AD33C371D89886C
-412DC7D3214F3F3D3C71D277ACDAE756A469FF297A66306166D2D4F8F44FBF76
-0E756B965BEB134C522F15929019894B6896B6EE33F2A38385E0551F45484A38
-69997B61EA42D81441C94C2CEBF2C28A8BCA7D001079392741AE61B841F6CE9D
-30531BB3156C6BC169567E0CCE348B7987F170CAC8937F76E3BE71ED5FF79B68
-5FD3F97DD0E8C8BD869DBE5A804B7A3B550462296ED8A19308322C11D1AAB366
-632FB28DCD7DBEC1A9461104381D0F6BBC7E8808D6FB8AB2743D32059FF3984C
-F5D0228E615AB16D34D364C224EBD23B192062F9F25242C04D720ABF965C7BB6
-5B6FA05A5FDE41211B546C51F20F876119D4957D51F8E2D62351A8E5DB276429
-0C72452FB257556823D2CCB96AD2191574929066DF307D8B8310A23EECBBB326
-FBEBDFE38FFC05D344EC4F0BE06D9CDFE71C962C3DBF936424A6F3FB7F4CB3D0
-D98897C15D196497E883845F10C8A75A1E02A4BFC6841D335695360E4D7F43F5
-5C66083FB60257A6362E558AE3563CF1B7588D09C766B6F3FD54E103978B8250
-A8C0C8205F77A530999D33CFE33299EA0AD0AA657C958A0BD660B198BD7EB40C
-3C63BD201CF1F08563DFD689DCCB0EEAA07E1FD13596CA96F25617B0B13C84FF
-667601BF5B1CDF5BC805595AF3B69A360D9787D43F99F21E5BEA78034288051B
-845BA131CE149534AF64D14944C9F87DABD39D30DC704BBCAA28DCF32FA9812E
-B381A84F1CB4743B5F1C9104EF924D6DE1C22BC011307F6A15C26079BF38DB2F
-F4FF392CCEF632A583B2E7094457ABC12B6B3410CC652A5E9C68B1B865DFD140
-F66293C0E99F2CD2245C099A2A53D090DAAE4CDF7A885B5ECD4742A036B8DF44
-C3E157DE60EB173FF479AA32CAD55A8E73642251B92A9EA5E0B4A45264B7329E
-B98785773ED292CCCCB600B00C32BD6B733D653A3EE720163028A91482657860
-61AA5CDCA3915C8503A692F544E0B36AE394AB4A6BF71826C75685559880FE86
-7B1FC44F3BE897A30F0F1DB23A4F9E9C951559EF4B119338DAEEC22B8760CC59
-A61BAF08D4492C5879D86D43E217EDD2DFE8748CD6C19630761376A32A8AC74E
-65B3121F2004E92EB80218FB1AE097644CC97507C38571450A00215EC305070B
-ECB6FB792B75E48A53E31F8C567C28E0DDE2A5BE38DCB90892AD4E9FD71E2390
-902C99885ED596EBE003D8BCBAE707B9CDDDF95AA1E1464FFD921EDF24876C1A
-7FF36ADB9CE7F184E8731540B5BF25FC4E34BF825D0B86795BA5A021507260FB
-3391788603E191DB90282535A873174CD8823EC313029A816D5B48898E4DC8E9
-13CBF7912C5D381C9282D9EE9B07EBBEB5B2EA1B166E810019551F503727CC1A
-1AECE76A7A0C3479E60BAB187E9C3BF9B0F0E12D2AFBAB68FB0CFEF7B9DCCA33
-DBDC30368BD46A43D6AC2C5755D1EAEF0DB7CF4EE87F354B4A3981069A398641
-E974B66E79B5D77107AF68BEEC4D4A5F1A75CB0CE814825D9D26F3F20C9DCAB9
-233259948A7B7F302014913813EBA57EA34953F1AE0072FEAFAE55B5FEBA93E6
-D25970E32BAA3710D22E6158099099F13A723741E390ABFAC942304AA2DD83D7
-0FB6435C748D1A1AB87F183159CC4342B9E3558306AEAF5C1164F8DAA1C1ECAC
-06D96CCC2EFA9899F97608E1983734CB79F38C6B577B54E4CDBE5315F8D774DA
-805C67930963E834D85900F51D07CA67FAA57F6D0EA7C8B64873DD427EDA7FE1
-A120F98495A3DFF6454867F2172A82D8BD1FE7D46B0686D1D624E54F3826B567
-FC67CD107234E0A9F6E12287FC915FC6792633E1C6B0E4F39B4E3DE796C2AA00
-AD25511FACDAB39BAC34579AF4E87CD614698DAEB52F9C47F2C7426D9D5B1A04
-269D3D6D380BBA5AECB04D318B6AAA2104F76B670457EC04E9F3FC16D4EC9A19
-18172AA7D14910E70889B81006860DD6B9B3B336716ACCFB09306DBF1C2FFC6C
-17DDD204E35C73D906192CC4EF969D459C3A8AFC6C44515EEBF5EA04212FEC62
-ECC3E9C371AFDFD3A5F3A311F296CEE6EA2D4E81AE88EE69D923E97866BFE134
-886519A2976D0957EB52BB3096FAC0F746E109203CE20818FFB1B6085C120917
-09706BD9760276E7AA64C9A5787E8772C80D38C48E784CB9C722F16B89D27965
-5AA592726E9C8AD7F5F57A54DEC706A53D79978B4518C27EEE1266A1C1F7626A
-A486119E2C9E7D3A56F5245C055924534CEC7A96797F700FDF9902B3E70B4781
-71506CE14C0FA292B81201FBEC7FAE0D3048B622F91A65EC0E5ACB502F6A0268
-91039348E826EDE569E12AFC9BF9C382182F31ABE21B81DB13596133C826E50A
-CF24CFAFE3ABA38D6D4243BC868C9A3C2755A91E7E76DD05478B0288E332D658
-6961A8356DE1CA50599211C0B9277DBCCBD7EFA7C9D1FBE378A551B83FD5F79C
-D52D2E8F9746135CF15B5A7186C568B73D3B1102F272840FDCDA6BCF9F9C2F39
-3A9384377ED3D1ECE1B9C24F8F9607FA08A6ECA7D705F1D00C0E45B2B10AAB48
-458B1FF4758556B05159CFC3B854B480B0F20793F5F6983B0DDCEB69F15F6672
-B8134DABA13EE161F2079F607DE8E04E6F2DB408323475F802C12BFC0B8E56EB
-9840FFB6EE2B5C9F4DBC95A4D71B565A2BE0C051EC096B957E6D0E713BE1190C
-431C5D38897AE56CB6C4141E7AB1489C7D8C83B35A6CBEC004EAB1ECDDB1556F
-4EDFE82D3301D7DF21890FAB56E3A96B59B7F65740D9C22953B72C8333EDF0D3
-B9A6CC20241A6A5D481BBC200F90081F8CB7C67712B5FFC8FBB47FF3F97E813D
-D002F3FC682F955320BE0E120AE57855800A6942DA605E3D2F2E59FB8A5DC11A
-45F43A44443E8D0B97E89193BBDC8498BE95C3608B7FCE4C43B6BE7336CA4719
-C416372E8A829A27B24CA1AA7602AFDFC69CCADF712926B3966B0C79DC67F538
-8A8C12EBCAE65F36FAB8B7684DB028E8FF0559202175E4BE01F266E68B977A59
-D12963E47B1DB2B7E54D33E8C86323307230139674E79F512FA14A31F9259CD3
-899032174316EE5E370E8699164D98DB4E726B3655E96F567F180E661F39B9CD
-653884E90D29DE14F90471E9DC330F9EFA02A0E6A7296918BE5BB333EBADDEE2
-A74DFF3145F5BE203128E803418EE9C1DF89DBA4A92EBDF94B401FDC423E2D7F
-5ED88BEC636E17C5C115B0FD061FE69DE97E4A0B2D7FCF2F6EC5B3B9A6E9A928
-F17BA6BA9AD2618560073726E2BEEA8031EBA4FE0156AEDF8A8F565C6FC259C4
-3A118F81B0AD2B787DCE58F40DF5C5941A13D116E3F726CDAA715A16D885A9FE
-4EE2E195CBDAAD731BC924D89CFB273A7385944642444FCFAB0A351CB0836E74
-2BE2C36DA5488897B2C31771899143B8780DF5B351F2C4653287B00D4940517A
-FD2A5A7F4937AE7E07EB29C02B276C662BBC798D7EDD3BD67291A2C1153A0E02
-50B1604DD6B2B0A4C9E09CF41F8176A32A448DB0573EB4F07B6CDE555FF98526
-BBBE22E9ACB3C578584344C4D76277077C8DE319538FC9509C8D3E1FC175619A
-0801B00C9997A8B315CF208960B18FB4268F69C9529F1C78F34E6D289BB8F0D0
-B89CF8741096F678F00685FBF235A4C1A8B14DCBEB1D8B0533A26A75FA1B3013
-2BF9C0110764CFF5E982272A39C7C1B44952E32DEE9393A3A1A50EFEF2B0BC20
-5D6AC175288180E8D7B6D831B5A7F2A83E36DE464AB787DC8442C4A5ABD4D9BC
-5BA190411AA224210FD9D7DCA4CFD73753037B9C655F15D4A06F3E1038D4BE6E
-6FAE715E2AC6B28F522F5D4598F9D3A7D6CAC432F3D072119ED9D370BC05948D
-F005ED4A88909C8DCAE253481F522C7086BBDE86A067B0766222D104CBBC2556
-A31BB6924DA174871FEFC136366AE6CB28E0D5716D1DAE992F48B163103608E7
-4043D73405A66A7D954E14D62F5D7DC41FB28DCAF0985E6765E2B7A2CCEB8D7A
-5D5E3BB1FD1D691485AE359C92156F0C7E41C48012EBC6B9EF57E6E38C0D49A9
-757CB049B02F6B867A4970F23D536B819FC5CAF65F680F4D4745FFD5BB7D2F30
-FAC8FAFD8F9F6DB3947AE87ABF8B778E2067A343A739FB5EBE9B08934FD5C840
-86AF28BAE95F0204FC6FC17DE47B198C7418FFD471E694209462D13AE46246A0
-2B66B1D26B69182B0664B1864B1BA7B2EED6BBB48CFA8AF8CD4A1085AC6A08A6
-71ED00CA33EB36A409E77F080EABF6B3252CA96E02EBF9A3137150E063D03850
-32FF9F4DED6E4CED171C17975BE74A78B241F0FBE744269C4B165240E351C07E
-70FCE19CCFDC7049F8AE95B8432B4AE416A5BBEB720CAF6D3CEB850435BF587F
-2F06B2573FF7F0E5DD8B664D00F055F4E92181E11346E833D38D1257779CD970
-93A535477EB1F55267DE6FBEB5B2FED8CDD1CE5960629A2320B5904B9D0659B6
-408F6E191D71CF5AB5343881DE325A9077AF0DCEB45533AB3A26DFFD7FB17BA2
-BAC585ACD6E94E08F006A68603F6C51AFA8B82FA29F47031B24C8FDEB94DD651
-DD2C40EBCC219B8932C6F1EE8245B05E1E4A497CDE68BAB0DFF42F1229F01100
-3E638CB49BBA83E156956E8AD166BAF21130463A55ECC53FD595EA141FEA1D04
-63049FB701420E082B033204F5F86477A9281F5AF942D453F674EAF62DF2F688
-DD5AFF93931EB932BF595F53D6AA86040B0656DDA2B5A3B0F1753158DB144A5D
-3E0595C3FE86AA9EBA298601A24D66E2194A1397BF30007B576D28C74BCDF14A
-DC34A579F489E2805DEC206BB30D0882B4C5679C3AAC7717009220F88CC9A258
-DD2795317AF0BDF91B5D692313F481AED28508F14CB6E8862EBA4D153E8A52C2
-339C03C90F1620582684D6B2EED6F4F35B7B064FE7E787ED3F6F5850D9496FE4
-36617A6B4776015F88D1AB009B59426D35B176C5B951648A17FFDED3D3396E44
-A508EDD36114A873BC0B3394BA30D5FC1758B715FE5CD3124EFFF8234425CF17
-FF07201E435B790696504D5538D2EFEBF2EF5D112599A5E2DF1A95CA7CF6C6E5
-584C86CCFAD811E309A84CE61E17C7FBC1B7C02ABA31CA4C50ABE7FC265697F2
-1285EABF08120B46C24DE5FE276DE24C42878E89C6F0D9617E0C6C22781ABCF7
-863FA23D3E06A06EBE615D78CA4E541BFEA4FB41199C7047970BF58A7ECBE5FA
-8A21B84E6C6B62F4A820E157886A01111807980C67753096DB80D303C7532C8B
-FF1F35AA111124505A627A27051789A0A0DEA844FCB13199D892C47AB761C715
-CA38BD881A301191FFC7E7BA12247BE72387C2EF42CF9A9A9BB89F532378AA0B
-EC62EE076C0F1A1A98B2CA61ABD267B016870E840C76CBEC7DCADB47DF89BCEB
-68A3393BD0AFBBA0B16E338F1FDBAA1434A9CC4725345C481DC0B6B815D80F5E
-C7B8D32DB3007CF3DC178BA0357D8E442BAF52AA5192B60C5DB306C2787ED422
-AFFA64198F666ECFE859A3F242CE5D0AA10BDA41CC2EFB4740EA9F00D9C9F272
-97344D4BB70F224F847FFB2AD9355C2EC3D07BD6561384CEB222621D4ADDB178
-04E1BC218CD51F3FF99EDA80CC950306B619306D6A5E7E28629004A014B1ACFC
-94D768E01E66B4206127318481DF32C617239E329B744ADA6C3F9BECACEF77CE
-E2A110095122E094302A18564DBCAA8D6F5A77C7FF202EDDB16D6D5EC0FB5DA0
-43EB8B8606B01F637FA31CE1790008BE35BCAD1DFAC3825703ED96F6D95D881A
-570E7088C8083E0C0D8F3DB72CC798D0C00B687125A8D3362162C875568BA68C
-6970EE35670EB6F75E15FA6B1DBFC0DB6D483F4DD104605A92C5E1FC444B7B5E
-267041E2647ED3CEEE3A89F278DBF828817A9D38080E7A6F1E71AD5A167AA7CB
-11C90EC8F0A23710B382844FD8C729991F3A28504830F00E0F50C4AACF0BE5B1
-5231222A588FEEAC4592DCA8E3EA109695A96D79C0CFEEF0C9F407D145E77939
-45ED59FD5FE0E6FB5ED308D9E2F9F5F66D687BC3A1DB27583CEDD60761086239
-4F13DF2A02A7125CC76BE19A2275BA92B27700CCE6592CC85F59A204E858E233
-7902F07B315778DF2A5B102D757A65504419CDB5F55563787A036E9495E6D986
-BAB107790B4C3609135162D72DAA7B9EF0B0D8FD8CB02D96574A25AC501D4B7B
-3072BF6D1E1D764C9C63218685DF32C21C1633131257AA133C2991417B15B221
-431EFD512E7EECE819577E277618656D4DF8BF3B5F02EC30DB3066E4FF4B2DF2
-75585E1D9962621BA056E8187C9C8EDAED876880C47C572624DD5AA7EEA85F13
-E5C140956D03FCFAA9CBB7BF4FFF484CF208B3506C1761789E47F24D3EA4C39A
-EBEBEE6866F2A6A6F8C416F262428CEAEFFF43876B0A64B55071DB38621DFE2F
-3EAD57D46FC268C59405DEE21B96C200438CFAB5FF14F0B7A4F0B8A978D50505
-37E891C626D03E8D714574D43FF7B5A3249C4214CB1FB316FF132ABD1B4FFDEB
-379898E6DD3AD9D96DE2D444774EE8F08813C09D9B059876EE09653FDDDD20AB
-F92277D6A35EC6940DE69BEABE7DC5F959E28E44AAB0DFBAEB318A6CB687BC99
-C262A3A22310AF478E327F3638C30213523DC53FE6076125D4C049F778830DC3
-517876664C91F075EC5D9B97FF352DEB6F3F4B7AC73452A5014D46F6611CEB65
-9C9752F8441D05409D1DE4E2BA61708C54566B8B0F2B48F6688970C2E67D628E
-BA74B44A03966D1A1A04E284B1868C2E7257E88B7C0CAB1DF8F2F95959631D3C
-FE1274ABE1C292B7C8B2AA2E581BF403D5A1B9639920E2586BBEB467F13A7E04
-9833BA6F888FEC435BAD817F3A0477CAF683FCAA4254121F8A69671BD14B974F
-24F70DAD8EDA7A4A68120DB4168623925BD7F4717408391F1C0A07E2FF8317F7
-DAF35784EFDAB0768AB112E3E39C7FAB712BE6FA37AA262245FBD49CF50D035C
-F5A08650BE7C59242E62F5A4334F5ED54DC1011B331CF4909AA718DF28D5F3C3
-FB9E1BD9DC531521B2EE967270725CD8051A878F154CC8AE7D34DF895D456B49
-B940265CB7CEDE88F53DE24A60FF50328A68171DBF6CCC783EDC992E8028DCFA
-FCDBF84D63FFA6FDF27A9D43B6B848F9FC0CEAF81B856050AFFBECA5D1ECB01C
-1309E67F97E8FCE3CB92313A6A2FE4AAC856DDAFD3472D74A6B86418A6B0AB84
-54048634EF8778DA982D3EB11879530AD25A7F3955F96F0BFA878704D36C37CE
-87575101D3DEF68354C2FF715BA9BB0EA117C5DE5F67A313F9796E0E1C50B65F
-E09CCC594D8977A8487346D1FF1ABCB21B27D478B6FDB63FBEC12A43F5FB6207
-4CFDFF9BF5F9B75020256E0CC80D34ED102AC8A8A61F361694620811D4105207
-07E9931C5C9FF3954AA20ADC851CB3FCE226201B8CA328D0019AD445D450B112
-F2B3E010E133A8B2D1C31ED2E4B9E98B952E22AA2995A78AAF065459C99347F3
-630E1A2367ED89E2DDF4316983205A4C1B32CED830223E10580550922B1EDBC3
-02651215A21737D783866B38967674DA602B9ADB38B65E1787D2CE79374F157E
-1A8EC651F4C7C27040869EF3AE0E38C76EBC870D4463B30E0353E9B937AB2F80
-82318B35D0D4E5BBEDC718B8B2ECC98FF66D29A38EE737943594851DE276E5B7
-5EFBACA40BAC294E24795CAA051DEE748F3EB7DF4831A2281B652416C163B43A
-83D90AE02326CA5295A6614261942C79C2E7C31F20B29F89B0C2236761B92DE5
-5A6E4CD7A0F7830BFFAF49C262A3F5F49019D85B4E3971A25BC59679F2CCB6B4
-9312FBEAA9A8377801474E5382E61B405286ADF1F0742DA8D83023BC94EA2973
-E10F19DF390BF0211D3B816B1003186588965E16AC67BFA01D35A4C038E0939C
-BB4B76FC56696DAE3F7EE5AD2D05D8345C49DFE665C84D32A239C396B5544518
-EDB9123AC52AD6490E4CD27DEF0C7F8F3E61DD5D5E59284CAE285589CDCACA66
-18DB59BA7C269D3FF4866650615228B1A433782E6FE642F64FDD974B24FB4445
-9AE0916C5442BD0F0CEB9BB6C701C8774C46464427E1F40D5A2DFA46E0D8A27A
-46663A155B169A4B498B5B7CBE830AC14D51C7440352B68C9BB21AAE3F59A2DF
-E2A8354D4A4230B9DC05E3F6FCCF1E336A77EE63A1388A4CC213AF0BF25ECADE
-013E57CBADE3E0496A4442672874FD92131DE2CCCE589D6302DDF71608487C74
-387EC9D2651DA9D07D877F453CC88EA35CE52E92C9D0312F004A94058880AC41
-8FC19FD92D706B7451D73CD77AD01E2B6FDF8F0B534E5EABD507E8480AAF10D6
-2A37346E35D604252ED68B75EFE98386D7A6B5F1E22C57F846341D7AAFA6D14D
-8F7AD7C5632AA71C17972E4842FBA118A13AE6BA5C098CC24465ECFE9CDFB77A
-BB3B346A211B8411864E8EE985760483FD5D37C6BE9A32F4968C8EBECBF4E352
-4263E794EB0EF4721D316B76AE9EC42119C6B38D6292FC827816876A6ED1E0D8
-8BB2D8EEAC0AA23C018D0A539DD088535737A6548CE1E6FCEDD67CCEFAC92CD1
-11E1D94C07DE54243B2D626A6C7E6D78FB9A1876C9C1FFA0CB14E19A956AE561
-89DB7E1FDE06B322FDC1649B86C15D49CE41A84AF29CBAD14E4F76A3874C2765
-041E235E02F7E38B48E0F4EDA33C0143596F1726598D218B7A34EF622D72423C
-A92BC0C8543F51CFF50C95BC809447934973998C68D304FED2B0CF2471ADE7CD
-A12999C86FB92C128179144FBCE8B9EDD578C7DC98C663220707684C9BD41B10
-AA7391C607282648AB6F295E0440245996F3ADAB5E36AD8C6CB1B05DF406ACF2
-107C648C86DCAB0E20D91F97521161B18749022DB7785649D2F69755C5181DF2
-66FCDD9229845F2DB61A1509EC1C35B74D38A492A726B5C74E764E9BE406C508
-837C3A5E584FB7280572E8E13AD31C811B51A91B04FD8FBE07ABA4983DD8EE3E
-1065041FD9A4959C3DFF9775FD3ADBC2612BCECD3190922997F8EFD70F7E7AB5
-4B3BBA3C029414FF088688CDC39A6DC708E599395621F1F6495B2EF706D8E965
-E13F33127B31F692A3212E726F95DCFF7699528CE4D8DF3F510757DE12D6F397
-21834FA45FD674422DDAF5E2619408313CD0E4192D05445D3AAFEC1F54EC1F4D
-38A8BBC2F95EC7E76BFE574C161823E03607242BD610A97E451535AE85FFAAEF
-2FCF376FA2983FE8FBF60E7DAAEE6DAEAF08C6AB9988652E1FACBC0296D2755E
-6A10F1321F4DBF917C360D6D21EC4769E1B009EC10E44CE24D149C09FCFD2565
-0B60437EABB7B6C0745E2195E724E6552932B8D5F056192DFD31C72F50F9643E
-EB9D639938F379038B2ABFD12BDF752B44C2AA00CE1B134288506A5D32E65D42
-92A9E998B6E39F49D49913F712E8F01638F632B485FF03DA199D711296476870
-67CCD1CD4D54CD143328592C4A21094449981989FDB4AFE4DB5639A1172741A7
-96FFFD10D4E2F3EA74E32E9D2B02D227C6D2C350C701EC682ED12ECBC29D0B3B
-520715C9F076A2DF14C2630E60C48C6E1F5EECD90BFD8B0E2C5784B2C526ACAB
-34074E78ED27E5397A9DEADEFC62072CCAF85B9E10DEB3A219BDAF48DF7F4E21
-CE258BB45A3154CB784BDC956E549557D4118AA4396A85B421BB184420078259
-BCCB1C6F5567BA5B57E21701525529949ED8D52FBA855F3D283EB225F2A0E55C
-A20D3AEC3389857665D85FD46FF9242B746DF7E73F0BAA88103FFA90DD40EC30
-01F579A567BAC08C31988DBA15E87CE483D5EB14AEB03A6B54D190A42FD0DE2F
-857B518DA5A16915B09A281D7990E45A339AC4A17C63E374B17995AE63959599
-83E4484D16A53044F1F17C73194E8A487F7CF0DBB29D600AA4ACBAA06D20A9B3
-5FF498C20A0513846BF43AFB3C2502B249E90B338DF8D27DCFC5264D9BC2BA28
-ED631ABD00E6663A0BD73DD6F89910092589AE70DA128C8B7045CD3582D5FA4A
-047AE34DFCF173E8AC093AEE9A80977EACD87FD7A2CFF876889F9218123F8C38
-93299EF7DC94A1DAA32428A05C018261DA79B3024E7BA5990516AF291D5A5767
-4D5C21719C590038592C6F41BCABFB510EFCF0423CC0011ED2D561091C8796EF
-E086C6C5F288F0A809952F44886670C1A4F5DF081C51B10C52079BBF9D8D7B8A
-683D550CE689D0D98CD434A5D5F8D5D484E03AEB52A208852FCD72566A6225EF
-00D1052DB98667B0962C3AE183E78AD5BCE415FE6E590EB70B58CDBA2784D1DA
-57D677BEB995896446B579BA39B9E270EC403AE66199F02493F6022D97E893B0
-C671E5302D4B6D4B41286394B32D893F9CDEF1E07080DA818A7E32624F5F0734
-733E502612FB3012C5D74179829BF62DDA3BA24083DEEBBD25B6BF29A4690498
-59928A521C57C45B19441AF4F50A5FB07C4C0FD11E96938E8347B4C6CB7C9F2E
-43C4C0F24DFAAA439C2027E955746485168793E430D7BE7E7EE15656B08376A1
-7EF5032F4CA4ACCA0BF5E47753EACF1D8B970D84BAC48B9F57BED8779AD7AD2C
-0A276D557B7CECE335688D98F212B2E28D5D35E8626C5A1909E399FED5F54CF4
-FFDD2351D32EA79002F5E365FC8C55637FF9B4FCF29F5D164FA17FF700254D7E
-623D77FEB665C4939E28179AA6241D63D8A67ACCDB009C5C7F2266D4604BE05C
-2D3B7FB782FB23AD60193AFFA19B9CEF458BF353B7E4F4A8693BB12C41B8D2C6
-B2DCC839FDF27CB33665D1EF0854E1CA9030250679E143CADF28E5EA6F1F9D52
-5C16E89370BFE38C23F4F7965AA1CD17602F3D0B774F23300A2B58A5663B4F86
-896B905DC30BF9B01FBC7112E1ACCCFCDA85842C46C04AE313A8607207801951
-645BDD81FB362BCE0EBD0107340207614A5A961DB798E7F43FF6605971C2EA17
-366BF84FF8B4FBF2666E443F71124B03220510A6DDE96629E7CC99764871C98F
-96AF79291E84F36237A38F604241F0D6C3E47B0882FDFF31A34AB534FC58C325
-BA4F8386047FDC7C810E997AA0024DFEE9092164F9E391E8A66EB12969FC8F1D
-3F391527E1B0ACFB6D6FD8B787B059068A8A6E12BCBDB6ACB967E993DD03420F
-09D09915995F296E4B31CBD2029D964C2F31FCF70303E5E3320826A277F24DDA
-CA22B27EFEEBE51B969A18A7C023F4FD60AB1A6472654EEC2425DDAA17B47002
-B4A3FDACEE018174DEB3784FAD91184E5E59485CECCCB086A0BA259A7BF25F31
-3FFEC540781A0BA794C0A886C093E8D05A7E917657F86FDA5BA0B27FD3C8F96C
-B781027EA18E6EB564D94FA9ECADFC27E03E3B79C06F9894312388E043ED6815
-3EEC388F2A56A56190B9DD287140F95EC56ECA32A336BC0B5D0437B28C08B30F
-FE0FAB24CC6ACCCB809D2C8DE003760B661819A92BE4D6014834288618759AB0
-A1944C5665C3632A853106EA0F99EC2CB5F8BCA9884E15ACAC8A7E4E37455A85
-549F7D9C28BACAA3DF617F352F74EFA6B1C2562C93FBCE819AFA1A85198E6F9F
-C8F22038FFC723D1618135E210B8149B41B1F4D0C5
-0000000000000000000000000000000000000000000000000000000000000000
-0000000000000000000000000000000000000000000000000000000000000000
-0000000000000000000000000000000000000000000000000000000000000000
-0000000000000000000000000000000000000000000000000000000000000000
-0000000000000000000000000000000000000000000000000000000000000000
-0000000000000000000000000000000000000000000000000000000000000000
-0000000000000000000000000000000000000000000000000000000000000000
-0000000000000000000000000000000000000000000000000000000000000000
-cleartomark
-%%EndFont
-%%BeginFont: CMR9
-%!PS-AdobeFont-1.1: CMR9 1.0
-%%CreationDate: 1991 Aug 20 16:39:59
-% Copyright (C) 1997 American Mathematical Society. All Rights Reserved.
-11 dict begin
-/FontInfo 7 dict dup begin
-/version (1.0) readonly def
-/Notice (Copyright (C) 1997 American Mathematical Society. All Rights Reserved) readonly def
-/FullName (CMR9) readonly def
-/FamilyName (Computer Modern) readonly def
-/Weight (Medium) readonly def
-/ItalicAngle 0 def
-/isFixedPitch false def
-end readonly def
-/FontName /CMR9 def
-/PaintType 0 def
-/FontType 1 def
-/FontMatrix [0.001 0 0 0.001 0 0] readonly def
-/Encoding 256 array
-0 1 255 {1 index exch /.notdef put} for
-dup 11 /ff put
-dup 12 /fi put
-dup 13 /fl put
-dup 14 /ffi put
-dup 40 /parenleft put
-dup 41 /parenright put
-dup 44 /comma put
-dup 45 /hyphen put
-dup 46 /period put
-dup 48 /zero put
-dup 49 /one put
-dup 50 /two put
-dup 51 /three put
-dup 52 /four put
-dup 53 /five put
-dup 54 /six put
-dup 55 /seven put
-dup 56 /eight put
-dup 57 /nine put
-dup 58 /colon put
-dup 59 /semicolon put
-dup 65 /A put
-dup 66 /B put
-dup 67 /C put
-dup 68 /D put
-dup 69 /E put
-dup 70 /F put
-dup 71 /G put
-dup 72 /H put
-dup 73 /I put
-dup 75 /K put
-dup 76 /L put
-dup 77 /M put
-dup 78 /N put
-dup 79 /O put
-dup 80 /P put
-dup 82 /R put
-dup 83 /S put
-dup 84 /T put
-dup 85 /U put
-dup 86 /V put
-dup 87 /W put
-dup 91 /bracketleft put
-dup 93 /bracketright put
-dup 97 /a put
-dup 98 /b put
-dup 99 /c put
-dup 100 /d put
-dup 101 /e put
-dup 102 /f put
-dup 103 /g put
-dup 104 /h put
-dup 105 /i put
-dup 106 /j put
-dup 107 /k put
-dup 108 /l put
-dup 109 /m put
-dup 110 /n put
-dup 111 /o put
-dup 112 /p put
-dup 113 /q put
-dup 114 /r put
-dup 115 /s put
-dup 116 /t put
-dup 117 /u put
-dup 118 /v put
-dup 119 /w put
-dup 121 /y put
-readonly def
-/FontBBox{-39 -250 1036 750}readonly def
-currentdict end
-currentfile eexec
-D9D66F633B846A97B686A97E45A3D0AA052A014267B7904EB3C0D3BD0B83D891
-016CA6CA4B712ADEB258FAAB9A130EE605E61F77FC1B738ABC7C51CD46EF8171
-9098D5FEE67660E69A7AB91B58F29A4D79E57022F783EB0FBBB6D4F4EC35014F
-D2DECBA99459A4C59DF0C6EBA150284454E707DC2100C15B76B4C19B84363758
-469A6C558785B226332152109871A9883487DD7710949204DDCF837E6A8708B8
-2BDBF16FBC7512FAA308A093FE5CF7158F1163BC1F3352E22A1452E73FECA8A4
-87100FB1FFC4C8AF409B2067537220E605DA0852CA49839E1386AF9D7A1A455F
-D1F017CE45884D76EF2CB9BC5821FD25365DDEA6E45F332B5F68A44AD8A530F0
-92A36FADB679CF58BAFDD3E51DFDD314B91A605515D729EE20C42505FD4E0835
-3C9D365B14C003BC6DD352F0228A8C161F172D2551CD1C67CD0B1B21DED53203
-046FAFF9B1129167921DD82C5964F9DDDFE0D2686875BD075FC81831A941F20E
-C5CD90040A092E559F6D1D3B0E9BB71733595AE0EA6093F986377A96060BF12A
-A1B525CD9FA741FE051DD54A32BECD55A868DD63119A4370F8322CCBEC889BC2
-A723CB4015FC4AA90AE873EA14DE13382CA9CF0D8DFB65F0ABEDFD9A64BB3F4D
-731E2E1C9A1789228FF44116230A70C339C9819676022AB31B5C9C589AE9094B
-09882051AD4637C1710D93E8DD117B4E7B478493B91EA6306FDB3FA6D738AAB1
-49FBB21A00AC2A999C21445DE3177F21D8B6AAB33869C882613EA6B5EC56476B
-5634181ECBF03BFEDB57F079EACE3B334F6F384BDF9D70AEBD592C8ECF21378B
-54A8B5DBF7CB9282E16AA517E14843909339B5E7C55B038BF3BB493F3B884A1C
-C25F9E8FB912CBE23199AD9D2C3E573727701BA301526C66C3617B9514D6F11F
-11930B1D97C17816C85B1BFD9B973A191B33CC3B391815AC46268691C741B2D4
-48A840F1128D9B2F9CF07D0709FE796B23A836417BF7B5B12D67F74453C82F5F
-25F7B30701D6F6D4F4DC623C0C27D6A6FBECC7312A3CD10932FC7C10851C3C52
-24B75DEA8A648B7F34F5711DB0E843C914E25663C510185BC37BDB7593C1C259
-21D8DDAD33982C336BF272BAB2F48E68217403FE9F54877B243614A87E64784D
-2796EE4179FBF96123D1BEE3EF89D682B427BA4F12A1318A57F18BE5DD903815
-2617B231347185E09C836AAAC02D7084899EE31E55E9D98B2EF9075677C6720B
-2B49EB18CE9249521558B183DA135E7E2AD901630A9A87F4D602ED878C6A4A50
-05D952816B0C0507CDCB79721B1304AEE2116404EBA735C41FE0FAAC2ECD7419
-1CD6119BDDAE9C5226482230ABBB7E206B31AC812D82A60309E77DD103782E5C
-1DE1A0CAB4DB4B3FBCAD1628286369C94134BC603AEABC4127B169E2B3AF1634
-0B354D88908260FB3D1C72F2C069B8970C121B2CF0877151D1933BDE8639E569
-9B7806AB0FCD5F28ECE25877AF315545BDDCA523EF2B8E6C7E5D2E64BF8FCDEB
-E317ADDDD219D3EDFAA01B7782C51C46CE1206D6C1881F07D9C2FB231CF35471
-E4EFCA0EEB33E9F440ADBEC93620032ABC2E1D04366D7F618022D7F23BC1AA80
-5437647FF9A1C4DC414C9FDEA261AACE8448E27233A4BA9C2A527D4032B0F13B
-314EF5FA5ADCB5BC1B0A46D9339F66CA940DD52F192816E7ACDB30B0A5EFF46B
-AF0E559998841C5D64881B43F47AD42BCE59953A48AF8775BFD3F1E9DF1EC263
-F4625F6C86FE0FEDD9E809C2BF7E883D5CFD0FC99C9682D5016E5AE069568EF3
-63D5381A94CF9AE216E81C362645ADBEF13C35E069AFB185D9A5A4237DF9808C
-A466FFA2867EB7B3CCA5BC2FD7EB2A5CDBC1ADA4BC4C887058752D75DA38E54F
-D30FA318F2B5681419ACDBBDDF526AA57410998C94F5FA582F6D61E547CE3470
-0B89918A6AEC4D2C7D750896118B38AF38FD0766CD3BF5484D89040DA02F1387
-DCA60C9B5134D949A17A4B4EB234FA3665E9B2CA006F0154E6197CB3FA8FB414
-C98CE24768F416F6D07C171F7EF052D578487F2EBFE86B7315C9B51C1F6B2EBE
-3086A1C08D478C350B2F30C32AD14183DE9D54DA9BEF52AFA98691ED8794C3AD
-F7264AF88864AB739B8E3B3EDCB4F898C4C9D944FC432B5D956AD7CC1CBDC5E2
-DE5B70422F66120B19280B51D369D9B43F5AAD67B470322F2C8D21A32DA3E8D1
-BCD5E216AB849F7D17F7AE998F3A79B9838C7C10DEB6CC746F201DE9F888925A
-C07CCC3BCBC2BA64FB84EA8C847806712ACB3B7A9D370F838A80AA5AB8CF74E2
-B29666C3ED08BEA798D11789C3680199787BE01C07E4321567535E3FAA0FB32C
-0BBDFC4B5BB007C290C39308E9CFEC2598B02532B5EFF4E4A617083472652311
-151FD04CBA9A4F32E2CC9C9ADAF0AE0941FFFB71EE93BAD2C3F7AB0ECB40041C
-065F02167B80ABD126825292F3F71D5917CD83222761AF068682BCF09DFC6055
-2E0F18BA4CF813E38BEA87DF4FF8076B09826758C5BFE38B27AC0C6C39EEC46C
-6D037BB34ACAC50C738F340478BF6637A74640D6339C8436B5A8142680BEDA24
-54207829D525C8BC387DF434FC4E905EF70A092BAC03265D6512B675AD89F879
-A163E65E195B7CBB7FA06AE6C5D718D2DC4BDB0571E13C0D466EDCDE2FEC32E3
-C1E33B653B658E1740641977759ABF149B19F4803A56885798F89D9AD30D883B
-3A72714917289169DF4C171440FA6875D6B00040A2836C99149CB9E9354CBF13
-24C0A0B3758A8E2455F46E36C8D4D89691780BE3457B07EC1953487753AF04FD
-92C26D19E22ED9B87D26EEA46F69D5BE1AD81AC648320C1EBA5F14EAA93C6BC2
-064D412B1B55C174766DD217B872A6D627A957F6380FCD5D041218086460B7DE
-A9675B3DEE059C8112952E294AD0998ADAD7FCE00305F9D3E72D2CA19A3F50B6
-825E257B6A61B472409688963F2C5197F94F59B8C92A5C6171CE419DF4527521
-D269C73D6212343785D14A64A9242D02B5BB019A817A5CD5056188614A5BFE5E
-68919B50D34C2A5AA24B24B73EC03D3B06228BF2AB8C800747059B42D13BBC2B
-E4C5F73FA271254996A4BF60CB159E5848DCE66C2A7A3AB8C8487196A2770B03
-CAFCB19A9CAA6B132306A77939587D3F2D07F85E4567391E12D72687198FD7DB
-705187EE59A4ED3C7F99E8DBC2A42C1955921F730B3320D0FFBAC9620BCBE19A
-D8B688183876C33E0625AC4EEDAA67A67D8C27187F072F982EC3BB7EDA88F99B
-1C1C1D4BB1D69B96BBAE57ADCDFD4FEF9A6372300D95957158DFE257A805D5B0
-17904F53F9D33FAF95F37E313396DBD3D3D6790772C10EC5C2B6EBB512642E3E
-3FBF4B78F85B6F2C2517802237A05A46FB651A34FFBCAD75AEF3B4AE766C98E6
-31C4D2FEC0DCCA1A958CECA8D314F1612A09C956221FD07A0734E7F226FF8E9B
-990445D0BDF6304B4D08954E28E8B5F1BDF5AE506A5FE6AFE93470FC20B2B375
-94E8CBCA8ED2ADEBC48B35A507682508D429A322698F98DEA1429230EC625903
-CA73AA163C739A275F97C180C24DB3495478010B49895E89A833E84AD0923748
-7EEBB480B828A40AFB698A7A3BB056833109CE417FC347820A389E7D6B6C8942
-0A38983B7A64675249F9BDDDAE45B1F5247E316E2529270934DDA549ACBF69DA
-D7ACBF9A7ED386D4482E3FB8A67EB35FCA48DDFC3E9E21954976799C62789059
-41E9B7CD275DEAB64C65078743D73BF8AA302B3261D5DFF4E1990A594D666A5E
-0CF53FA6CF887D5DCD340740872B089FD99B1898C613060B2C626FE7FD63AC2E
-82C43721A03C6B60910F18C0544B135BD4AAB90D22E1B3113689788BCBCF1C36
-5AC37D0E41C0D0F08F93623463AEBF4826A3D074EA6A6C241B2F70511BEDC3C5
-0DA05C96FEAAC3F7FEACC96EE5099D6E7765E506C1CDF1A2E202C7B6D40E07F8
-186916A068A22824F881C1CAC64BBD25B91C1E4E2C4887E51FD19F7A37603033
-6DB8865B779D65A26C1DA77457D026AA9B8102E8958B60041DEE0E5D64248C4E
-EDFAEB6279AB6BCB14E4DACA3822E92AD99D706FC987B6FE558982E075DE02EA
-B0DD2B60405A26BFEC5DC14FF7319D229BE988BC255D7013DCD91A7B4C68058C
-3B4C2B058B19B3A82C02F2AB6419F309CE6000422CBEC23DFE4694932ACA3C58
-64B2CB5E6D6735E789E2CAC92999EF09408070220AE73B753E18994E1CDD2755
-28310899F5AB6BC59C725730B98D2C9C8C0885C92ECBBA6BD258131F34DA80BB
-176BEEAAF85F4D8853194611140B4652A38AB78491282DC1ECD106044039E31A
-08A502B380EC1D56B88AFA74D5FAF62A31256F7AF2B9825F587B63AFE225C3B8
-0A819759057BEF22C8666D6B933546B9B5235243C9961F2D1DB91A376B4052D4
-F8E08206AAC6A0836AB9279550D79F4C9351E090887F2CE788B82BC17FB321D2
-573ABE2296FF6AEE4AA688208B074337A746C40E1B8BE5F4E6039C09E7EECE8E
-665AA85458B0D18888EDC58361719A181A5611C87BED681A860F60BAF7969B5E
-6717A257EE5BE70B869F8DA9E4ACCAFFD866A8D12BBD09D7CD67D8ED65B1E767
-A09AF9872DB309F5173EB4CEE072F4E883AE2EDAE70513B6F3CFCD5E70375616
-C82B3A8E75A989F72F87382D2B077E527852FBCA9132A1CE2B277F9568F18E1B
-779F8F99C311B6024F5C560AB0960CFACE46A14188FF248D751F59F0EE2431D5
-77EC171B8FE625F6603B0719AA2D273879DDBAF2691AF89525C4357294D2EB1D
-2DBB946C3E0E3410F9F81E170C879C411B4C64150A196F1130811B3109BD3618
-85CB102B22B3D1B06BC53AD8C094A633B10AAC847CEBE3F65F47D6F32FC1B6A0
-CC3FA2A0C1EFCB7A40764417F5D522D224BDD1AA68E5A3BA98960D69E7C31996
-6FE5583BE1CB1BD2DC5277FB49F35B3BAD301E5EF0ECAAF358115F197F92B5DE
-2875AFA66B66AAEC383EACB79BA769F5FBA313928D1A697BC389E39EA725FC77
-59F02ACC3165B635F99F2A3BD2594A2B6AFF1DFF16748F60379375C4313A4100
-44F1D2C56DFED87418AE88D9C7C3EE54A946B8F4A4CFDB99857B7B0204C8A71B
-69CC0DB7DFBD57B6CDAB5D670A30394A041706BE9EF37488AD284813B2F7D30D
-81E1F955B6C58B48E8FAA8E6EF9A092CD65968F59716EB70EC237B45335FED92
-18192A44FB0AAC924A60F47C1AD139F2A4228F88F932C72BB54E8AADD71AECF3
-A3E53CF1450D8497C7054A0E79C58C9C1AD4CEEB87E17FFCEA7B3CD52056564A
-94C09E87E0751CD49C4A3F1A0BB905309D97B3F5EDDE5122720AB086EAED99FA
-00780881D89902644F27E335FB312BE5028A041377E43F980F78DF6BF4F199F2
-C2165FB5D9D46D6682800BF6A03DF6CDBEC995897A6826B186C093837FB16B8D
-41DAD29CAFFFE5C1F544AF3F76314FE9158753B6AB9B5C22D3E41168369EAC53
-69FEF08A7DC1E1ED9A2DE11EBA7756EDDC697E5A3F211DDF968F642022C20F8B
-539F90CB8119B3EF1B6326A2AA0D4694BAB34ACBAE5D03B2818978B16A6A8EA9
-36DC01008D37087E7361F117B0B419EDEBAC55B92383D873955965C341DB0670
-873F035954043377403CCAA16844762DE4511B9A5668B91C4075D8CF83C3743F
-93738D5986220A99E6DD3AD9C865608D6A48BC94B80B9E1849B69A08BC003AE9
-DAC5B789E36C8C52D10B30D1A676B81050FD773B5DD9DE16D8DF1C0FEF9E3782
-2EE472D07CFE8133E779A8362CD84482726B51284EDA06BE222FF0C03FC7CD7B
-0BE9143F244051FFDC69B0C31B92A14531EC45BD1EA0C22708C0668AEEED0630
-C5FCC8AF097D32CD82192B6AF474606A3880173A9EC5635647932F97DB3931BD
-2570723779E9311D38653561355D164331F5CCFD7BE51810B44751D978C2A8DB
-868670CA59D81F1C266875235F7F127481C33DB1CADC7ECB031B131184162F8F
-C1C426AD8EE29B90E92E03009C528A438035F0502EE6B78B7C985AF58EF2AAE0
-C7683D16211097F5061BB10AF9C38C6873309999E2A5948F3998AE7A262CDEB9
-256E8208A55EC2AAE276B6FE4DBE422FD6CCE59EB8D35003B0AD3A66AAE9B892
-90DA5B6BAD48BAE57BAC2705049468A80F9E91805B996ADEC599B81968130906
-7BB8BB1A0CA1532D627912AF7640585EA93E86C66C528BD4A41E0C079D85F49B
-896316745A4D4D488C6AA6D7C8169E6DEA740D1132439811AAF7F6FA6C5811E9
-A4199D7406C786E3A390015FF83BA965EDE5B44E7249BF34AE9A8742E8C811A7
-2F181F4B178032F25400524930E80E600CBB1D642FB8B97107968405A462B331
-BF05E1DC91D9B38C9114AB59B3E9261BCCEC0567090358EDBCF6219E34DF0D99
-DA36DA7724EBB460901CEA1647795DC3E42D2988055B36C39CDF48F3356E4227
-B2F4FBAD76CD1A85F77D87E218E5C7FE42C26D4239AC4DD9E7CD38BAE732DF8A
-3A7276B339C0F12FFD0F3EB05194C245B6325081B00E802B2939796E44246D46
-D32FAE883BD453AAE560B90AD136C37FD8CD2417729872D1B2629253E2707D8B
-30084E416042CE1488923F538A45D38A89C649F82D46AC54D0C8836511E8D598
-95B139973435E42B6BE29EC223932330B558D92968AC81C4565E16652A3D5D73
-8DC1F739DF70AA3A2D946B25217103E9D9BA8E1FEF478E5344EF87723DA79039
-227FF756D9A7CA10262BBB1DD75BD2BA309C5D65286FAB77F0811A877944181B
-767AB5188BED7F9A5F6E55CFAFF99BA2785C01E6381A14D76BD333E25B69581D
-506043C433930918B7EABFCB149446D72A091F5BCEBE6E42B3F17777885F3BAE
-5BEC0557FFC9269775E1E18404A24DF64D156D62A2AA1D7B10FA3EDB4913DE15
-EB18EFF166F1C72D09743CC778A7CD79BFAB02CBAB8755DFF80AAB0A281A29FC
-D785A7D1FB0A8C6060788A89BE60926FA7C63E596789ED6A58B8A5699F5814F8
-749E9D416A0DA2B3A3DD79C5723119B03960D21A79BDA2C47D9D34941BAC5F58
-AD70F3BF3DA3051EB0125CF8B85AA69A8B08A1DE8FEE15D6F06682A6EEB82286
-C461C765FA25174607B11F3B444FCA80DD1CA034F5DEDB5D3CF71112E4D6DC1E
-8B5F465A78EAE8AE40C9CA184A28727E615A3E63B5538D31376A4A33DB534EFE
-15FC4E5DE07081F02C25413B85FD27A55F005B41200D11ADCA2BE9C2F8EC7571
-3B6A062490D0AEA9405A00666038375FD2564B045AA9BAD8DE90670017181DA9
-7F17F999731FA5D111F8270838CC40FAE071F4F3E232D6423E62329FBCE2F8C8
-48DAEFB17147B81E7E8A74A3B9E1614D4F1FDD63684CE7A3E1CC2FAA67D49017
-7877EC3D393E232CC8DDCD7C61FDBAA5E549175CCB853F21BF7479EDC67B5A79
-F4221D918400143969BDF022588B58688F23CE6EE72B7C30884D54BBEA9611F2
-9FFE291DD1F8123174AEF92B6FEA73081D6F625649C0BC6656050153F57D99C2
-D0C87C4348C47EF57BC2887165F0B0A738A9B89946E9F30BBC5F1C45B22245BC
-6D4281A62FD1322B0D9260539D9AFEA88355D02C0E4A7EF99B6041638DB16C56
-80EF6F3D3D03FE5B45B314D198BAEB2FE9DBF4680E840FA98757D1EE10F44962
-32F75E694BC0CDE119F378F85C5740012817FC73E660C2C6741585038B2BDED1
-43E4286EFC690CC9F1C86F130415D269F7C0588E51D3B9699F380F76DA949EDC
-4030DBA93ACE8F554A448AED35F5732CF319AEFE0DA9407A4DB52FD983D9DF23
-1E38EE562EE7458BBBFA5FA1598C2F8C9A2D2978F6634D13CD1FCD153BA0CF8A
-CCEBB8C8676650588BA84A0D408E74EE400C54FC5D33512992886B606CC1B2E1
-6B8964C67714DD39DA2E095F8846302B2FC63A732AF800420EE2F69721AC40C8
-198DE6EE12ACB0115B56ACBFF635B622D6FBE07AE2221A8943CB778F6332CA9B
-142D0BCB53DA32A5BD6C4A6010A3F8D5EA79E51BBBCA1B9F0102E91FC5E7C0EF
-11E8AFCE9CE37501B793CF31A30BF6A71F101815AC6E049116EC474245EA4C4C
-B96CE29CD66235128CF1820EA6C644C0E64753EBAA137AFBD48F74E7550E57DF
-23499DCA8B81AD892DE34C097B651F722C3A36D996038DE84C8C1245D4DBE7EB
-E6B64F0FE0B5DC18708C5BEFACADCF6132F45DF5905F013320970D4F74C33CBB
-1A1CE868BE636E03EBD3BE160D9AB140557226707518569AD9388B4B308E9AB4
-003DBA8D16D0A32C8AC8BC69C2B0515929D47E560F97084A6C622AE2306C26FD
-C68CB9ADB84E360C57A1E3C143C2967F77E82AA9D42F09308EBF05DE827242EE
-F39CF29D8856B937320826DA054F11F353FD3396F77C1B5EBAE08FB7E9FCDBC7
-D36B27F38AD1E6E1436738DEC6385E92494C20C990EBAD484FB9A3527331A191
-21EC6610DBCB56E3B0EA773ADA5428A0DE812691A8086C2B03C3D83C7A5751D3
-F91012BCB326D608EE446A68399870678E9338F2283554EB9F606FF972D94937
-1B5931AAAB6C1A97E5E857C052397A4132BA5ACF93A1226B2D7F9C374F098D8D
-4C45B4CAE174C72647385FD43F215E003C4436773397944D8FE72C9C3BFA28B8
-395C93AF828395A016311EB1CEB2EB85E0120417EA53E056EF1A0E5AB4D2A661
-4AA428655D2952BF131EBBB09E1D905ADF83C0A350D6F912F5C351CB6035BE59
-179624E4916D8B11C654628D93D534700DA8715AABF7F24D3B532667E291265E
-A88215E4F2DCAE3FDFDCE703A43F11BDACBFCD861AA5974D46E553D4213E7354
-3BF4E45E5997FC859B9F4CD2D1627E824954009877D025750A81C8A07E6163D7
-945A01D5FD186623CCB8D38A7263D153FA190A4272BD194DCEE2AFC9FBA9B745
-F0150F6675221954AFE06CD9544384EAFEC5495844323A27ABC060E70DA6168C
-E835CF739CA9D45AD8A26154DDF40A002350CDD6621F6935B099F51E7EEC1FB5
-2BD4C4791E31A6161A7463333A044E8AAE86EB255C074DE18DF9BFC534CEB01B
-C74C0020DCA79FD98D518A084AF9E91462C910FDF3DA9250A2EF996D6686F6FB
-63876A513F0E0E1272BADCF81CC042E42D3B2624C510184BD0E2140D3881AECB
-4AD9F9B5504C36C4847DD2A272F6643390C1621DD332E2215A3B8265786061BE
-BD04941D58CD93D88E06F166033D361DB421AD8BB541AE428ACB2F9AEF170E08
-211450165DFE7366BEA509D76F5E866D5673F1C62BAD69896C94564F1165DB54
-AABA04EBF2A31FCC79D7B370B5A5827D791CE120BB075E0B4FB6722FCE30F5E7
-6CAB671102C7873C5764E62D01DE760B93AAAD9D064DF7D21E37BBAD2D8D4AA9
-21A04EFF19EDCB60A19CD41AD9E27FB3BC8E7868E78C292513E59B5CEBE4B921
-96072F57B416952A4BA9F7E42CE4C663388893694E80B76ED31A2D87A427DC00
-58D0E949B69CC7BDA3AA8D176A10990D57329D6CC9E8059B1DA799FBC30231F1
-9E1A4BD8A7FAA8E0E893CCE6610A8E221091E1D17E0DF655E43153971CB1C37B
-96CEF43699D76CD7F5AD3068EDE02A38468EA51683A92472B201398EBCEBF09F
-38B722A98491E8E13707E51E4EB9F41749B1159A770CED917DB7C990A179A82E
-21390D9729A600D29121259D12B057EB65E8BE513D6BB38CF6F2C0F6E1C0C15A
-EC40022683C03B54F7278BB68A6C50A8A9A475A7C4EE6916F1CD35DE220F1B3D
-F0E079202B676810EA73BA2ADE118103829FC4AAF2421E5673B1700C16132B55
-7383E2B1F5981B98F9AC595E7F998E628676EAB540674B981C336C24F7DA41BE
-B2719B2CDCAB0B1AF82E2D72E9CE810F159B53DC551ED399BEE723C4611D4DA4
-53FE2B238EE66F4599213C43031C36DD2F2706A706AD75275B5A3D24EF1D0C7F
-6E9243A551DD5433D7DA57E2F0BC37E8632CAC3FA4F7BA5E49F831D1062D2D75
-41F7B47B6EECB46A0C20C1A7EAF650ACED8BC16DCC1E65360C1CC64E79BA255D
-0DE901091F1467644207A2709C764984DD876417F231AF0D22185354646A285A
-8245A1E1EDF87704B2987AE02A670E30F23895EE61AB57C423C21E3A6CD3BBD3
-94F3FAA0918C0A06376917F77D973A9B91F30EF462C7F067E157B37117573197
-8C55451A1EAD8C02533078528D3EEA00E1992F244F1D623A9A49CCBA3CED350F
-6CC1908691E4094232C010305B4FF177A8465B0481C0326C2250B8CAF81751F7
-EFC67E569B6A743B579FD83BC9BFBCBB7F1C2E8CD26E5BF11DB5894481DC639F
-6607D2DA693AACB7AC0358F2FA7C1DA84F4EADE4400F0DC93FBBAD89D08EB000
-F3E7E88AEEF2558433270B70B610D70A6A9364BA8AB54BC0BCC44D2D2C71233E
-1D6433107391FA1CF93E498D307C86B129FAEC6666CB8F4560E98D9F268F8FE4
-82A532F55A39569EE27F83270F169D568DC9C824EA3AD2EEADF2F155A3AA539C
-8FDEC67825265EB13FAFEDA703ACA0D240F9FC9D44BDAC5954B675E9277DE6BE
-C429817BBA1AE1A4ED09D2E300670380E650CA0542429CF38A794D1D6296D875
-E91EBD2B264C185E7548DF2B4E5E37C479349CF17CB2CE9D79ECAE2B4EA83398
-9F67EE849F1C974BACE15E46FCE8542317B35629FBB60221C7C77EC21C505F6F
-AE74D69A603D6378D24A91783BC7DC88C78DF57D9B82FEDBCB46D3A9773C8852
-6725236DC5CBD9E63BE1B3112B24D60F1A7C3F9BAF163CD7BE52EF7A734AA568
-0FA1AAA0427A5337621D76A8C839DAD7305570922A9A1D5FF36A8D0B93D0AE03
-C9E05215304C4F1D7930331FC72C3DDF098C0006CBF404AC87F85D5153653A63
-8454725BB53A6E6DE47947DF7C11192338B1EC0600DC18DFDDE71498078FB25C
-9DEB3F29C9F9DB8C9AA5F663EBA095C5107E7A1E348A270DB13858483233B94C
-7FC8C5AF90CF1602EF11B8F7848E5624351B27D86151598EDD1678FB737CB33B
-9D5DF34DE02BDE9F6A7DDF0F44B7EEAEA21BEC5F5C9939F8C7262A6086188396
-2C96B4FF4860DA9E7E29380EEC700BA22A94D7CE11FC48CB65B05742300EAEC1
-AA5D18B07B1AFEE6CAFD96B8BB6876F88F64FA9BAEF0E0EED7F971622C383181
-41E37108694EB7F2DB55F5F5D1107D6489B6B9BFBE8D38428B6B6946AED16339
-84A7A67774B689F2D6977C4CA85603FCF9D475C8EED6BF9778C68181E5DD167E
-8BF307E8EC418B7D634E07ABD74896E84406E81603267F41D1F2F8036EE2843C
-474DE277145FD729FF5B169A878E8C4B8990AFF70F59EF19DF8B908C1D31E1E5
-BBFB0982453A8FEC0BC45CEB8724BF63A9E3E28BA6476C02D0D000C3A195EF34
-B1E94763CFB076D346B3C1F2642C3A0D469C1993D94CE66EE1B2163BE11DB896
-BD35AC26087DA2C3B972B884A8B3BFE968046DD1DB330C6D791AE53B657CD3E0
-B58E21B5916B10B475F4B68A9DEB90AEFB5F4D201C218CAD20D629DA5937BA6A
-8BCBB4E72DBEEBBD530974D49949C3820B2178119000585FF745D6177919090F
-40E8B0E1D7DA6956C1026781474FCDE9FAEDB58D20199A3DACF7A0166744C932
-0F45E8EFC9EACA77851476AD1171B6C72090513AC7F975FFEB0917AE25782ABB
-B6E08885346EDF7F7222622D2A59A3E179056A4A736171848C8F882135A2077A
-629765395B1180CDD6DED2FE4E2857514686C7AF2C2EDC6369D4BDEF806E68A1
-58D04171FE8420D1C3BDB3F223A1B5EE2B33AFBA149B075FD2EBA8DBEF318347
-FC3134BA0B26DB555B75CE299114BAB353F159DA25994BA23A7652BCEBFD4537
-14372CFF3D0E0618C8191944278FC25627624CB476BD00F70E03103D2F176467
-85FA95456A9411F2853ED1AE7B91BC6291858DDA415937E69D1A22CF3E87ED4B
-B99E73B363AD8D753860D22DC8F5555DBDE708481E857E2BA9F50DCF5683A4DF
-2274ED00AD14DE3A00347D3285AB6615B765DE5E2EA4A4EE864A73F6C0C57ED3
-382FBDFCBC2930F5A32C228540DFC2D69D770E00517E97B4C48F16E7BF52DBE9
-1E81C90507F4B4FE643F5ABB340B308FF4BC2D123446CC2A6692197EE3263475
-DCD802D2718C8C0F261D491CAB0D9BD5A1963759726A7C26FDDBB2474CBB71DD
-CD31BD728A6165DA76AA6F5C7B1D01F143DD9B18159137508268EF544CCF067B
-3C196BFC30B31BC772F3D753C744099E725BE89EEBE39549F4D9C93645E94803
-04399E790B5748606D99BDD3C0A973E4E561F05E902E95F99E6F47F68F835EF6
-C14CA88EA7E552D7E5EBE77F675778739556A608442098EC2D01C9ABD0B0EA96
-0010EFBF1B8001E9BC1FDEE37A4C73C9C748D4235E40F628B6D1289C1C67859E
-046FA93245271BEFD52C13A98CDFD73B3593AB98970AB36059E76B4446366830
-9496A537767613B7B2DC8DA4B82F9D6B607DB1CF360F8235F69621A5EAFE25BB
-E6FFE337461FE365F261DA40AEC0F3B4CB5DAFEA7E3B47C219FE67BD3E0D23B1
-EF173713249923719B7E7F8F8FB8F2662482327E5FD2E8FE838F3423E9EA8CDB
-7E8DE5B82589EC77FBB38F3C83FCE56025A69A1D1E2195459F741D59DA25A3A2
-7B2145FBFB5AEA914E923D851F82D1C8738708DFBE4D6AF31380BF79FDE74A57
-9BD95BA25E99F58440C931195EA6A57593753A217370352C85CBFB94E7706D40
-08A2744E2B119EE0D75E276964F6CB776C99C2B198FA289ACCC2A61305F28C82
-9AFE8154C8FEB2A1D84EDF23B32A72FCF8B3B9D9753563601C0FA62BEDBDC081
-C4F9C6A843FFA22DC14773584B92296BC094B09FEE5DCE6B8CCFE61E75288352
-766D16125FA544576DD1C03ED3462538582F6370B74027E92237ACD86F768A92
-502890AE63526FB4B95626B1146DB4786E9FF6F565395CBBEC82D7C7ADA9635D
-EC78141707CA6B94781B3A41FD227FDED6AD3BBA1681E9A80F1CC7E1EB1B78E8
-6FE122D9FB24A029D168FA99D7A046AB2C91219EB1596E6395B8EA9736CE4C9C
-FF4DC1E4E735E3B68DE59765CE11DE38B71AFD13927AA645AFEA1CBE098407EE
-E00569AB2D86F7709B1471AA16B6AD8381EB4EC6EFD908F084D7F90813564369
-828F4C3933AD2B581D06AFA5A3250328D825DB89B80002AAB371BFA0628CA722
-4977A1C5ABD0A7F84A2870608A3A85A3BEE058C92BC5DBD710134A64AA9BFBC9
-FC61330B37B454E945174F9C6C1AA24035EC01B9A34B0AD0B818F19EC7D78F63
-04F793760114A5CDCB25BF16BD4934D0500B3F3A2CBEB489E0F9A7C5289D1ED4
-EC596D363F51C0345536AB32C6419E1B4B11C69849BFD2BC0F6EC4BB5AC9AAC5
-4DC822100AD7C024E1F302623291072579014899D5955327106A1BBB2E03DED8
-7E46AC4AB17052375FA7F291D86367C1E1C3DA43DDB82C03746F80B8AB988859
-BA0B911106546CBBC890420E508F2CB81AC9B397C1FE8CE48B809EE6D00F3770
-0A77967AFA463E2FDE687D8F63EBEB62D1AFD851A57102D50DB09769F7BB6C8A
-BA222354E81B4B61EEBAE82BCAD0AC2AA88E317DA0EEF56A282D3DE538065464
-B1FCF965C40BC740F7D42D68DFA9CC72CDDB77851AB8627A10980BAA82D74C52
-EE3F30CFC69103FBDBF57AF5AD177948A6274C032F3D99E1584D3E32FE2C2A43
-0AD2C7FD5C2FD15FF95FCBB1BDEFE09B5741AA2BD2D68940BF9280A1C3F22905
-7E70D5876E90DD8AE6B7CA0339562E9DC15258ECFDDFF940C96201330003CA5E
-14234C29BEA2D25A4FC3FA4E8945C774FB9622FA6B8B8FBB0871CFB9773D22AE
-40A3B664DFBFF9929C65406CBEC1A4BE32547506F0EF9A78945A2496028F4C89
-042EBD803A5DE2426270A88AD1FA6F5878BCD2658B2666145244BD52A9718B9A
-669D7FF8766B566ACD50DC6E7902D3721755BAE3C339C1C56EBE122188F50BEA
-C6709AA9E238BC44FCD3EF695F8C928D511360BE5FA47389B0ADB2DF3CFF0FB1
-AC8E330902EE94720EFAEE44F4A86C05F7532134A7969B76914A0D0C93519EDF
-AB78ADAD4801025C24F5207368BD51F625D29499A5C0C35F4C27D4409C2B4BA2
-03562D24B7CC0673A418CF7154223DC0A33C14BA727F933A3EB79D733989B8D9
-1650C80D000AD687C621815F97BF3936F345299E091780E2FC41A5A9C7B3BACD
-FB387668552FBFB4349969DF50C872E6B68A9225D93C9E99CD45651A4F7F14DD
-39325CCC810E9BD130304EC955B77487D6E8421FA595A435E5FF94EB5E554091
-0C6FB1BD43595956B60EC0C2BADF5B6E6F6894F9FA424F27E360DF3734432A26
-4D5F0313AB2083260FBD3089BEEE2954958E26ED66E6CD33851547387DD4EAAC
-F67A799276E7553582F026888A211905D8819A4DCB94E790ECEEEB9DBC59D7F3
-26E2EE2D807141EC6985F9A06A4502C17DDF5C30BF6C041AE06A65DEB90A10D0
-8DB0E7F103F6CB2AE59DC15D90E07A5B8AFAF0D0616F0356384F98DF14277E2B
-E5346527AAEC53241A8A75DE57462B07AB66B65A5E32C50802A63787DEDC11EB
-7B4DB77C1D7D2B8A8E243673ADC49015FEF371165F7B80C3ECFA27197C348461
-B557238658C982CB79316444473BD0D6A6377A857927E95C5ED1BBF15F10E01D
-BDC81168FBBC0CB0B80FC52F96A0749DE0032A98CFFD07FC87F7FF502ABBF42E
-D8E17B15E8176E1C1A412A09A090AB1978EEF87AD1D642664366BF66F2E27549
-9C57A4FAD1706288C15D5064FBC41571CD40A917DAAE9D6E702E06CD571E3F35
-DCBFAA38766144B6AEA738E1957364B377B279E3EC3D86B45192F269A9808053
-5A1D9030881CAB3E49BFC8D0B2B9E32B6E34E8575F99AD1CEFC95CBBA1F84765
-70D1FF704C5538C695137C33D8D8D12958E1EDF33C06BA29AEC48103A58A40DE
-3282DA394CF50564DEBEF65950C8F48EE15E6CF09E67BCE1F3E4B6802DFD6A49
-6E7C232522A1282EBD18DD435828DBF49CB47C3CBA4C22EFC4C0C6C32571FFC4
-5FE7C8350E3F662A9E9B9722B0B12C95D744B8AF9003B4E0AE2985E3FB5A1EC8
-C6FFA30AB743F3014B00A2B118324D4DA7550142415CA907900C7BE231B25820
-CB77BA35FFDDE59F5C471AEDE6DA6C593281717B13C16E2BD13F9F1DA578542D
-3FDF611C8EAB1CBC05F4FF1F9960782E20400EC6663A3CE1E3AC0A662377E1B0
-2B8C9C1B700ADD1DBD47FA92E352A2E05007BC3A63799C9999BE7E1329A04589
-B987AEF12A7F2E492790C562B525DFD71677A9EA4A1073C0645ECA99666FEAF6
-A616B09B5851724023EB1E2C57151BD76583584A9409CF908D79EA0715484DC8
-4C36760E6DF51498895FF7722F7A4BD5F421D392FD718F7F022C57D1887CF71B
-F3B4DB96B39F36EA45B4E9B975C564AEADBD4E176F1C09A9E30400BFF45D8B54
-CD17CB0AD6C964DDD88426214A5E9FFFC9D4370EABE92782F965BDDD29543C1C
-5FC76D0F1FC58CE31A8986D9969B7D1956399363BA0EA21D49D96B95E9139755
-5A191B888AC0691664336BE30AD1B5B36F9FAD51D87A58C66FDD1D4ABAB456F7
-501B473F2513FAE32A6EB3470FB376465DB51E07EA3CFD5F5D3B626543F77250
-0055C749BBEA77F01C25109468FFC084674727E1AD1EEE6CC954711604CE18F3
-A767AE2D7C7D3B22D3923546EB534403EC5503FD776574152C8A9C94A6963B4C
-33642551840F72127F0F95A35231F503B82DF052B6842A1B323C836E4044751B
-054ADE6FB2B12D97361F8EF61658557B918961B1F280CF219EADA7209C8D53DE
-08CDF5F9346B94213E2C252BB8FB6E41C0EBC6A8CC2A655F6664FD726DD1AEF1
-F35F945B6D0E6D12F5BFAB56401C3A3EF5B517DF4EDFE9809F3A7653608CE9E3
-86E64A6CA2E3F3EF443566D9E3ECF57788263974C4D30C293D30FEF892D04BC2
-7BA499429EE65BF324A27FD7296EF15672722DE881E3F28C162769E1933B26D0
-03C0C68B0822C4A0716524ED716C3F472B4FE1D68872692F213E12E5A814A86B
-0786E84D7E67D8656177BFB9DE038BEB0144C06893D1E9073799C3ABC971B114
-A6AACEFB49B803B8404BCDBEA4C311F33791FE7A9A68BCF89042F03CDA3D9308
-53AF26137B38FB577270BE2F4A28AC519C543F0D411F759E3B77F4BE00FA8942
-F63B58BD1B772517CC35D9254BF91F961F34B3EDBB4AF399A28EB73B79FF6855
-9D1315D665A4288DADD3CBB1BBBAB67297AE13DD7B33A038EBA4A02821E850EF
-E0445C7E9B1B5B7FDE3638AEEE84B2D78DB60F024BE8A1549B4C498D5352AA29
-F18C5E5F534FBE75AB4D8A52A8C480D5806D195F59F8EE71638EE18EE43EDECD
-A01799B385A25324751A862E0B8F88349DD81A62F36C54705535D2175373A1A5
-C36303A3EDBD9634FBE0F904E483CD829FF81624A81D83AADD93D0D74AFC5938
-07FA18BAA73C8365BD5903AF760DCFDD230B86A0F5E54E1DA5C8F675BB8E08EE
-C4AC868DFC68C6D869CF64AC576989E764CAC35D8D4DA97B2B939783BFC90B77
-0BDD64D37BB40B8F0038E79AD70884D723FC305217DC2F9F1A3122CD8F8365D1
-A71B693F7638B0A18DA5F1F4973C6E721B3DFDB35A3B98126E51FA1B857B36C7
-437F1870A82698E16A756B17092D34F9F765AF66F033FC2F310DDEF2AC20F63E
-B263C169420ED4021D8FD60E4D7F1E4D3856C73475977B8392F34D7AFF85A29C
-071F972E3769880C8D837ED9801E7A03274CF3299DCDBD5D5C41BA6517DFD887
-607B9FD77A8C7BF5804C8B20EE80A5168D5F6EF14C119AFDA9560DDA451C83A1
-0CCE9CEA04875B4455AFC759E4FED5F09DA14BB26DF9C8390EE02D32EBD460C5
-0C19267575149D475E45DA7A7D08AD7544FC526515DDE9E1BE34170FDDFB8FFA
-EBC922AA6360B0395BC79CA28E4F70E5C1236CBC51228A5EA30B7E70C8A262D2
-50304BD72F4834B7739E41215CDCF3112910C5D32B2E54A0CC1C314D02FF0A91
-7C41
-0000000000000000000000000000000000000000000000000000000000000000
-0000000000000000000000000000000000000000000000000000000000000000
-0000000000000000000000000000000000000000000000000000000000000000
-0000000000000000000000000000000000000000000000000000000000000000
-0000000000000000000000000000000000000000000000000000000000000000
-0000000000000000000000000000000000000000000000000000000000000000
-0000000000000000000000000000000000000000000000000000000000000000
-0000000000000000000000000000000000000000000000000000000000000000
-cleartomark
-%%EndFont
-%%BeginFont: CMR6
-%!PS-AdobeFont-1.1: CMR6 1.0
-%%CreationDate: 1991 Aug 20 16:39:02
-% Copyright (C) 1997 American Mathematical Society. All Rights Reserved.
-11 dict begin
-/FontInfo 7 dict dup begin
-/version (1.0) readonly def
-/Notice (Copyright (C) 1997 American Mathematical Society. All Rights Reserved) readonly def
-/FullName (CMR6) readonly def
-/FamilyName (Computer Modern) readonly def
-/Weight (Medium) readonly def
-/ItalicAngle 0 def
-/isFixedPitch false def
-end readonly def
-/FontName /CMR6 def
-/PaintType 0 def
-/FontType 1 def
-/FontMatrix [0.001 0 0 0.001 0 0] readonly def
-/Encoding 256 array
-0 1 255 {1 index exch /.notdef put} for
-dup 48 /zero put
-dup 49 /one put
-dup 50 /two put
-dup 51 /three put
-dup 52 /four put
-dup 53 /five put
-dup 54 /six put
-dup 55 /seven put
-dup 56 /eight put
-dup 57 /nine put
-readonly def
-/FontBBox{-20 -250 1193 750}readonly def
-currentdict end
-currentfile eexec
-D9D66F633B846A97B686A97E45A3D0AA052A014267B7904EB3C0D3BD0B83D891
-016CA6CA4B712ADEB258FAAB9A130EE605E61F77FC1B738ABC7C51CD46EF8171
-9098D5FEE67660E69A7AB91B58F29A4D79E57022F783EB0FBBB6D4F4EC35014F
-D2DECBA99459A4C59DF0C6EBA150284454E707DC2100C15B76B4C19B84363758
-469A6C558785B226332152109871A9883487DD7710949204DDCF837E6A8708B8
-2BDBF16FBC7512FAA308A093FE5CF4E9D2405B169CD5365D6ECED5D768D66D6C
-68618B8C482B341F8CA38E9BB9BAFCFAAD9C2F3FD033B62690986ED43D9C9361
-3645B82392D5CAE11A7CB49D7E2E82DCD485CBA17D1AFFF95F4224CF7ECEE45C
-BFB7C8C77C22A01C345078D28D3ECBF804CDC2FE5025FA0D05CCC5EFC0C4F87E
-CBED13DDDF8F34E404F471C6DD2E43331D73E89BBC71E7BF889F6293793FEF5A
-C9DD3792F032E37A364C70914843F7AA314413D022AE3238730B420A7E9D0CF5
-D0E24F501451F9CDECE10AF7E14FF15C4F12F3FCA47DD9CD3C7AEA8D1551017D
-23131C09ED104C052054520268A4FA3C6338BA6CF14C3DE3BAF2EA35296EE3D8
-D6496277E11DFF6076FE64C8A8C3419FA774473D63223FFA41CBAE609C3D976B
-93DFB4079ADC7C4EF07303F93808DDA9F651F61BCCF79555059A44CBAF84A711
-6D98083CEF58230D54AD486C74C4A257FC703ACF918219D0A597A5F680B606E4
-EF94ADF8BF91A5096A806DB64EC96636A98397D22A74932EB7346A9C4B5EE953
-CB3C80AA634BFC28AA938C704BDA8DC4D13551CCFE2B2784BE8BF54502EBA9AF
-D49B79237B9C56310550BC30E9108BB06EAC755D6AA4E688EFE2A0AAB17F20FE
-00CD0BFF1B9CB6BDA0FA3A29A3117388B6686657A150CE6421FD5D420F4F7FB5
-B0DAA1BA19D638676E9CF159AC7325EF17B9F74E082BEF75E10A31C7011C0FFA
-99B797CE549B5C45238DD0FADD6B99D233AC69282DF0D91EA2DBD08CE0083904
-A6D968D5AE3BD159D01BDFF42D16111BC0A517C66B43972080D9DD4F3B9AE7FB
-11B035CE715C1218B2D779761D8D7E9DEBE277531BD58F313EBD27E33BEF9DC5
-50C7821A8BBC3B9FDF899D7EAA0B94493B97AFEAC503EB5ED7A7AB65763C9AE4
-247C7C9B60444EFCA66AB8108DF1085D4F3D758CA672BC89FD250646AAFC9585
-F7F8583BEF48D4A97DCEAABEB778FDFC2AC2789D6F4E1F0D9237205E6210893F
-77BC26458D7CB35B844DE20BC63A4057AEDA379413FB28B0C7C9A6AAC97CEB9D
-5F712AB7B25A697092C13D2042A04EA2FB36836E425CB0C97A9F30C6758FD6F5
-2E4A4AFF054C14C7507A4D90B76F44A240D2709F26814A24C405E59D5109948F
-87A93BFABAFE124C8D58EDF774E060F599847C6DA5E7349BBD7791505BA1AA41
-C047310EA5BE5555F3908ABC457CF1E806AE9D9ED134577DA0DCAA9120B78425
-571445724A1D1BE4A49A88C16F64C3E73CE74A68CE9F413A0186BF50527E3378
-0BDC374D6775CD1A60D04A2936D6613D91023157B2277815D3EACBBD0F5EC49B
-E10FB601A820B3FBFDE967AE881960711947F2C00DF744E3E29D6783D3F10D95
-0140A5B62877AA3A89794368D3866910416393C21EB2C8D48B36A3175ED20B45
-D3389ECE0C0FD0B8219CC0FE131BCADF70835C1ECF5B3B45D25467E7035313D4
-C9D0DA39FEA7F03DD763174C09C7F59D83D484E2C8151DB2A52428C5EA3A0649
-0AE2EA79DE5DC679CF978D3CE71BA42811E1DE2CADA4FD5618AAB6CA11976402
-57E5F5448863B4B0123088E8B1C22853F731BA9797197646BD327D873769B322
-12479C1813D4DEB5E9C7CFE623DC65CC67B381FD18537BD381FE8B0EB0E65407
-D5C970329E61082E5BC69152FE91373CB3773CA987742586E6ED8C3016011724
-E3F5266ACC8161A3E60B779F99C62483289B8F5FAB2A65A2B3EF026F50521673
-94318A800C2BADBE0F256E2B0B1BB9DB90996B17E39E5732E0932EE71D94AFA8
-6B5B0E5DAE5C3DE55A167544D9F315D7DA1DC1DE8B00E14164B941F136801A81
-FDBA98CA9A96D881EE331F4B45FF396B54F7BDF32408863D62F39AABCB5B45DB
-5E1DFB417F9E79FA062244A32D847C0CE041A90A2375EA44ED95DFD6A7BE97A4
-69A896ACA2A8F3D1838AE43D8315F69DEA5DDFDB068CC94C5B0890474075E320
-A5EDFB9E13A5060BD2C45E855F51AEF305CA576A9785324F98652B3340F6858C
-0F936ACC0280DEBC3084E0C3BEA789D8E5CF803B7D72F2E96AD34D947DAFC787
-806C936F0F9D8C7C8C7AF64EBB2EBAD3A97DC56A775279BFE6FE5A17209A5DD7
-BA86A542B70E8AEEE4B53A6A7E389709156BD02E37648648A8C4E6366A255D4F
-B6D33EB9F9A7E96AEFA0E9D68268C3A5A1A8CEC390A244C6CB8F210C608F51B7
-769E52259B2EFBF44DE98ADA262AF6132C829EDE71A0883DC517E14DC0312DB3
-10899A3662CF88797DDE4BE8507121E7EE58D83F0761A5F9DFE463637560BE31
-EA5E7931C115F68D02EE832D60E974D5BB0F6025D28E24058E8E3CEE6B45156A
-70B4C4DB0C784FC5D4A95959C6C71C70233E3EBB696E813A2AE3CB830D6D07E7
-4F790752D9E8E6BD41C3EA514EFF1ACA2DD8D1111BE62A17120A17A6BF806CF0
-9E8FB18AFCBDBF67B15E4D45A3688E4A7108380FD6DE1491CDB932A7A8CBA1C1
-5D6770AEE80289FA6D6CF1460C151A78147DCFE4CF3A0A91BD7A14091CC7BA0B
-87F2E10493A80BC1E88A382088CA09806D7324018B3C832C984EAF9E801F08CB
-AB1EABE8C8A6E14AF293B5776C6F75CCDEA7F25431F902A1247CF5A101BAA8AF
-846E3366916058BAD88CD99BE5369D7CC3B143CDC0E48DA50BD130997962726E
-D50E227D7171951F42C60857453E6574084AFFC583423E902277E7F86BCC93F1
-C7A8CE812F89B20FD8FBED0005CFE83303F61369405336DF24CC15745443E9AD
-8B49D9F29798735EF6892E925C254400DA606C657DE585088692AE468276EEC8
-4544F24C068ADBAE403BB7D643AB02A289097A3E87E464D1E2DB0E7885AE8B96
-44C08FC42CE55281BC901F194CF9FC24755DB18845D8FFE03F70A9A2D70C7097
-46B7CA5F10AAE098D99DFEC165BA71A67381F49D1F09BEEC2C0348A290C1A1EF
-298DC0B5931CEE66FB6836A3C7A09CA9D8B37043478539426F6269EAC21F5ED5
-59AB35645218CDE8946FD4468608D539E0AFC73812F41C6AB6508CB796B50483
-C268C21A06BEA059D0EE331836A4E242E243439655BF0EEB18E45E6DF5BD75D3
-1B5E0112FF2080818146214D1A6F1CF66F2FAB4A4A975B99FE8282FB68D29032
-EA0AA51B2810F66E0B72A8CEC2BAA30E88AEA22B3A30EE6C66A1DF6D4273EF6A
-FA09EC1CA0BE4E156FBCD5029381E0368F42E466B2078639AE281C31F5B282C6
-6F621D7371113AB536EFC242766FAC1696D1902CC514E8444D8C977FEB555E82
-32C08EEEAF5A8820E4341EDCC6E98AB6F0EF6EA5F5CD18D1922FDD273C61ABA3
-1AE8EF4874E27B005CE5D1308EC915999E62E44638BCB9116A69A202392A8463
-CD263C86FDB8E0CF5E25CAFFD32F824F9475232A27862EF2723B84B35DBB0627
-37579F19E21253433D9BF96F4C8841331190F924CBAE983DFB9728B0B896879B
-DE3A0D087C1E16BC93D734757D327C31866CE6B15DD65EC169CC2B9C5FEEE538
-E5B8FFBFD3BE85FDFDFCA09EA4491C539D79D4F7
-0000000000000000000000000000000000000000000000000000000000000000
-0000000000000000000000000000000000000000000000000000000000000000
-0000000000000000000000000000000000000000000000000000000000000000
-0000000000000000000000000000000000000000000000000000000000000000
-0000000000000000000000000000000000000000000000000000000000000000
-0000000000000000000000000000000000000000000000000000000000000000
-0000000000000000000000000000000000000000000000000000000000000000
-0000000000000000000000000000000000000000000000000000000000000000
-cleartomark
-%%EndFont
-%%BeginFont: CMR8
-%!PS-AdobeFont-1.1: CMR8 1.0
-%%CreationDate: 1991 Aug 20 16:39:40
-% Copyright (C) 1997 American Mathematical Society. All Rights Reserved.
-11 dict begin
-/FontInfo 7 dict dup begin
-/version (1.0) readonly def
-/Notice (Copyright (C) 1997 American Mathematical Society. All Rights Reserved) readonly def
-/FullName (CMR8) readonly def
-/FamilyName (Computer Modern) readonly def
-/Weight (Medium) readonly def
-/ItalicAngle 0 def
-/isFixedPitch false def
-end readonly def
-/FontName /CMR8 def
-/PaintType 0 def
-/FontType 1 def
-/FontMatrix [0.001 0 0 0.001 0 0] readonly def
-/Encoding 256 array
-0 1 255 {1 index exch /.notdef put} for
-dup 48 /zero put
-dup 49 /one put
-dup 50 /two put
-dup 51 /three put
-dup 52 /four put
-dup 53 /five put
-dup 54 /six put
-dup 55 /seven put
-dup 56 /eight put
-dup 57 /nine put
-readonly def
-/FontBBox{-36 -250 1070 750}readonly def
-currentdict end
-currentfile eexec
-D9D66F633B846A97B686A97E45A3D0AA052A014267B7904EB3C0D3BD0B83D891
-016CA6CA4B712ADEB258FAAB9A130EE605E61F77FC1B738ABC7C51CD46EF8171
-9098D5FEE67660E69A7AB91B58F29A4D79E57022F783EB0FBBB6D4F4EC35014F
-D2DECBA99459A4C59DF0C6EBA150284454E707DC2100C15B76B4C19B84363758
-469A6C558785B226332152109871A9883487DD7710949204DDCF837E6A8708B8
-2BDBF16FBC7512FAA308A093FE5CF4E9D2405B169CD5365D6ECED5D768D66D6C
-68618B8C482B341F8CA38E9BB9BAFCFAAD9C2F3FD033B62690986ED43D9C9361
-3645B82392D5CAE11A7CB49D7E2E82DCD485CBA1772CE422BB1D7283AD675B65
-48A7EA0069A883EC1DAA3E1F9ECE7586D6CF0A128CD557C7E5D7AA3EA97EBAD3
-9619D1BFCF4A6D64768741EDEA0A5B0EFBBF347CDCBE2E03D756967A16B613DB
-0FC45FA2A3312E0C46A5FD0466AB097C58FFEEC40601B8395E52775D0AFCD7DB
-8AB317333110531E5C44A4CB4B5ACD571A1A60960B15E450948A5EEA14DD330F
-EA209265DB8E1A1FC80DCD3860323FD26C113B041A88C88A21655878680A4466
-FA10403D24BB97152A49B842C180E4D258C9D48F21D057782D90623116830BA3
-9902B3C5F2F2DD01433B0D7099C07DBDE268D0FFED5169BCD03D48B2F058AD62
-D8678C626DC7A3F352152C99BA963EF95F8AD11DB8B0D351210A17E4C2C55AD8
-9EB64172935D3C20A398F3EEEEC31551966A7438EF3FEE422C6D4E05337620D5
-ACC7B52BED984BFAAD36EF9D20748B05D07BE4414A63975125D272FAD83F76E6
-10FFF8363014BE526D580873C5A42B70FA911EC7B86905F13AFE55EB0273F582
-83158793B8CC296B8DE1DCCF1250FD57CB0E035C7EDA3B0092ED940D37A05493
-2EC54E09B984FCA4AB7D2EA182BCF1263AA244B07EC0EA901C077A059F709F30
-4384CB5FA748F2054FAD9A7A43D4EA427918BD414F766531136B60C3477C6632
-BEFE3897B58C19276A301926C2AEF2756B367319772C9B201C49B4D935A8267B
-041D6F1783B6AEA4DAC4F5B3507D7032AA640AAB12E343A4E9BDCF419C04A721
-3888B25AF4E293AACED9A6BDC78E61DA1C424C6503CC1885F762BADD50DF87A0
-8B6D1BA96CC415579DE9A26786F37C6F37C57E20559A06FBDDAFB7A0421BE3AF
-ED947D999B9B6FCFD973D2A9CFFB2C38CD1F4E83DE081288F2654E747F7E7BE5
-32FF02074DF581DB456CDD381D834EF577A7DC94FFABD35019230545DF24B281
-3C57DEDE6580DFF703681287F31B62A0DF73E0E08FE3E8D4F3BC58079DF85A2F
-9D66DE46A9D3F8F289BD78DD2641DF574F334704A570AC88AD21D0EDA5E7660A
-5ADE393595DB983117680F836913355EAA0C6DBBCED2E7568D988462897B5EB7
-F32692135C9C6ED6E12978DDA350CB2BA64D433A908E31F61761C23FBF18DD4F
-987FA6D14562DDEC9623FE5480255072140CE23ADDC4B0E867FA871B5D1CD62A
-0E07EB4CD8067A363DB0FA8E9A81109A1028A076A716CCEA3D569950E2683B60
-D0E5EB6611DA3DD784FE69E0425E19731170E3FD55E533C4D2D9932B5CC8CE59
-D641D0116334D2360F7A8681ADBB014895484FBDFD0B903E8E15DCB4C5207445
-1AD1EAFF6D9EF7EFD9883B95A6F179D2B108CCA419643B31658A4755658130FE
-E210089026EBFE95DF621F381F7236E4A407F8298A30E5F704C28A1C5F64FBC3
-9991B88BD657CEAD53805B2F61F2264DC7159572C18E5537886145C22574845A
-9A616E5D4C2613192073481EA165A94547E0337ECCEE93ADE0281A913C9B4045
-C3165427682AE888369D9BE2A3333232979FFEE701652CCD553F4909D0A99FC9
-C8C851B968ADBB92C8550384651FC30FD010251D792EBDF4BCE1E241AFEC6B67
-EDC73EECA0BA12DD9A22937CACC49F0AFD3CD7E032C248F70D2D338CBC6E9B34
-205C184BD86663C972E37D05E01137415E2F27F6AA774530FC05BB3DF616356D
-4FD973B3B74C43EBD83CAB8E9F72D1B4278350321E4894587B458BA313029168
-AC14916C7FD5788B4E4A675081CE6046FEA28ABAEFD1ED7C577BB74F66F5D8B2
-2F355DECC234EAB0DF594B9C9F11A3415DC4734AD1E43CB4311C8DB693F2ED84
-C70A36215C4D146DD4DF54FAF65B8C7A2B93498B4A74BE58B40778E4A881DC38
-D180B995251CC4A6AC8C8979536212CF023C0EDA692DDCE760D3A12C108DD40B
-C86B0A2300B94E7AD95EDEEA99AE3A034F21E98FBFA2E31621DB4BEF674CBFD3
-1FD6102118844C29CC3CEDB9A9BB2EA82C5E43934A7BBE72980855283C3BC562
-11292ECCF4805B390FC29C3A5C526D4B365ABAECCD0B5D4C71CEB495B455D836
-548AFE038A03F581390C5AD5814F6E395DAADB1B3E93BE91AEC7BF5CF9220A6A
-91DFED453CB4013B89FBE39B32CEBFD4BF498FDB985407ABBBA84784FBA1EB9A
-41B2B9BEE5865DDC8658920D96B6C26BAD0A67EC5940E5C34A8069B1D31695B2
-C7095A0A5C74A733436960E3F1FFEF9DAB3CFB3842F2BAC3D6498652D3CCD618
-8336FDED8A3FBC5A0B01013E06B10208B94A5BACD939B91A9251F8EFCD0A8970
-A7D19A1CED133D1BD4A1FCC33C0F11E3490B80DDF8471C1BD826ADC77894C7D4
-E69C826EAB793FA6C1C942E9FBFC416213A66B19710A34239758CF055D6C4E31
-39DF5B49A21E433E299C6E03E290CB2BAD44EED9D20C0B39FF6B0AC8D1D8D1CC
-28196F69A3FE2FD78A65DE47387363CB633080D42048FA14A7656346EE34F2B7
-2472024F755C094803EF3AF917C4D7FC183DFCF1D72D73B3BE40BBDF63E621D5
-A07A6FF8C5C5D1946FB877AF00585D260CEC0051128927F0E68FF4743BC2C5C4
-7AE2F82CD28D717E155CD2B8E0880948EAE84A3CCE30B01E8445834FB3D3062E
-CD7E6E84C549D73F735141DCB74390924EF902F7E053BB7C65403B96B8AAA827
-EA8FFF133A6310BEF8EB5EC3F9FF7881EE687E31DCB5749B41933BBE086AADF0
-877FAA01AA390061EFD315FCC44BC099FB6EBAA35070B8A12BD44D474201D42F
-C0C0577AC0AE21FD682D9A50C71CBB8FD5DEFE37AA50B2D69EAB483FE64A7BE1
-920137441DB5EBCBE4D0A1CB7E06B31282DB73B910E33C628EC5267DCE7723FA
-456259380153BA68A817869C62F315C4BC750E47060A0B467455E72C872003E0
-F6E0C3B4023424950373514C099D10AB46348B0CFA3488269451B10CD072DD61
-1FABCA5E1A488917BA120F9207EF7F3E07B473497A77A0043925E52BA328C105
-6D8B680EB5C7648602BE3CAD4C37CD9617C17EA141AAD191CA7FCD23A6C473DE
-9F4B38D38E0909B3C5969F6B592E35ECC11618FE0B8A7DBC2D8A5585DCF4FD20
-47D07DBF38A9439CBD3D17FDE6AACE7C5D2F9F2881D6E3E92A4B51A42E4415AF
-E3784D7921DEEAF969C8BBDD1EB0499A88CEC7C4B098C32FB32C8B95E9C3FF6D
-97269D5D5A1098AC4AB4EAB8839C3AB34521A16203C42550373AEC6A18AFA4F7
-E15946EFB23467C26C09ECFC832B1084414F20D39123FA77522CCEAA63F11857
-D69CEEB988FE3B57C2A5781FC235F72248C628631D9C9BE8AE25E34FE8E3629D
-82EFEAF0BEAF6F237052E4B398AD1AA82CA20EBDC707C3DCBA9450AD2D8BF9BA
-220B4EC5CCA2E03F82555CA52232656942752E80C50A2A339AEAE834010819AD
-E40B332499E2E32DB9EDB7C65964CB10532FCFC0BDF028B0
-0000000000000000000000000000000000000000000000000000000000000000
-0000000000000000000000000000000000000000000000000000000000000000
-0000000000000000000000000000000000000000000000000000000000000000
-0000000000000000000000000000000000000000000000000000000000000000
-0000000000000000000000000000000000000000000000000000000000000000
-0000000000000000000000000000000000000000000000000000000000000000
-0000000000000000000000000000000000000000000000000000000000000000
-0000000000000000000000000000000000000000000000000000000000000000
-cleartomark
-%%EndFont
-%%BeginFont: CMR10
-%!PS-AdobeFont-1.1: CMR10 1.00B
-%%CreationDate: 1992 Feb 19 19:54:52
-% Copyright (C) 1997 American Mathematical Society. All Rights Reserved.
-11 dict begin
-/FontInfo 7 dict dup begin
-/version (1.00B) readonly def
-/Notice (Copyright (C) 1997 American Mathematical Society. All Rights Reserved) readonly def
-/FullName (CMR10) readonly def
-/FamilyName (Computer Modern) readonly def
-/Weight (Medium) readonly def
-/ItalicAngle 0 def
-/isFixedPitch false def
-end readonly def
-/FontName /CMR10 def
-/PaintType 0 def
-/FontType 1 def
-/FontMatrix [0.001 0 0 0.001 0 0] readonly def
-/Encoding 256 array
-0 1 255 {1 index exch /.notdef put} for
-dup 6 /Sigma put
-dup 11 /ff put
-dup 12 /fi put
-dup 13 /fl put
-dup 34 /quotedblright put
-dup 35 /numbersign put
-dup 39 /quoteright put
-dup 40 /parenleft put
-dup 41 /parenright put
-dup 42 /asterisk put
-dup 43 /plus put
-dup 44 /comma put
-dup 45 /hyphen put
-dup 46 /period put
-dup 47 /slash put
-dup 48 /zero put
-dup 49 /one put
-dup 50 /two put
-dup 51 /three put
-dup 52 /four put
-dup 53 /five put
-dup 54 /six put
-dup 55 /seven put
-dup 56 /eight put
-dup 57 /nine put
-dup 58 /colon put
-dup 59 /semicolon put
-dup 61 /equal put
-dup 65 /A put
-dup 66 /B put
-dup 67 /C put
-dup 68 /D put
-dup 69 /E put
-dup 70 /F put
-dup 71 /G put
-dup 72 /H put
-dup 73 /I put
-dup 74 /J put
-dup 75 /K put
-dup 76 /L put
-dup 77 /M put
-dup 78 /N put
-dup 79 /O put
-dup 80 /P put
-dup 81 /Q put
-dup 82 /R put
-dup 83 /S put
-dup 84 /T put
-dup 85 /U put
-dup 86 /V put
-dup 87 /W put
-dup 88 /X put
-dup 89 /Y put
-dup 90 /Z put
-dup 91 /bracketleft put
-dup 92 /quotedblleft put
-dup 93 /bracketright put
-dup 96 /quoteleft put
-dup 97 /a put
-dup 98 /b put
-dup 99 /c put
-dup 100 /d put
-dup 101 /e put
-dup 102 /f put
-dup 103 /g put
-dup 104 /h put
-dup 105 /i put
-dup 106 /j put
-dup 107 /k put
-dup 108 /l put
-dup 109 /m put
-dup 110 /n put
-dup 111 /o put
-dup 112 /p put
-dup 113 /q put
-dup 114 /r put
-dup 115 /s put
-dup 116 /t put
-dup 117 /u put
-dup 118 /v put
-dup 119 /w put
-dup 120 /x put
-dup 121 /y put
-dup 122 /z put
-dup 123 /endash put
-readonly def
-/FontBBox{-251 -250 1009 969}readonly def
-currentdict end
-currentfile eexec
-D9D66F633B846A97B686A97E45A3D0AA052A014267B7904EB3C0D3BD0B83D891
-016CA6CA4B712ADEB258FAAB9A130EE605E61F77FC1B738ABC7C51CD46EF8171
-9098D5FEE67660E69A7AB91B58F29A4D79E57022F783EB0FBBB6D4F4EC35014F
-D2DECBA99459A4C59DF0C6EBA150284454E707DC2100C15B76B4C19B84363758
-469A6C558785B226332152109871A9883487DD7710949204DDCF837E6A8708B8
-2BDBF16FBC7512FAA308A093FE5CF7158F1163BC1F3352E22A1452E73FECA8A4
-87100FB1FFC4C8AF409B2067537220E605DA0852CA49839E1386AF9D7A1A455F
-D1F017CE45884D76EF2CB9BC5821FD25365DDEA6E45F332B5F68A44AD8A530F0
-92A36FAC8D27F9087AFEEA2096F839A2BC4B937F24E080EF7C0F9374A18D565C
-295A05210DB96A23175AC59A9BD0147A310EF49C551A417E0A22703F94FF7B75
-409A5D417DA6730A69E310FA6A4229FC7E4F620B0FC4C63C50E99E179EB51E4C
-4BC45217722F1E8E40F1E1428E792EAFE05C5A50D38C52114DFCD24D54027CBF
-2512DD116F0463DE4052A7AD53B641A27E81E481947884CE35661B49153FA19E
-0A2A860C7B61558671303DE6AE06A80E4E450E17067676E6BBB42A9A24ACBC3E
-B0CA7B7A3BFEA84FED39CCFB6D545BB2BCC49E5E16976407AB9D94556CD4F008
-24EF579B6800B6DC3AAF840B3FC6822872368E3B4274DD06CA36AF8F6346C11B
-43C772CC242F3B212C4BD7018D71A1A74C9A94ED0093A5FB6557F4E0751047AF
-D72098ECA301B8AE68110F983796E581F106144951DF5B750432A230FDA3B575
-5A38B5E7972AABC12306A01A99FCF8189D71B8DBF49550BAEA9CF1B97CBFC7CC
-96498ECC938B1A1710B670657DE923A659DB8757147B140A48067328E7E3F9C3
-7D1888B284904301450CE0BC15EEEA00E48CCD6388F3FC3BEFD8D9C400015B65
-0F2F536D035626B1FF0A69D732C7A1836D635C30C06BED4327737029E5BA5830
-B9E88A4024C3326AD2F34F47B54739B48825AD6699F7D117EA4C4AEC4440BF6D
-AA0099DEFD326235965C63647921828BF269ECC87A2B1C8CAD6C78B6E561B007
-97BE2BC7CA32B4534075F6491BE959D1F635463E71679E527F4F456F774B2AF8
-FEF3D8C63B2F8B99FE0F73BA44B3CF15A613471EA3C7A1CD783D3EB41F4ACEE5
-20759B6A4C4466E2D80EF7C7866BAD06E5DF0434D2C607FC82C9EBD4D8902EE4
-0A7617C3AEACCB7CCE00319D0677AA6DB7E0250B51908F90A32C4175B6BFB279
-024EAE1B04D721A6C54FD62484F8949B2CE9B87D9CEE04DFF82BF14931B3CA03
-AA5F701B6F80BBCDF2C427C40A51597F0B1BFA25EDD7CE0EAF2EC676BF0059B7
-15DD5462BA30DE78A08DD533DC0E8D85F9DAFC5FD842F417265427E0F1B71834
-D2BF6EFAC3CCC40D3EF3B2E2080F148441BA45E5D0C0F7D8416730AF4BE4FC93
-1E965594E0364F0D4F1EC48004CEBDDAFB1F0EE0A8222358EAC0F62E6BFA3C9F
-46875EB4C999219B91E6147A49A668505667030CDF3495682B79C0F614AAEE68
-D976EFCDCB04127C0D7325A2211E49CD316935A0B472D1F9FFC68F7FBEBC7582
-036CB393016193A9783DD08D647E89C5BA4EFC8701BCCB6A5C027C4FA8644C06
-251B9E33FFEBB1B84AC4D4B148205C8CA7AF5EF97F2788EFB0B71473AD0F5EB4
-FC43F46602C53E53F5A6D1E445439F65967C51EAB636178FA377DB2DDE5FEF41
-9E91F3BEBCFBD3B4EBB510A0DF7F4D19C6552BC98F10E25612B1396020D7836F
-A3D3C865661DB276E428F09F048A916B4F07D8FD01AC1942A3CA342B0E531BF2
-3E9A7AF265ACE1585E331A8F8B5AE06FF085C1F349215581FC7D68D16395D934
-79B3BD866A4BF33913DEB54B4D00ED5EFF3313FBD1C5E6AC430567872BD935F2
-AF1A3F892266CEAC15DEF43BCB83DB075A69EAD7D2EA53303F65E04C5673411D
-EDFB32156120099AC210E623BADDF2991F96813AFBC1126DF53A0A776AF7D61A
-6B42225A5AAC1B0AFDDB59C5922143A156EED76E3E1ED01ECC6ED9F61B5711DC
-C5709EF5A3CED45628AC1728DFE98F07389777E04A7E407E3B007017C96F6EE7
-D0FCC0426C4D734A0B108FD2BEB48FFB6D107C5AB8EBC3584F13A40E5508AD9D
-5A081286BFCE1D5DAF5F3D86515244B4D0D77AF9820A93B7C90420FF4B8D634C
-2C5697E3E04802E2CD7B9AB8368F1A9DC214CF893AFC7BA3A8DC24B0E549E106
-F04530708DD03367D8501655B1501645F17E547C1C948DEA7A4814F22E2A1D55
-5AF16C55D6BB4EE9929C9CEE82C4D6A16D70D17AFBBC6551BB2C9D8B69F5DAE2
-5DF6C2187ACEB119EE6087BAF5E79340D115C53E710CC7E4C771F43ADE91D2E1
-1AEF7BB2E6C9ABED010A835514EEB6C9A2C93396FA12E8CD0B2F9045587E51D2
-7E059224A889B3E7620E57AB6CACFD769898B3955661824DD4AFCB9A7B218DF9
-F84B369F52E246723C7D0B26C145DA0AF81C83DAA091143FBBBD2A414114E34C
-7C994D8401119D5A46856367EE3FBBBB32155A00E5314641288A6E1FCE47F385
-71C2F7A7602F777C11884DEFEFA560333458DD227E63F3FE68A762CAB0A7308A
-FC59C9B293233DFA257E5D10BD5F12B7652C45C4C50F14F17E59A758BD7355EE
-A89B1EC954B86642B87F814F936577429C467BC8E97A481ED15E2633AD73830B
-DDE3DE50E1EC439204C7FE350C69494823725920719D613907163AD63FE83C6D
-1CB6DA81A6C816C747542CA09493306B44A7DCE934B877DD356F38D07D3E0355
-CB149BE6ED646E84DB9DB61859F6FC45BCE13EE42458D1991AC34AAE6EA72320
-3EC6346C38CA87107618ED3C46C331623D8FAACC6CF9292B8F1B407806A0D480
-8F51A5BC97F6B592F50E6FB89017FEA216E7D909A6ED818080A5F897162ADB21
-457E5604917EA038B54B01A9A8BD87EAC0EE1359CF393C09BD9266EA6F30059F
-566A33A1109559393953DF8DE857F8F4A83C2C8211628B531B9F365178D26D2A
-75E9E134DDEA354BD94133154F81AF8A474814039BD531A56B914AA3A4CBF23E
-9879A8DCB614E04303B838476C233AAC81D0F6920BCA07749A0CD30CCE9CF81A
-C7F3F62D5D49E2EADF96D35390489EE719952AF58BA5AE78DA996469677D5A56
-4531F0A159BFF37338BE0E64CB3B10C4A088E63694EF84F55C7537CB32CE0BE5
-ABE9B751EC06B5AC8F7227F2615D9DFCA22395312C1EDCFF460485E54995E011
-6F38F33C1986BB7BA8BD7C48937548974C7E964A7E0921DF781BCA556E811C7A
-7B56BF6085CEBC73931E073F182F723717F2FBF8708AAA1E4B69152011CA7DEC
-A52535FEC2AE2B5AF921D0BD28983FDA9533444930217766190C415F7C2C2AAF
-77868472818BEFEDC5B30D2852811DC0FC50BDFED4A09777E7586556F0A67E64
-E6B2A18B1184E62A5E05167AF397C0B584104F83C7B4E9C409471110702D5FCD
-C1B988038FB3E7CF8EFF153608C3DBE81A286B9434F67ABA7D4690C5C41ED1DE
-B7E71F32E454961C88B7E1757CD736DF756F9155175CCB580A6634086775A3CE
-61EFC38F37580B71C1C83E17F65A5F8974A0CF9ED9F76F818CA31E56891BD78D
-5EC25A9F50C7725EFC1D5ACEAB6CD909943874ECC4DFD117A7C6F5B07FF1838D
-94A543F432F843DD5B6C77EE053BE73F2E3334BA6B615BD478C892CAC1B80B7C
-61695E2087167D41E834D808C12AF04D2750FB63EA896968C36372E729DC2D13
-C62F0D44272AACD7BFA3C6D55B53118C799C40EDB77C49F0E0A2582206825D6C
-F556B8AD57DFEB441E93A756A4E4468A82F79A0A4FEB4A4F13108BC14CDAF4D3
-DF5ADFF5877C7003EA8177962C3B4AE4A1B0AFBEA66D58AB823D13E90CBF8678
-AB14DB59C7865BD555B4556C6F35C1E30A6F017DAC032A33E8E24C62BAA9444C
-1FCCCD5C74AAAF1175C3158FA587E337CFA68B64C543A381DE9057E12B88F70E
-2E1540CDA8FADAEBCDFB0EADDFB0B5CCA3BC23F755D15A1DAB24294E4D12270C
-103C4C81EBAF282E55CBF75C63C552AFE07E2626F93C373BD4CC30B4A9D87726
-271B24C15ED67355AAED8CC4B31479F17F8C596FADB61C6FC2A207C182C75E24
-F9BAF5020743D564A99EF034F26AF3C259DCE54E5486B8304A168D3F9141A659
-A5007BAE3F23B5BC4CD33E34252E8E97A0CE1D44B6DEDF2910232A81C6616006
-BE3FEEF19F51F6506C6085025863BB06C27E59EA233445CF86CAF222DA8E6676
-21FCC932E74827CC46556DF30B6E8D81C0183094BFCE91E2AA4888A57365485F
-85AC3784B90738CAEE60A56C8F437BEB21F92F3C6DCB2BDD2B376E618D79C3AA
-F72240DFB9D090D5BDF5FC43ECDBD222BAA6510FD744834358E30F3D08AE7060
-3D96C5595851E4A3AAA29F80B2CEA228DC2CF87F3A5403F783601FB2A26CA34E
-C2B6DBC569A723D332F0B6D2065884472C29372A50006DF98ED6D0C4D5BB5341
-6CB8C3C00C9ED760EF48D210AB36C452337FB3ACF6E2178EB05127B6C7F77E7A
-AB4795302DD4A6E07717000F056F1500CBF5157CF3FADAB24A5BC70B94294097
-EFB71CBC3F942AF4AFBE6D6C06D0915B1E6D19A4FA3970BC922AAE8FCCC05169
-5D8CF56964579CCB70B7C66F5DBD3D39AD4649CC2AE4B7F7FC32C42C0B078DB3
-D85CD57E39F0DA41A932C1E5D5CE703CAF9C9E4BFFE00230CB8E7E0C29481950
-15B1A14E1A6F1713B9362A87B40ADA4BAA80E962FBD14CDD464D1C02E9679F90
-4132E8AB70002996C2E31A25345F1A700244ECAEB6CF9DB48D35785E693AB659
-991C810CD2535D173EEF08D7EE6A6BC4DEDBD1E9C7B470AC4F293E45769645AF
-6963115F1A6B24D5E38163FEC115991DC9CC8669C80129323ED5A3BD87552216
-A3741FE0833C47F0E2B98C8749BB314751328F1DF29FF13227D392564F25BA89
-CCF7CD0E29125D0F9BE0384AE39CA3004D2AC9152854E78F820503959F48340B
-183FE4B499407973B5063B1B75DFCCCCDE384189B358C7CA2951C8E896490F23
-11748E537315DC2F8842FA57604BB83A5749BE2415F172D25A50B489A6AD5730
-1CC69AAC36791099B01E0478D1A28A081FC2AA4A943A8C77341A7630D9525695
-D5EAEC7AE44C29A16796C5185D2CC48A89AD049F890E1C09B2E21AC8CF7E10B0
-42F43CFA13416F2FE631D071C979B2DAEA5B3A79EB0B1F2D7A3F6F924E4B22E1
-013BF6C9BD1585D63B6C457672934E2A2C47E977F5F3F9DBEF0DF13C7E866DC0
-A501190D177443B5152669322A539D3C308A748E5FE1561384941532A7AC8A83
-58624BC20F5FD722B400A7FF7FD0D33789FE76F34FF712C20BA407FAE695C3F7
-817683099A0DD642A948906F5F11ABB08690A3A370349AF5AA945A149D7CF66F
-A08024EA5E9308F0CAF9B2CA4C5E6ABDF0561EF958B719F38631CFC14E79396A
-2C3D33F6D4502CD774734F2657A277C02954C0F621D0C960A835412310E65A19
-9DDC695BD5AC7C66F2D2663B9318E84DDC035EE72C3591A34EDA7398D2A0D455
-355673529F351EFF96D6E794045EEAC1245F7760131FE13A69CD46AAA99CAFF1
-CF4EB12E9DD9994E2D14E203303344B2BCD9E77B5F8801BD6378A3495A1BEC0A
-9E1FBD8CB8C583C6AF487AFF1702FAB9B69B3B19016F89463AC295AF39735095
-C7AB3D9F43B0FB521F7DCD59F2560D0538C5FC18172FF00025DB3C8373FE129B
-EB10478DE414876FBCCD665CB694318159CFEA804628E33176071AB2D14F45E4
-926BAEA7503ABF426D510A62BC17DA6CD35AB50682F29B1E6457C90A844315AE
-3C982C3F0D7FF19FC690B9E18B62A5F490143A2FD3C23D766C0C01AE62EE5A5B
-9CA4F92BE26805C50EFAE0FCADCA36A1B586A0D5AF2D7AEB88A6FB0AF199B720
-13B6B32B79AA3EDDC9435B6CC87B3A657D89468BDABEBD2DF6CABB2413CA87C0
-8F4E8029465238F71B833F11237B36BC9730488AD8830EBCEC6B57C955EF9E48
-D44727CC37D4E55B9A7418AF9139E18E3D28B709D6B7AAE83208F2CBB3B116D2
-75FED758C67A5B02FE755F08CB1795BAC9DA6960F25651E447BE66044C539410
-96969361AA3A3E98FBBD0D063C73323D8FDFF23955A29A375F8599174BA5F4B3
-F3A1ADB4F6F07376C7BA3371EC9E29309EC6471ABFD3A3059C0FA47CDF89E4CA
-60E5BBE8A1C4A9B5DA536CF62D0381679E8B827732A4132ABC4280B310803C53
-9C31DB4C4544798B0CE46D8F54DBFBDC28CFE03CB7FE7180FE3056285FC87596
-C50EDDD28A73288E550E9CB4230703270A81CB466CBB6DCF4D96AA0270812B1A
-B364A29687C6644EB753E92112CCD81484E1A96A53BACFB90B6089DF9EECC6D3
-858AB1F8475122E8DB3762A46E316FD0346E11ADDABD12AF720EA5341373DA38
-A72D0C91BF1572E099D9AFBE14D7A3BDE14C4D5DAF1A8CA502B011262FDC34C3
-66AAE048A19F9583010DC8FE2604F7EF8992204DF5A45FF6C9C4E366DB952D17
-B5142DBB1E39D958D9DAD6A8481431A329CC7DDCC62E014AC52A9324D0923BE7
-8E0BBE3655ABB59B7092B3D967E3557202DA9822B07DF89F1684AEB27F8958C4
-5223EC5D41F05CF8AA16FFB3842F01C559FAD0A42D441E52AF72AFDCBF90BC62
-B3B204E0E3B56A4EBE97DE4A2DDA2A9ABCC33F2A4BD31BB806B1B50F112D5FE0
-D25C79F2DDBDA3EC77FD3ECF7C5C114FAF4144FF9231D93219CA42A932C17788
-3A2D31418184BFE2F565DB3B519BA743DAFB120D0F20718F5C38B89D159150DD
-600099BECCE701DD31DCD3D9530027DF3357426F3CC3037F8841027EB6EE277A
-93BAC1F216F3896D04431E38D3D23AFD63F38BFD49E6593AA349D4251F9AC9C5
-C55329406914853F3871995221A8F6D4BD8F9D113A18A2B044457A32AA4278FA
-2D1252D377CD2EF9AECA7553E4317A019F4E8BBEB3CC71E0173FFA551B26AB95
-F4D7C579E6D87CD9AB43AA617DACA5D3B5ABECDED57B6B3A997D29C2051F6CF1
-ADFB3D5913E68ED0E5B87D1042D03C6059FF97A14D1FF8D24B5A573927B469ED
-FD92F1CEA154D2DDC553C835B68DE02AD512603731A49441DF0561F9EAD21B5C
-EF08DD5C28458C87EA5FA0371244043D4FAD96BF687681E2FA3814D3AE727A6E
-6018E9FB26CC68FB3FF4E3204D3F3C87439D4FFDF17F9F3AE2A5A061A82D906B
-C02548DA48842F51A0CD12D58F915D1294F4D46FC5BBB4874E96D86D6DD0179A
-A3FEBDC085EE36CCCBA9575281A929EB6E2941A1232037096B84E0B585849C45
-0961EA9C617FDFBF6B9876E62B2E9A881941866285CC520CE50A5B22EE1B7E92
-541952AFB5AD93FD2ACF3EA5695D19C6594E404B8746D3948EF1A40F5C9DAE07
-83D6E5A3DB0510E79BAAFD6D5CDA3ED6DB7433CCEF361422DAEAF36F5FEB9CA0
-075655FE5B53FD93B905C6907043082DAD53E0743EE75CEEE7A6862E3B24DB44
-795BF9F64ECCA8075E21C820F3E793B43554C1368C3E4D80C207F4D3AAE01D03
-D734C8A062A0A85A88AE3B70E9050B8210E42751BEBFA270E35F2172C515E9C5
-C3DA9E42F4B9EEE8C0BBF715EA8DA45F7E533201961E8E0965E1C213574FB573
-8A25D9EE832E9D6A0DD0D005C833735951F8156B2FF742D8455247731BCD012D
-FB7043FC60DA4FA8FCDDFB9F840273992E013AC2D24C0DD4800102CFDE8A3708
-7423EB4249ED49474D1A9D38CE3B6EB21E7F415DEFDF403BCD5EFB2A2B6098EA
-F167DBDF601FFD50AC5EEEC672B29392567052590727C6CB0D3561F6770244B8
-115783C59F4852CBBC76DBA9AF87F8935D59A63C49CFE440BA71EAB4B3DEB68F
-5459A25710DE083F1E0D375D4EA423D2FC7DBBCC8D155FC8AC98E8945A5249BF
-D8717A83765E4944FDFA27146745C9730FC73ED9B4D28C9700C76312CF347E3C
-87D7800C3EE5D39D2B6D06A78AA2A2F958B19008A25CEF6E3BDF2D962C69300A
-0CBE0DBD0FAB04AF0098CA2F8D07773E391C2E6D5D75EB755AE79FF0543270CE
-B2288BECECA47C5D6E48957303A3C29ACB16A957120B5B7807E3DF78150FB2F7
-5043588EE6695458DAE6EB7D02125F3A31D822788F20BA69926EB72C7D4F5563
-CF94E193FD164B0AE0CD1F7894F003A3505CEEC338CB731741855A68B435FE04
-32E1D5686FA4D89F32AB00B66F4AE1A6FBFD63B40F8C2928895706FD973C79DC
-A55229B28915AF4BCAEE35A54F535B35398B8983E5FBD073A3F8F38528E46D6D
-8E9859E010F762709F87BB9DB337BE48F0D1FB8EC74531201A84BB7EBA1A454F
-F3334AC09D65715E90D8438693C650721919108398F824B1C943564D5596946E
-595644F0A2BBE3EEED86D2A3D27CEDC8094ACFE9EAC4F952C7C8DBEA4B6DBD43
-656A682A6BD9D4BA07F0E2A4F07C989F092B8B101A4E51ED8D2E6D563ED9362E
-547165895C710AEE883BFFC20C9BBAEC06476CA367902552C88FA6EBFE1B1B96
-F0C79263F8403DE8A8CF4F5E58264A83A45460D91C6591321A25455BEF59E327
-440E91DC524D671963B2AE7DC6FE4BD79F2DB779683544A8E1576C0EE957D00C
-6F11F1E21F08DDA9ECA708DB8F3E2DD63A24B79887337AAFEBDEDBE9693CBD53
-B70853B7B3F4471C3D20F1DA3CC2BB0EA483499783ACBC2F997D9FE46846C0D4
-084FF94B9C53160F01E7C1BF68B6DCC948AF4E0AEA323FB5F1E96668C669FA42
-2D7D7DFE22DDAA60A2F8F3D19A89797104F8DF40304162CF2D36A93B8C891495
-BF437FFEE4C4F5DEBD413F03F556CB017DD970F03DF2E5980793E0D7162C4AED
-F7C26BEFCA1E4539C3AF3DDF2A3CE4DCE2AAA8B8CD4A844CC253B2905DA7B2F6
-FBD5937AE2D11DE014C62E052E30ACC15347CB13FCF878265672992EB9D2D82E
-20751455F350372B6578767EDE8536DD44DE9CC3E3471F747231F0BC760CCD73
-44002A982B7479649A658DE286B041A7A93392D3A86914F0E0477F9400C9D711
-9C663F377DF8E4C1711798C5AB38F739F592403C605197F93CFA672619982CEB
-07AEAB8DE454685211A7FE0FE62976A46023A5A66F1B03BBCB84937F3D63E807
-9C50390E1ECDB8F8673F7A4561AE209E9B9B39D8EE59ACEC682BFDCE68BD9CD0
-B7FA74EEEBC3D88145DCD8C814F20EE0BB86E4EC791BB9D9B33F9715FC27B15B
-DE1803AFB3FC1A4089518F6535E3B7B584541D205C7CBA843F535F67BC38E25E
-755FB27DEF61812EB559FF246EC4427BBF7568F862C92558FD42728E603D5C2E
-6058CA9FCC33832B0466D6A4F8488B5A95DFE4D9370A10684C4A5826E2DF86B7
-BA574358C03C1119F16C8561129EA0E7B573E9736AE32DBC4D92A9B91F35B368
-B475616EAEFD1E2058CC51EA3B0AB791C2F58246AE9BC2D63D4192ED979F2300
-C46620C3B52A6BDE847E5969CB5BA8A97244B758EF14EE1075FEBC0F5DC618FD
-EF250A8E402BDE1572AC49DE3FC807C8C30BACE1F1F89FFDCD64B2F3C8908ED2
-31DCEA2E8169804F987675F2CC22CEEFD36EF688444FB49EA88E5345E819670E
-17586202F75FCDEF95F52EA86FA199E1A557EA63D0C71C34D1C424CC71535D63
-90A07ADE5D754F2146091637C82A2FF56572C5E5F0C5BE8E0E1123CA4942CB51
-F3710090E4D2BC7FC3E67665BE2AB5AFBC5C8F2B03481EA371484B640A6F1736
-02FBEF6B1362CD097D8F212E662229052B318384E63F3465364DE37A2C926482
-C8055EEDFF0DD3DDCE562995480D30CFC26FD864EF6B530784C6B44C7CFDA274
-297FB676D46F5DA8BE9DBD36C6A7153B0C1DF27086C2EE811BFECE34D499CFCC
-006A9610C445508814A9E6489FFFCF63E9D6D337F7FE514C5D7719BA1A2CEB11
-28F3153672A71A43F2EE11D7A869048077CEF97FDD366829AB39BA18294E7536
-D3445043E3DC9894049856E3D33C7F388E52D43D54EACE6F0A0BCF16F4265488
-069E83E1D777B5CDE28B9037F16AACE7B0B9E13741DE971ACC1873FD8056818B
-73F61AA057F40AA22727B5374FAA94F2A13BBF6657FF1AA004FC10BDC80AFECC
-827E6ED3EB47FFE7BAB6303472E2900CCD7E15F139715A38B94732A25F0B5065
-E1FF507F5DFB673A38862C27B31E74690BA47EDB0D0529D3E7028D50A61C1702
-E3B15EAE6D8DC21F692297741BB8972B191C6BF57D930B6DB8BAAE0306FA348A
-3B13AE54D56C8A16EBB03F9F8697EC6D4E31E42C129EB10AE4E388804F56E412
-C8999D339DA2094291DFAB7579FF4526D590EC49B5DA95353A114A92C5DECB9F
-CE15418901018EC604074B99140972B4021AC3CFAA009DD0AD2A2DAF2838F111
-3B64A0E630BBC4AFE5CA7D59B93984ACB4F62E421ED93AC6958DF20AA126F118
-14C5C8ECE3BCBF962432D7E796859F9A3A0B1CF749998B7B7C058F4F7F7CC9D8
-576BF0BA3A5CE2ECF4134341335E914F926A6E386B684EE24F143D0FC00FAD16
-72C67D9B9B3146E4000DABB9E17B197335730082FF7368C360C325D7BCB6D3C0
-D30039C2B79CD03F0A9A8C55086A3194B5A2134C3018D347BCD3D32CF6595FC6
-BDD39486BFA58DE31962DBC835D31F6D1129037727CF77BA577FB64D89BE85AE
-A2B55E8237C5818105FD516E6740A37F1E68BA96CD1F50A4290A5AD1A98DA118
-4A5C54A9A7AC5B8C7AF679F04C6D18405ED4D77A697AEC7A54F36C561E928A99
-9D1D923B5C268F9E51D3AB6C80501046909278CFAFDA131ED02C7EEF3EA411D7
-C0CEC9C92C8AB5303BDE183855494E91251471233CBF31231A3FB59A2D629F20
-CD6A19416FB6AD3DBC74A1685C7E63F9CEA6E4693E383CBE29F72CBE4A462ED7
-64259607F9FA4CF73EE28DBA5B157EF0092AC1B8C586065212C9995528597A7C
-012BA0245172E318D8FFEB8448E4BF5F1473A74A5636C2C64439955A7994207B
-3BA38B3CC9A8FFE33BA3E8500368F46F5E500DF386F9EBEF60BA445BB31437F5
-AD54D2B27E1ED055C47FE4D066486E3CCC971364BD8A4D3CBE42AB8B3C4F97AF
-45AA19F4C3B53C02CABABAFCAD8B4FDA4BD1897631326A8F4712458E37E6456F
-247B5BB31F428785E93AF98C34F992DCC2FEFF63EFACFEE15D06C68BA1460F76
-AE287DF6AA9F661E8D358279D3E2D7F2460D8BE185383CE8911E9583E83F2E7B
-CD3A291DA2C7E98FC89E52437ED5A2DEBEBE28B7E7D71895FF3083F6454ED582
-35B8C330C67193DDFD4DE07C6C0512E9C1722B51B648C37C567E0C3EF121E3AC
-70294DB3035A2A2D4110A97794BA791621E7A2A54DAA02AEE816CFE450EE055A
-5A578134946CD59612A4CB5424F9353E0DA13E788BB71C67E800F4326F283FAE
-1751D049C2106A77108DEEBB8E42BA91438F896C0E7360057FB1B0F2EBB4AAD1
-6CD6DECD33C7B1A240F24ECB84D86528CA112D44035AA430243FE05051607AAA
-48D182CCCA65CAC42776DC74448CF2F792C24BC099FB676118CB2A34F8B0DA67
-13ED020AAE5CB40710B1D71DEA58746D3C3BBD523C6843652C4C635E72838664
-D2DC01E669B57E1002DE945A3FDDC6FF739CF0E7B506450EC482BD62A02F298A
-1C5AC5CEE94E2632EE07C07B19C3A00D666369E6B95D1D9BB2DF47C844EFF0B7
-77A1497B9F42B5B9C39A8897E4B477ECBB9185062B1A54FDA1B6F23BC530F7C3
-AA70394F410EEF21EA41EB58515F1D43CE299C560231F26B37078A771C9071F8
-1F2302C187B15F7FB7F27A945347FEF2C49FAC274C443EF0685B68266DCFC81C
-B0FC66BF04D1F44D5B29461A3E43443569541A8AACD12C91D1F7E77184D7FA71
-853291D68FB32975FE2438D2E15D710AB133F3E708BCCE41281567F9873FC4B2
-9D4537D5A019D777A9212DCE011E682FFD8B65C6B0D2C5377BEC918F643AD087
-C4EF29CA7D35A0A669758B60CEB08430DF27896BF6676CF1DCB2751A894D455B
-8DD624BA42585B6B628A6740B8C40058A4BC5116B22C98E94CDB8E175C562ECE
-E28D3FAD4FBCBA98F2F66B0178B55495037F62CF560C8E77050BC7DA73B52EB8
-F626A197F55FB665A19B591541D6411FEEF0C2B9449FDD528C1AA0CDD0E90C0A
-126C1CE25F78FF172C28386F23A5F13C056B9A2F2EC9C4AE2891BBC2370978F4
-7DB5FD17DFDC5A9BB6EB21FA0425BB26F7F0559489A4E01DF09E957CD2C591A6
-01E9075803F4D4B9CB536AE8B80BACB5A2708ECC13554DAD32CF12CBBE2B8F7A
-AFA3F51595AA8B25878517FC54630C85C8681F2F987E1FE4FF69D9B08CEB6CAE
-31A732DC431030D3B66E1211A8E528AD86CD6AEF60724F4C35CB808644F1E8A4
-FBAE87DC82E11C6BBBDAD2086FC49DEB5F98D17BC4405EBA7CD94A15DCF93ADF
-4513E83A83265317F10E67806426D81990AC0B75A5314A254CC1BFE835622C22
-3C284445D5DA1A33AE978AFF4B45A59AE4A7B95E18830C650F0C5C0C601F0854
-834563AC82B3612FD10C5F2250C67AAD7A3152EAAFD1D618CFD517A42E088D12
-930904D75EDD3C99D2E11B48871F38477F5438996717AA58E4857A7951AAD389
-AF0E30AAC0D6F2570951B0D3C97529A4F62A81106CDD4C2F9944BB3516808DEE
-D2B00EF1C2FD3947ACC68B98136AE2C000202BE99D1548C9230A6C5302D46C85
-B6AE3304B7026983FB94130794C78148B2BAB7F2194DAABD24BB938A9944ECF2
-77DFB8F99B1F524710922B62059DCC0935F32DE2FA6184EF3475081FE6DC5C2B
-80FF98EFC6AB126EF030B0F490EE00EED09B711837B6D8636B270B8994CF4849
-8EB06E16A1AC952BD188DDDE196DD3186894197422A54CBA2745FFC7C4BBE7F4
-41B5856090667816FB2F12D534728A74C7D5DC9D321C0BBFD0DFA25158E00D57
-3B22A3E57A195BDFE045C963701B5489D14C2211E589DAA2D77F38C81B397EA7
-916ECA1603E487AE3B9BC5F84166EE911AC4351B0CD89231FD3C1D4F4D0BA77D
-13A2242DD919E3DB22BCD7D181CC25C75B0D759A18A0566C2D628E52A5695A54
-C76D6E616F262EBA587A9CA8F9C9B5D620FDA2B9074A499241A202D4261154FC
-5B6DCD5A624B109AE9E79F087BB5501B8A1D1271F0156A108F3BB91821A49523
-3923DED030C9E8AD88AE30198D0A949C81FA4E649BE5FDEE54E1EA013E4B1D1F
-575D4A861A3D2CB2597AF2C4753CB420555AABB757A015411EF8C5C0CAB06D20
-8BEF12178ECBE799A401D941BAA52B78F35BA4CBB50420624ED15BE8FE8A955A
-F805C2D8551BEF1463E6CA8B8BBD7DC6F74F42AE0977EA0BBC7E6DA1EED53213
-79E99939E1FEA729E8BD7D9F750A8D57BD88889356C830E8D069F9AB4FD5DAF0
-2428F7278DB863547B05C1977AA7196F9C93BA46F2C310A22ABDF29CFBD229C0
-D074CBA318FC7941EE51F459FA2D5C475CF1915A7F382A318CE4153F187F8DD6
-AA293AE3974EADAD0B603ED36A8CC0E52260A96532C1E35A2DD99659808537B1
-E0167ED71545BF702A21CA165AAE80D563A40E1FBEF6E961A287A868F988B8EC
-AFCC46C9BF7D2A056499CE06D09578AB26DFE19A40B015425A10AE9F6CF64408
-BF5A1F4722607F8A0D1A6D2195836C3C605C9D08A6A0ADE0E20AD544C4C7A840
-160A32D0EC83F6FAE61A50828A0FE4EE7A57D223ED6A71F3C53E6B29A7ADFCF1
-2D66E9AEB9AC20242ABFC5288E231D064166E5F212F2C881746172492090E317
-91B6AC3224A687749875AFDDFABEAE9D81607B801ACEE1797951AA5372AF8256
-CE9E8953297E5341929B88CC42AC77EB3B4F9403C6D2B2D65E12A12C4EEFE299
-FCC327A0A4C7B4DA593D6A7230654E3C7E400A8C7CA712114F0A7DD3AC92D005
-AF569066DFD6DAC9D3064C84EE4D0B7B4876B843CFCF453E7DEE56EC80390D72
-6787F121B7205A8DBC8C3769C802ABF5BC82334B725E5B9C40F4E660A42AAFCE
-81AFF32F0645E0C5D04FF78184D0F1DC5C02D9E727629C61319B523647063FC0
-96C0DB61B1B51DB210D49BD822EEA1F39A5B2D669A83A001034EE8C908C106E7
-53F2BC6585437540B420B3031A67AB15348F9146F25130672E203F82FB9205AE
-9D2B357CA9BEDE59A0A3D8003CBF2138BBEC76ACFAC6FFE3C3880B74ADF332D2
-A47F02C7E0F2AEC11BE8B16AF1189B5B224A28CAE7AEEF2B6245FF5CC297D3B9
-6AA69957DFCD9DD0D4E056466AA496B751D5A36E5E2AE957ED50F033A53811B5
-6DA206BB726BE95E2DC752DE21F313CBA1DB28528DF290FFC6C7CE51BBDE4971
-EFFCB3440BB70AD9F69FF63583900F5DA21A29A95ACFC84D42A543B0E6F5BB0C
-CBB25E5F82BD6FB07E506337E27973709173B379A1A3604F414C343C4326F0EA
-2F1969E85C4110715190DF3818AC91063986514122106D9B89D06B34E990BDAC
-67AF62588158763BBC01457747704F6BD46CEF2EE63B8A0BF3B0A5560C815D6F
-6812149B6BF5B4897CE0D48B1E3B43D54EC41C286AE8B64E19E794542D6CCBD7
-D1B45819D6967BB11AB7809DBE5816A264838C64FE087AD7610FA5188203F196
-9DC583341DF384C1A4A1B172D3DBBF9767308D3693A419A75AB7CBEAC17EF6B4
-0CFC35D00AF789A5982418054EC05BD7508BDCF71DC7328B84FB5CFAB78C8D29
-244DB5BA787439D33E42A7581EB8E589533D02CDFF8835ACB27862B0D2547E20
-E0BF2CAAC14C18E50AA97FF77E063C604028EC35B835201E4FDE6BDF15112A82
-F33E96A12FC4010484855DAFD9ED39FB01C314EF11D086D0D17A006E9FAC8A85
-D2CD3351DC1F25A83022D9EE97BE1DC98CFCD8E473991C6A40726F02B1B56997
-FCE9FB2CEB6A38B0A6CA718D55EE3C193A3CD05AB1CEDD6E374B5806F693CCC3
-2C7AB4BE8CCDF85CB6BD4B72E56DAA34C0AB0D2B6CF62A397325D7E4F74DC416
-AE726A775B821A269F2BD82834E86774BAB0E74ECCFCFC0BA75AD0AB44017D2B
-02DC0702F687387063FE179E1873356681589DD8C23F58CF68AFD103DA54F49B
-B7125E964AEDE8138F8C2EE36286EA8A786B3127E93352F85B72BAAEE5DEA381
-ADDD2F5849EE7DEACF754B3A11E35D7D6CC1353205D66238CA5394FC72984472
-66228FB082866170E6AA61E63BA41AFAB8FDC69252D973C86D0CC8FAB8F2D7C3
-1434E6CC274DB24BE00E3E19AF5A221B75F71F870CA62E2F44FD15FD1A71D96F
-546E44BCDC2FF0D5F6DFF07D71DFAA6856EB09F556B73E47EFE34CB9346DBAB8
-852F0C293B82461BC1282C9B98F50CB67545D683F042EB951F58008F91861687
-EB4749E586F2753CBBBFE3DCE401BB9F96D066E3D56BC578C3DD7D0BA3797FC2
-A505185C3F2432C670C22CFB0D389F56DDF2078C900D4D11A0C96846FAB5EB49
-2EA158B493E5E7EEEADE8BA3A5AA98FE623FC0E71E8009E25A24E480339AED62
-97EC30F94CE630B402F6E1424D1B73E68A75E2FD6A9F290ED7E2960DD6987458
-C924D7B3D9C6EACFF87C827B2AD202EFD86AEDD53DB66840E0730C884475C333
-4C8B58E7F9BD355C8BF4D499DCDA09CE3F992291CECDD8A76F5D5C42DE9A15C2
-0B9D3EDEA6B92B4EE29C9458585E057DAE00389D1358D10AD90534A8DF8D2A0D
-E1653DF3050180E80153BB8FD245FC6303359CA16245DAAAA18E577B250FFE96
-557A76E61AA88D03C04AF451B6ED4810471C4618E458D18704F0B7116C2B82B2
-73789D00940F5F072E724251FEA4F51753DDBE126A35E199F3570DE2637F8DD3
-386C838342E0FB36EEC7B100A858F115ACF4F4C2B0351FCCB9962004D7C8BAE3
-96DFDE769FBB128238CFCD13B06B2DEE6C20D5F0B53AC6BCE65E80C5F4F53E34
-3ADC9A504D431A2E0FD72B44CB9FDD862CFDC0D7A9B9CC1E504CE61CBDB44C35
-C0F64042A7F41615AAE4980EC045517B7FBA86BD60C0D56CDEDC19100C8AB4DF
-DF99808094F5EB4009AB0D43EC879CAACC10F2E56C5DB7C8227BC5D5155263E4
-DF03D92474FA070E37816959322C21DA374F556F47A278719A903D0C957498C0
-7721402EDE78AE3367E9FA0811BAA327B64099EA0057AB33C33962951F1F2AE1
-19C50C1482FC65A0DAFF591E6B3B0912060CEE49EB9C69C7DF25A3F2E27295D3
-926ED1F38A63C3A13C1607539DA1CC5342A2E23D5DE46F219765FB8398EEE51C
-D0D0386AB2D10F6D57A9108FC2004E78347E911CD069FAC03B0FEAAEF819407B
-B226D825380625148A6BE3ECE27F8D0710DC864AE7AC4677F7A3FFF9807A2C69
-F6A09945E6802EEB2A2B8B51F79A443C38AA01B363EE4926490A448ACD5EB9BD
-93753134B7B2D198D29FF0AC969A4DA84D44518623E086DF2C4A94A6204D76D5
-EDB990D26B3AB6B5AF7F7608A86E56809C6BF4D29625BE224B87F6DA40C5FE43
-EC4CEBA50AFD0A4AF29BFC336D929083557FC7958365282EB5D53313600E1799
-B8851CCF94A926C8FCE07131E2DBCA6B989DC2EE57A85EA724155419E080A5D5
-F98A79868FCDC48EFB98E3C971204367CC56873EAB4A21875C9DD0C1DE05566A
-5F8F01161D465170D8CD173B47315A180F562BCB68FD3A3B06EDEEF7FAD56867
-AD7759222ABF7041C14C1D60EE0DE4204BDD9886794E18DD1130E1914F615DBC
-7E09EA9AA89760CABC7C4FC24600F825053F50BDB364D7C19D2FC318910D13B3
-D88B4B41ABDA2C3FB158EF1723B63D9AFE5E6D1F5A5BC593829A849EAD0294BF
-D80DF3230AD5B9D3CEABDAECDA15E74C755F36228ADD8A74C8B4845567656A3B
-E6460A20AE9B149FC4C79FE0B5A9CBAFDC2580EC042B8DE568B6CA3BE8B136F2
-1143DFC683396E51BB0BBF2F6B89B2A6BBC7B6286BB872D8AEA256F3FC8A6D35
-F80A505641F3F04B1A8E7A36CCC04F077BFA512ADAA3C059B0DE2706A9D651A7
-76FA8E32EEF5F5E73D34AB6CDEA0011BE91D20A9AE8696F3F789FB414BDA3100
-BB3AF1B85A58744BF5D0A8D2CA9BC55E9A5EC8C161907A179ED947F1482B94F2
-AEC6118959C5341945E322EB535B1544DE3C733863CE2D422B667AC78A4C536A
-8FF2B0AD389D5FA0F26460438B491125BBEE57322E2EF452862298F197732D36
-E5A0F14944065353DB037FD71D5F8BD29A73250266F47C1998CBFA4BBE211359
-5EB3418BCE97900DA2B230A07C65E86E14B2675AD9C3C250251CC6E4C5B4CA76
-23BA9F45431BCA10FC7DADDBE62DA2CD8A89686C321487ED9CA141C3A9802C82
-B32510F4EDAE2A150AFC07722EB6C7B596DBD647C9E58FAE58888073D24D3603
-749684C98118B30740AE6E880757F3F9813C1CBB560A07290CE485ECA3692756
-C2BCDA8053DE796D4D9A1372489C58893BE974248901AC4C1BA79E058EB939B0
-625F52165651C0FE3A05D01D82377BB35A7F93F5CD2B88E333A857A7C5CFD0BF
-0F269C44E7AF63E5EC25A1B694CD51EC9659165A7F7F112AD849BF4102E2CD95
-92757FCCE3196A8090481B92033AC8C1A2AD2A86BF395F102C2E5F4AFAB8CF54
-5B8817DB4A0CD86F66ABC8F0CC92A6E3B5719760D7BC6172DDA5DA3003B23F54
-EFCF61A4ED23AF0FCF832FBC0D9E734F433CC760023D5C1F69A66EBD1E5A9651
-639BD4F45DC4384D2367C2EF3F46B88B88FECD008118E7D7E5259F6C79F47FB5
-069254FE6BD3946642457ADBDF0042DE2A72A0A5BE0A5FE0C2E1C7D50817A71E
-90230C546F1967F16D8722A943FE845AAD9C6F8FCCF969C569B2896E91EEEAB4
-56215706A0737FA4903A5A5849A48911356E8D98321F67648ED8D120026F1AF9
-54A1B53519EAAA8E4E4A387407BDECAFBB4F2A84D3499403CF3094C7D4A897F0
-2199C744D012CF84BEDAB484528B6B62E9D04A045D156A762C6919479858B1EE
-7E0C80A5A2A0A17E365C1469BE48B32B7A43E4E8339A51CF99505E295D3D2053
-6F592E37FD1D31223CD3076E42D803B8EA60E29B5A5F0CD01133633A43A654F2
-2D8A4F8A1500BFE3E3AE88D268B27DDEB71BA158EDDC9C7A874A8B267F330638
-EE35AA443666F12530E3B6844EA082A0691E4A6BB8BCA4AF35EF1AA11AA2DB78
-997CFDEBCA2E529D0A2C136955EB6AF7A03DD8EA39C858D3BB9D5159469EB29F
-7974B764F0C95B9C9C01547414F036F2C73B99A01D5301C4C59859C485330490
-2241D856F16BB9CAEF2B33940E406F30895A909382335FD4DF1F2E5AAE3A0100
-55D915A264D33F8FDD90B473D66EA643DD2F50E93BE7584C07FCDE5233330FC8
-3064E49323FF0160031A77C2C3E22554BF62D6FEC589DEC0E7F79D36AA1849A9
-8841D630848F35AD2CB0BD468F37CBDDBD001F9E6F49B5C4C1C7EC358078FB55
-C463C9C532272F46E5A9FEBB2CD8C4CAB1F5BE04D6A14CFD0F1210C1E10B808D
-681C58FDAE908EACE0984DAF52D29E91D39254AA8C92E1183F6A3F0706C762A0
-3D85AF69D7E79A006F992419EDE523505F435229FDA3101829CE52A36DB79D97
-48F2377225151FF656A7D74896B799C41F2FDB30EF3BD92C874FD396AEA34146
-4F71399462CBFF35EB7B5E614B77D06222B0988F640B2CD1065154F56C12C7F6
-49A938BD18392BF64A0611164680DC59FC4E166A860DB8A10BA86420A89A5D93
-306BEFF9648CD149A2F77E1EE47E9EB2E0BF3500F19538AD862A322A73ABFFF6
-782CDE41DF98A31B9DFF2EC05702D1D4638C25C4615808B825378C39BE8D2917
-D18580FAF9CDEAB92FE09195E72D394556756283704F9A82EA3608CD23DCFBFE
-F8EB10B5780A4EDFE391A65CD3C3126CC54335D9D6B7A9F3D20A6D442715E6D5
-5BE93060D8AA4920FB514BD0A6DA01E433499BC843AEA30752DD49072B7ECD8A
-C463324541070236063644EDFFC5DD7818FB025AB6B1508D49F0A333983DC4B8
-9AE16243893A2378066FA4D55B3C4A855FF8B76708E9B50077A36F282ED2C5E8
-5518866E659A1BF21C132D69AC938C1440D76F0501411CFF09084E36AA9BBDB9
-1F24B8E77A3855D08FC9FB745F1F0D8D54345F105D565DB9DA61D9312CFFA5EC
-57E49EE05F087782CA2AE2FEBC4C04259A5E615FCC0E7A161D2F8B9E768AA7DE
-1C5C17D03064ADA5CFA8D0AFD19D163B0B98C0A82E90DE6CB92861DBF7BC39E3
-41FF17A26A04CEFF813DCDBECA8DCA5402A3C8055AB3F8B4AF50E0FBE3B572A0
-2B8C7FDED8685B4A01E4258075B95EC941D17433E69D39048E3F738018BDFD47
-8614E92019A02855E3A62F64EF36BCF72706986BD7D784DECE6F4828F3BA79E2
-0481E31E87654563071377860BE2725BE48E7EC384CC9C552A994BA81CC93BF6
-B528BE49FFEEBFDC8C613C69E99FF8E286656DA777B1B8B71A8A124FE8569A05
-77E8E77CA6D9ED8C8CCB8ED6C108D28EFD0979AF32F6B7CB7FEC291542411339
-04878B835B171A4C0FF979E088C69E1A89D3EACFDAD479F88451FF35D8AEF6F4
-ECF179439167382A5BE60556BE0F950DFDB0FC0B5B23B46B59F0A8FE3408B862
-C2F63D251CBAF40EA9DE1A6BC5E06EF61881E437F6CBE25E0A8A95998D86A520
-A5017B0B1AE68D4DFBDEF4C464A549DAC450ED4E55838631ADD25BF78F70D9AE
-3279B0D97342A09D3B518EA0CDBD0F46B7DEAF8E7410D17DCDD23C1317960C79
-72D693E53FDED2AB03E7E430B5314501D535298E35A6EABD00CEAED90694694B
-F8D96C7B9C5BACBEEF4CE9A583594625AC4E8A2569521B50C16AD7396A21D7CD
-5181FC6012406EA3D51B9A55187EDAD507F851FD056F454FFB507ACEAD0EC654
-A3CC3B888975189C4061079D5B69F524355183C8BED26C213315F9C01F1FB2CB
-D84BF3E0CCC91E8B5D066F245FC8EC709E760B8879B14C1391C7E6A0623AE26A
-CAC09252144897EADF7E6A96CD4F07CD581DBD7274D491B21CBF1E59E7662CD1
-69C8E41989E49CC21B34DDA246DE41DECC77C75F1CE06D14531C60F2C6FDBB50
-0224304703B3B94FB1E1E32DE4F4D6C1C386FF3AFD34B8CC5D27CFD06BA48DAD
-4868737C533A2A39A64D1D9FF9D6CD5ED02B42CDB257A4A8F58BD9181657D445
-F45D90CC66D84398B54215A7764149C075DE271A1F44447672C401ACE61F4E8D
-673A89A5F58E699F7459EA29FC02C424CEBE8E12AE73511A12373F4FEE785F5D
-328B95C4A74312BECD9500835055EDF8EA492481863294AAE12CEEA8ED3CBD3F
-5242DE1F0BCB6849D3065E3AD24085D09DA56833A3CEE2D605E7ADE264240E21
-0E075D0C44B3DCC0DF1212DC98405E95E973AAEDB92AE2B33456708C1E1E3489
-52668CFA5593EA24B64766098492D09B3C01D357C27A115ABF9198565A321F1E
-F409EEA3FD3E4F45C64B19CADB8B8C086D4788278DD6454132E0AE0DE8A87F2C
-43C367E9C6DC1F9BBE7063FB696832B017A5F55177653CB9B74DF4FC7A62A7C9
-4F04545FE07AA8DDBCD0F93590BA2C3E542BA91D0F67F2B4FDFD215C9C956507
-5F178384C8CABFC6E351522E40ED55F8F2024F40D1FF5A7E5DACC87571D4B62D
-7B8085EACD29A7F589CCD7946736B369821E029710FCB35E4D06F8EE8C2CAE6D
-89721398FDBED731472249A7946E6C07B81B3004C6C4E5BA434B1A799B625285
-1E863B28B920AE927DC7BD3A291FE863868241172AC2FD2CD50C69FA79D3FF16
-77AA98E60B0EFDA2DCB3A1B51851590658905BE5813EF0501F21C9CDE8009EEB
-B21A87F5CCEA49B8EB9FD49CCE8D40BFE6455EA62E61160350C0C61C92E60D72
-D17B6C14A74A2595E458B24879BC8A3A0B9E56832DA8673DA467C33DE10A1010
-8605FECA9CEB05D04FDD82D256F2D480AEB20F990A32A322AC4058D11821F918
-7204E68D10124FD4090A57C6FB92B7E7F2D257068C34E9AF09C79FE96870716D
-C86A4A77C627D8E9523469788B91B979623EE4A9F981995CB2309C83C925B106
-F7DF2CFBBE8A1C5E3C1F60FE03C6BFF1E64071C8D491B4D49F3FAF670DAD3507
-8D799A672E45C1DCC390DA810697E7ED2875C9D495EF88C9525CD0E15C498016
-7254F8C6774618DCBBB073D29F5424ABF46A3B68A75D3D91FEB2B05E0F0EA754
-6C777B7B09A348E08184A1218BD1A0E4E655AAE5EBDDB7AACBD6B2BA1E8B040B
-5E78AEA444C33F013600ED7BADCF27AA89AC51C72477B7A048C3B5BC95AC5736
-40E6A912BC2420C9DEC23CD220C5428C250577EF63399D9E1D17A66A22888F69
-147AADCB3EF973830A0C10E6217A94A0AFC3985CD9240BB0CD9CAE5229615007
-C8272688856D47E7C90D805C1F012664CFF2FE55BE79D57D903E6E9D0C3E1264
-99D785B4F9F41C25598B54D37A5F9D5F7D1F66F063AA452BB8E05BE593B9E961
-AE3199BAACA14FE3D76AD623DAB0109A2D80B46CA6869B12401052BB2217C38C
-D973E4A9FAE77DC28021E214E9696023E679EF05F1CF552D02F30B9D3425F079
-C347FF9C168A081C88E9D9090C48F44F8977E82A15A7196EF753513311539C15
-9121D2323FB228587C3B4041D86924998D61F04A1F0F0AF4528A41B574C753C9
-010975B687863010CD603261E83C76B76C79552DF5EAA4DC506770BD83BAF57C
-AF9354FCD71B8D025C55171C86336248F45F08FB9D79D81EA21ED5AB4F1C8F98
-CC3049FC2066BB468E85CF79611CA0D8BBB052DB5AFDA5534F49F259CAF9F8B3
-909085C17CC89DCD9FC498747E76FB196946D3378F9592A23DFA891A498E6866
-EB43B72700E959581DDC058FB1156B8787FF3C8B2B6DFA9B3928FA0D2B6E8434
-109CBBBC184EDE4A9333B6CB7BAA7DEDACE10E9EA5B461847EBDDB8BF6D9AB0C
-D5213DF776F5289A53DD0C349D09A185CDDF82D355BB1F76975B8A3B6A3516A5
-1537967DC0301B0FF2230290500886FF9BAC713BF819C0B39A406F098B4909C3
-52AACB5EC7D95C0C50AD67FB970F67317E7E74981D22CCA14F866B2363484E59
-D40198DD464574C6548D47E8D72176F3C8F8000A9EDE561549676882B48B2607
-1652E501CB5C566BD0261DA6FDD14C016D07144441A903DF2639E20A2274ECA8
-001AC13E99BE7FFAE58DBD4E66FDC2927B7A1432B1FA6FDB63F5CA7658A92802
-6E289D1F99CCD3BA9442DE57B050C57EC9C7FDD9D33EAC6A7276D0A6172CD696
-30901764330589046D4D7C10238B0346A9921E0464AE6AC69ACD8D3116D2451D
-A25CF4A39C2437FEFBEC68B95D4952A17CD8E1E3EA5833C2B2E12A76B51D7CC7
-4BB6D66CF133F4F4F94C0F66FF83C44BD0C2E9EB06F1812EB2F0E1503571D483
-770396A3FBDA6C35301B8D34C9F009ACB0E3B5FC2BD4012F84A57B
-0000000000000000000000000000000000000000000000000000000000000000
-0000000000000000000000000000000000000000000000000000000000000000
-0000000000000000000000000000000000000000000000000000000000000000
-0000000000000000000000000000000000000000000000000000000000000000
-0000000000000000000000000000000000000000000000000000000000000000
-0000000000000000000000000000000000000000000000000000000000000000
-0000000000000000000000000000000000000000000000000000000000000000
-0000000000000000000000000000000000000000000000000000000000000000
-cleartomark
-%%EndFont
-%%BeginFont: CMR12
-%!PS-AdobeFont-1.1: CMR12 1.0
-%%CreationDate: 1991 Aug 20 16:38:05
-% Copyright (C) 1997 American Mathematical Society. All Rights Reserved.
-11 dict begin
-/FontInfo 7 dict dup begin
-/version (1.0) readonly def
-/Notice (Copyright (C) 1997 American Mathematical Society. All Rights Reserved) readonly def
-/FullName (CMR12) readonly def
-/FamilyName (Computer Modern) readonly def
-/Weight (Medium) readonly def
-/ItalicAngle 0 def
-/isFixedPitch false def
-end readonly def
-/FontName /CMR12 def
-/PaintType 0 def
-/FontType 1 def
-/FontMatrix [0.001 0 0 0.001 0 0] readonly def
-/Encoding 256 array
-0 1 255 {1 index exch /.notdef put} for
-dup 51 /three put
-dup 57 /nine put
-dup 65 /A put
-dup 67 /C put
-dup 71 /G put
-dup 73 /I put
-dup 75 /K put
-dup 76 /L put
-dup 78 /N put
-dup 80 /P put
-dup 83 /S put
-dup 87 /W put
-dup 97 /a put
-dup 99 /c put
-dup 100 /d put
-dup 101 /e put
-dup 102 /f put
-dup 103 /g put
-dup 105 /i put
-dup 107 /k put
-dup 108 /l put
-dup 110 /n put
-dup 111 /o put
-dup 114 /r put
-dup 115 /s put
-dup 116 /t put
-dup 117 /u put
-readonly def
-/FontBBox{-34 -251 988 750}readonly def
-currentdict end
-currentfile eexec
-D9D66F633B846A97B686A97E45A3D0AA052A014267B7904EB3C0D3BD0B83D891
-016CA6CA4B712ADEB258FAAB9A130EE605E61F77FC1B738ABC7C51CD46EF8171
-9098D5FEE67660E69A7AB91B58F29A4D79E57022F783EB0FBBB6D4F4EC35014F
-D2DECBA99459A4C59DF0C6EBA150284454E707DC2100C15B76B4C19B84363758
-469A6C558785B226332152109871A9883487DD7710949204DDCF837E6A8708B8
-2BDBF16FBC7512FAA308A093FE5CF4E9D2405B169CD5365D6ECED5D768D66D6C
-68618B8C482B341F8CA38E9BB9BAFCFAAD9C2F3FD033B62690986ED43D9C9361
-3645B82392D5CAE11A7CB49D7E2E82DCD485CBA04C77322EB2E6A79D73DC194E
-59C120A2DABB9BF72E2CF256DD6EB54EECBA588101ABD933B57CE8A3A0D16B28
-51D7494F73096DF53BDC66BBF896B587DF9643317D5F610CD9088F9849126F23
-DDE030F7B277DD99055C8B119CAE9C99158AC4E150CDFC2C66ED92EBB4CC092A
-AA078CE16247A1335AD332DAA950D20395A7384C33FF72EAA31A5B89766E635F
-45C4C068AD7EE867398F0381B07CB94D29FF097D59FF9961D195A948E3D87C31
-821E9295A56D21875B41988F7A16A1587050C3C71B4E4355BB37F255D6B237CE
-96F25467F70FA19E0F85785FF49068949CCC79F2F8AE57D5F79BB9C5CF5EED5D
-9857B9967D9B96CDCF73D5D65FF75AFABB66734018BAE264597220C89FD17379
-26764A9302D078B4EB0E29178C878FD61007EEA2DDB119AE88C57ECFEF4B71E4
-140A34951DDC3568A84CC92371A789021A103A1A347050FDA6ECF7903F67D213
-1D0C7C474A9053866E9C88E65E6932BA87A73686EAB0019389F84D159809C498
-1E7A30ED942EB211B00DBFF5BCC720F4E276C3339B31B6EABBB078430E6A09BB
-377D3061A20B1EB98796B8607EECBC699445EAA866C38E02DF59F5EDD378303A
-0733B90E7835C0AAF32BA04F1566D8161EA89CD4D14DDB953F8B910BFC8A7F03
-5020F55EF8FC2640ADADA156F6CF8F2EB6610F7EE8874A26CBE7CD154469B9F4
-ED76886B3FB679FFDEB59BB6C55AF7087BA48B75EE2FB374B19BCC421A963E15
-FE05ECAAF9EECDF4B2715010A320102E6F8CCAA342FA11532671CD83D34CCC3F
-DA992BB3D9CB34AA01D8906A7D23ED35750B129B3F77A91A0CB3E17FEABDCD13
-3FAB5219AE262FCB3E8F1088BC3D0A1B39E7DF3FC54F7D738FB23B9D504B0FD7
-3C66F690D80CF2D96ADA6F731BCEE3A5D9DD2868DE969ADB455F9DAD98FD23E4
-13145AC4C6F3ED5786EE9E9134C3A325E3115EC2F1761A2B10B7D5A9FE9137AB
-0E2BA316A1BF681C234301057B97A62D21AA4C5E4B00A4FA69D0502CF90C6FBC
-1083572DF59B07E876EB8AE60CF6952C11FC5A83B28C54C0CD5627AA54103680
-0F3EF5A0654F673490CAC1C0E44E097BC90C47236F4C6F5654C82D0CBD428811
-C7B756DDD6D8AEE0D20428B0385D872CD14B2C7E86BB77905703B8F7A03899EE
-6FEDD0BCF153DD3173B6A769212731AAC873D852636D80671C6A8FB34E42EC23
-6AC9DA1CC1D20540F23E04D1516F4F5C1001F88476D2DB53278FFB554BE35CBC
-AA49142063417AD3A446590AA665AFE84FD111E564B281644D186225D82C03E0
-F3D6E5E4B824CED16A8B02FF6A969AE77E0A5B7C8349E4C155A9BF4549BF9909
-B5DAA97E2C0B6C5302B16BE8AB22CCC269D90D42423693FE69A00AC44D0A8D8F
-893B6314F33B50DCC0C10526FF28A02CF13F64A881B16B23933642B7D515D654
-8704FAF46D52F3BEABE5C0896B1DCA846D94653102940AE4D387167EA8EAFE3F
-B42D714401673FCED5D4EC5351849896FB0879D7799DAD6315CFEED539D757EF
-E8802C140B896F17F20E29C98EA306E7BBAE5075B0680A7A321F54364F02BBEE
-FC909409BF508B3F97761528171E19E14B410DD0B83381FFFC04BC6523CA516D
-6D848112045336E8CD2AEB5288778655005AFAF900EB1EA51E12171C75EE8E99
-182219E051D57E8DE14005CC4E25E1341B7ABE9888B6FE8B4829C0CF7D22E67E
-62944D2FA963F18BDEDF5E4D432E5EB3F658C2D94B1A604A389D1889F0F599C0
-C5C6298E90418582FE409C651EF87D5A475029368A5CCA34E5880DCEB1B215F5
-8A7BD6189B70874D3634F162A55E9968D2C20C921685DC62C60A8133F34AC9FE
-2FEEBFA761BDA29821B5675F4062B2C2DDE1F4CD7480EB9C75C42B1C6A1DCF8E
-5E3D8EE013A404DDD05E26BE752501CB7BC6CFC345B31C260AE95364AC1AD3ED
-FAFB16982A7E0CBA2A079033AE6F3BEC9F949D46B31E1756524BD9416739B521
-EA2C7FC9FDCF0853662EF6E67FB973952F767FBAB395F80743AE8138B19E4B90
-466B333B37558632A42694B0439F05BD6F58BE5E1E7987B71B74295D59346A4F
-4DDCA7BD0C22330AAB64A13B973D37E8FA42635BB6F9525A43DFC6047B7E0854
-3C673C7ED3C7510FFA4523466978645BE955AABDB0D69AE4AF2C15D5196C27C5
-9889194C2568171F6C5B241D9B8101DCF7FECB9E5E6CDAC42D8E204FD4E4A937
-0160B7F22B90FABF5C3300098B474A66D6ACBDB5E6A3428CD8720544C30DFF20
-F335FBE36E5BBC321C9B0C83B3929F070848FB9448E66D57973B730612F12461
-D09B28B302044D563F14B0902DE56352E0AFCA99AA73C45A6281F6B081503F1D
-D55A91173B648C63FEA96982C929B1744E8E8CBFE2E405C7C61D5E9766D06B00
-8D2C1BA33FA58FD2460A634C7BF9D78B79113A0F03288C6BA3B0A9653E1BFBCD
-6D94F7C2A60ACC2C7F4F3CECE39A03CD006C79D32D90AEB978FE1A33D2922E90
-5B9E1CD5926117C90EB44CC2D6B7E6E5B4BAB338D78B792AEE6C5181DEFAEB77
-260D762E33953442CAD13FB4FC98EB34971F4A82B5995CA2F1522BDAA11F4636
-6FFD3C57A621BD55B4D1DFDF01BE9BC1C9BEC714E724DD0F691449077628ADF7
-5A344B7672DB4FDBBC3047169296B5471B9337D782407484CBC4A169BD126D39
-27A352D2A70A0CA346C7B052088C7D5556139D07C27921112A76B3F73D737FC9
-FD874936F2B7A85471900BAA72BF5A15EEE2E8FBD6BC03A14CC95FC1671308D9
-A40FEB441587B22174D24057D6B74DEB8315A96FE9A1B56362052995ADDB0511
-F774ECC99DE0D5907366ADD9490D0D829B891A66AB0DF43EB4C7BADBA6FE14B4
-8F5CADC791ECC3AD9FD36CE3C2E18D91821479442E9A25B0F49F26EA93B48472
-69817C68DEB1CF673684B3A7F19E4F4278F8DC6C41762752501651849A1A4C79
-3F654A074A8A7B2ECFB6D2645FA82E83F5684FE9CDCC73C23E459BB4918FEA86
-377BEC25E87BA33DDBDE26E4B52744C092319D06EFCE73CA71F4999A5F27736D
-BBDF7A0933E23CD89BD803150A2AAFE4C2D1EB37BE903CD212D05AA0BBE60B96
-71E2AC78DE84AA2F2CB818F31AD754A9B3926511C714151714B5C6D726147383
-232486A275C56477EF4C824EFEF161700D7B19E997D3E6F3DD58D7B7A654F678
-24BECCC9AFD45BDB51D25FB973C9C7655FC50C4B585AA98AE1C1F0CA22EE9E42
-D01C738DE4C81EA8FC01DBA83E4C3FCDA3A3CB0F06DA77D734A45A1E31B879C5
-578EF7E979C2101C39B07B825917DCEB492D66FEF14EDB2F43DFF646AC80781E
-8F0A5F771BEF26B53AF15A04B37537CDD649C5FB1166C0774741254FD7AD17EC
-EA740ECCE36447B22E15263F989E5A562BB56C7EE7AA274B9C794BCAF52A96B7
-56A169A0AE49240F161606179493C81A5A086443B882150082BE44D98085123F
-8F51575E9781C1DB9936A7AC869456052F099F2D637F22C61E323836F7E97C15
-46DFE20097A7E8E91AE7F6293AD09DB1808CEF9CA64F81F4EA9FFADAC04CCD2A
-DBD15D2383B3272EC35A867DE5B463685FA39BD2FAD564828E73755A8D4D939C
-B08F951B355A00847EDFEB3B66F40F69EB74574F2CEF725853B9328D075CD4A3
-17CB8D7DA6DF2D5B7EFC4699B88C0032C961017F1308D5E8A9D435A6666D1E2F
-4FD69E44DCA09B6396218A9405ACB232DC7CF00AC93C16D37467EFA53BA6D297
-93C7BA4FE6A35079BBB7E3EA7DD6CC51916B2EFB3E8399CA8D35C9994C7666B7
-042CE345FE8FE45057F6852BFFE743D906BF2CFED715F76E90EE815D86F0126A
-C0889A7BCEEF046F2704327A6E115954BA0801D6CE4628A8B3FB9B1DC49DBE40
-462C29AA5484BC427DAD3E51E5C4308CB283EDC452D8ED4EC54BDF8B5ACF5473
-4C332E8E676E2DA576DFD6F1728382BB13D9B0E1EEDE70A182454FB336FBBC5B
-ED7F43C47269430E1CA32BD99D664E65AA8913A3864C0BCAB8721EEEDBD634AC
-616C9F24B59481024A7C65AC464087AB50E3F8C91B896F354F81DDEF71448852
-39E80C8B95C5E20AAFA9AF27C292A586E40FBA59C6CBECD0242749AE7D457553
-31AADFCFECF5C4959FEB3F0374427BDB66731043170840609F49FE02DA4999E5
-A014E30A25BA3CCC37F36E82E0009A17A2F5208DA4275EC632CB0269EC30E861
-CB2F6EC52B16B2C70C777AB9975672252DF1F0BEF82EF20CF74FECC5D1A3E860
-3BB7A694F0ED72EF02592B7100BCAB82D7C9979160E9A8E422DB511D36096C31
-242F4207AF526155257F6F42CFB378734DA3E4919049C9732ECF976D5B7458ED
-032F6F3F1D94E2B9795668ECE783B6A15EC8D72DCF7A2E062094503EFCD842B3
-A035CD77022F94CD3500188825EC51CB717C4A832C99F8821695F391C27CA192
-90C1BB49A276F77EB91EBA78A19C81AFDBEE0CA81E363520E14C06FEEA641BAF
-D50798F2BD99DDEB697FC2BCC662A65E8021125F7F453796046FAD3A2AAEC66E
-E773B09CD32EED074A2D74128D019C74FA626EBC85A2E78EB8CBBDD7CDFAFFD9
-64660C95B730D94EE2FC88DCCB2B91015EEC832ABBC917E4972F3264A42EA9A6
-36B8EC763CBE0991F4ADEF336A892AEA734D7EE0EC490AD8CCFBE8DE5CCEFE7F
-0A2DEFE25CC46FDF1B2A1F4B0880DD20660347DA8E297A3EECD3DD9B348639DF
-3745EDB87C438D57671B23E3DBDEF70E116F887AF4D55A5907BD205DE839EA5B
-624E47A1E3450F2AB03BE3E7E122CE7C8C9523DE87128A38C3FDF81F847E6C5B
-92C9866F67CE7F745C08C960F5C0F184DAD318F8885032BC6C5D851A6373D788
-2677FA37FBFDC32EB2E42025AFA5CFF502A7BD0CDFD2D2B35165FB19B4F94CA5
-D0CF322F1C5D97AE38846ED366965EF380EA6DB4A20D8CEF5E9C7881C12E3C11
-2114D22BB990D8C69CE60C4EE1DEB26B8F4D0AE4969D2164BEC8104204DC4BD3
-FB7C6039CA91F3D45B51E12B91FCD9A61A53BD11578D6F885726D966D4814B04
-B32E26ECB5E2EFF245012C667B48910B0B1E1D1BDA0E7BBA0DF1577CF687640E
-7BBB3EE607CF8AD864E984494384C070E9E749BD148C2ED78117427819D6727D
-F475F949A8DA67F2CC67D822A7D90A0A5A59732B5BF75CA759CD030A905995E7
-D06405814AD236828B9FA4D7E72F62C3520545618E2C9B429670AAFA9F1509AE
-2BD089441521812FCC1579055F1F7435E9BE7CC7043BAE80B95AEF41D16237B8
-B5D6BD2CC640898AAA4C7E22A463E1852E08DC0FAA1F2567185AF8A0B9280027
-16FD44829ED232157BC951DB6BFA047DEDF96E81B4B25B4AA373ADCF89CA5363
-3307C7DEBE91E43F7C8E86ACC7FDFFA68A3573EC1E2B51CEBAC5E1CCA1A49C39
-96C5443C7277B01F53C7A31AAAFC08A6A5753BE057F05AEBE932F4F272EAB982
-1D12E36E084A514744B906A2F8E6E3C84828F5268B04A5CA7FB0CE7F016B4990
-ABBF3B0E24267ABAF25B5006224D01E5E54454491365E70E40BDF1381BFD6DB2
-955698BC2DE2A02982C65D477B9ABD0AB2BB34CCC4378C3A28C1FA2A5D945AB6
-32D8F315858EA23A5B63595C4FAD923D08A2E9EA04E7A05DA86E029FA9D1D1D0
-9253C84B1E3DC797671C94314ABEA1158C1E84E7D7E00FAFC24E6FEB4EDDC82D
-B4CACDC2690E45508525BE57695F40FAD2E5A9A88046607EFA95C307CCA81FA5
-94AD34430CBA2D0F5B09A98131ABD9931710359EFE849338D8B1D7C1E14F5F91
-99270AEC71AEBCCA8C111639D4704B7B234953171889379C6B8E55138D4E33F5
-CF23EC28ED633AA85E4B2DBD98AA3EA9CE63DA8392144B9E8868AC9537E15501
-C26BA0C7B11B48ECA889A390F9D9E16F015D194DFAFD1EDA1470D2F3C7C972A2
-2FDEB9976D55F4762F3E796E8046B127AB0B6A843A6AC97F8F9CFBF9E4C74634
-4B6D060B8C9C15026FE8936A3EC067B8B1CAFBCD6677AA1BC446143391C443EF
-E034EFBA4E31DC4D5A0297A7977691836DA0CD68AF9145B2AF24D7F57078E539
-0EB23A4A7234495BBD4D807C017DD8F3FCC90D5FC34E6D5F8823BA19808C9A43
-1E9513CB9C47FC68983AA24C698834F46DB0D59571A500EAB98F3BAAFBA25716
-D0905416E9F22DE5A796210332A4FAE38398FA7CE50A402C624E41EFC13E7E4B
-67ED7459DE929E5501A9B6B5E1595765EA29097EC43585F3B01E13917F609607
-253BF9E6B795DE2876806145CA1D0FA24A547EB0F23AB41898938A78713CDE18
-AA89038C215219727C098A82BC293AAE9D182AF5B331EA5F38D523C0EF5F9654
-B728FEBC626D5F0FD13E5698190F49E15C04A14E6DFC86C33C3F860F8AFEF5C8
-5705AB236C277D69354198238F12790E4F6953ABE5BBF52F6132683B6CC52754
-C381E98184758E8D3E06F9C2FEF8BB67E4865BEAC8E00C330E1C3DECBA71B155
-B015F1693210C94DB1F574406EA9D44FC3812E49C9A9D99BB01E5BE7792B6EB3
-F6302DA68EF532EED466019F8A2997D0FF3F2A6FCA53FD7013DAAF4170810E33
-0A4EE2C3FE3430137C0CE24B11D9E4FD6CB1DE3E42CB45465C4CE359A9B6FAC4
-62AB8D4888723F1D624906DCBC7BE99BE8BE0160AB06B355C379365E427D32EB
-2ACC5E2FE4FBD082CE9E056440F61E80F2EA618B14E6754F109B9249E86B73B6
-ECBF8CBB32BC9B81941FE4B60B29BE8C3F9541E9D6A6714D2BE4B2EE7A4BDBEE
-C0565AD48592B46E085630D024B1D808311798C4FB8AC858ABABFDCE997516B1
-48E1A657E8501163CCE38AFBFEA39E81FB0E0B2AE88D82806FDD5FC356E729FC
-79A40A98ADF296C7A97DFEEA905EBECD4A7742A56E692C00B521FE52A2314951
-946CB39CD3753CE5D5F58E9D06793D478FBECBDB1C1B8A4A7D4CC2BF7D66CA89
-3100D755C217EA9E7976F950A1B887A7D0DCD18180C9148F782CEADDFECB8555
-97207ECEADEC5E4CBA59E6D8BDF929793CFE2987E0BCAB4C2B1872EAAB62194C
-5CC8F8C1FBA41ABC986D07E6A6BB60507104869B339923890F230C8996C44D87
-89CD1A9C7B417C4BDFBC923AC2D4B3A9B4ED74F9802D10CF085BFFC6033A598E
-FBC879548587E150DF37B099960714CE621D16F2AF08BE35502DC20195724337
-0E06725FF1B9D032089E05006461EAFB14B85584BA0618D13CF485DCAAF3DC9C
-C80DE3BA662F7F07FE860AF5061130375A39C0606DD976ED084642AA7B5DAD24
-FA107F84D5DB1C1B5331816303E8C3329E8B023790D70A75480AEFDE595AF8AA
-1C41270058F581C7D38E6C8C02F0D9D3F1250D149682FF74AF9BF35FCC15A1FD
-68F6D1492DE7E00EFCACA2A4EE134344
-0000000000000000000000000000000000000000000000000000000000000000
-0000000000000000000000000000000000000000000000000000000000000000
-0000000000000000000000000000000000000000000000000000000000000000
-0000000000000000000000000000000000000000000000000000000000000000
-0000000000000000000000000000000000000000000000000000000000000000
-0000000000000000000000000000000000000000000000000000000000000000
-0000000000000000000000000000000000000000000000000000000000000000
-0000000000000000000000000000000000000000000000000000000000000000
-cleartomark
-%%EndFont
-TeXDict begin 39139632 55387786 1000 600 600 (lawn93.dvi)
- at start /Fa 133[46 56 1[76 56 56 54 42 55 2[58 56 68 47
-58 1[27 56 58 49 51 57 54 1[56 9[101 74 1[71 56 73 1[67
-77 1[90 62 77 52 37 74 77 65 67 75 71 70 74 18[29 34
-29 4[29 39[{}45 90.9091 /CMCSC10 rf /Fb 133[37 37 121[{}2
-83.022 /CMSY10 rf /Fc 135[102 7[108 1[108 4[54 3[88 108
-33[138 146 65[{}8 172.188 /CMBX12 rf /Fd 215[67 26[46
-13[{}2 83.022 /CMEX10 rf /Fe 157[33 41 17[58 15[38 63[{}4
-74.7198 /CMMI9 rf /Ff 133[34 34 8[64 96[38 11[38 3[{}5
-74.7198 /CMSY9 rf /Fg 252[35 2[55{}2 66.4176 /CMSY8 rf
-/Fh 138[41 4[36 3[21 1[29 24 20[41 11[58 72[{}7 66.4176
-/CMMI8 rf /Fi 171[66 51 67 8[33 68 1[59 62 69 68[{}8
-90.9091 /CMSL10 rf /Fj 141[48 9[48 4[48 1[48 97[{}4 90.9091
-/CMITT10 rf /Fk 135[52 2[52 33 43 41 1[46 44 55 80 27
-1[37 31 52 43 1[42 47 1[39 48 6[62 1[75 1[53 62 53 56
-69 72 58 69 73 88 62 2[40 76 2[67 75 65 69 68 1[45 71
-45 71 25 25 23[42 18[37 15[{}46 90.9091 /CMMI10 rf /Fl
-133[51 5[51 51 2[51 1[51 51 51 51 1[51 1[51 51 51 1[51
-1[51 13[51 2[51 2[51 51 51 7[51 1[51 17[51 51 46[{}23
-99.6264 /CMTT12 rf /Fm 133[50 59 59 1[59 62 44 44 46
-59 62 56 62 93 31 2[31 62 56 34 51 62 50 62 54 6[68 3[85
-86 78 62 84 84 77 1[88 1[67 88 1[42 88 88 1[74 86 81
-80 85 7[56 56 56 56 56 56 56 56 56 56 1[31 37 31 2[44
-44 27[62 12[{}58 99.6264 /CMBX12 rf /Fn 133[37 44 42
-60 42 49 30 37 38 1[46 46 51 74 23 42 1[28 46 42 28 42
-46 42 42 46 4[47 5[68 68 65 51 66 70 62 70 68 82 57 70
-1[35 68 70 59 2[65 64 68 6[28 6[46 1[46 2[28 33 28 4[28
-4[47 21[51 12[{}53 90.9091 /CMTI10 rf /Fo 133[40 40 13[45
-25 84[71 5[45 11[45 71 1[71{}9 90.9091 /CMSY10 rf /Fp
-138[75 52 53 55 2[67 75 1[37 2[37 75 2[61 75 60 75 65
-12[94 75 2[92 2[128 81 105 1[50 5[97 1[102 13[67 67 67
-49[{}26 119.552 /CMBX12 rf /Fq 133[46 55 55 76 55 58
-41 41 43 1[58 52 58 87 29 55 1[29 58 52 32 48 58 46 58
-51 6[64 3[79 80 73 58 78 79 71 1[82 99 63 82 1[40 82
-82 66 69 80 76 74 79 7[52 52 52 52 52 52 52 52 52 52
-1[29 35 29 44[{}58 90.9091 /CMBX10 rf /Fr 129[48 1[48
-1[48 48 48 48 48 48 48 48 48 48 48 48 48 48 48 48 1[48
-48 48 48 48 48 48 48 48 6[48 1[48 48 48 48 48 48 48 48
-48 48 48 48 48 48 1[48 48 48 48 48 48 48 48 48 48 48
-1[48 2[48 48 48 48 48 48 48 48 48 48 48 48 48 48 48 1[48
-48 48 48 48 2[48 48 34[{}76 90.9091 /CMTT10 rf /Fs 134[123
-123 2[129 90 92 95 1[129 116 129 1[65 2[65 129 116 1[106
-1[103 129 113 13[129 173 1[159 3[140 182 7[168 165 175
-65[{}25 206.559 /CMBX12 rf /Ft 134[41 1[55 41 43 30 30
-30 41 43 38 43 64 21 41 23 21 43 38 23 34 43 34 43 38
-3[21 1[21 3[79 58 58 55 43 57 1[52 60 58 70 48 60 1[28
-58 60 50 52 59 55 54 58 5[21 21 38 38 38 38 38 38 38
-38 38 38 1[21 26 21 2[30 30 25[64 43 43 45 11[{}68 74.7198
-/CMR9 rf /Fu 198[30 30 30 30 30 30 30 30 30 30 48[{}10
-49.8132 /CMR6 rf /Fv 198[35 35 35 35 35 35 35 35 35 35
-48[{}10 66.4176 /CMR8 rf /Fw 132[45 40 48 48 66 48 51
-35 36 36 48 51 45 51 76 25 48 28 25 51 45 28 40 51 40
-51 45 25 2[25 45 25 56 68 68 93 68 68 66 51 67 71 62
-71 68 83 57 71 47 33 68 71 59 62 69 66 64 68 3[71 1[25
-25 45 45 45 45 45 45 45 45 45 45 45 25 30 25 71 45 35
-35 25 3[76 45 20[51 51 53 4[66 6[{}85 90.9091 /CMR10
-rf /Fx 206[42 49[{}1 83.022 /CMR10 rf /Fy 138[65 46 46
-46 2[59 65 1[33 62 1[33 1[59 36 52 65 52 1[59 9[120 3[65
-2[80 1[88 1[73 91 1[42 1[92 3[85 1[88 7[59 5[59 51[{}27
-119.552 /CMR12 rf end
-%%EndProlog
-%%BeginSetup
-%%Feature: *Resolution 600dpi
-TeXDict begin
-%%PaperSize: A4
- end
-%%EndSetup
-%%Page: 1 1
-TeXDict begin 1 0 bop 889 -269 a Fy(LAP)-10 b(A)m(CK)38
-b(W)-10 b(orking)38 b(Note)g(93)661 -140 y(Installation)e(Guide)i(for)g
-(ScaLAP)-10 b(A)m(CK)2475 -184 y Fx(1)827 72 y Fw(L.)30
-b(S.)g(Blac)m(kford)1424 39 y Fv(2)1465 72 y Fw(,)g(A.)h(Cleary)1904
-39 y Fv(3)1944 72 y Fw(,)f(J.)h(Choi)2289 39 y Fv(4)2328
-72 y Fw(,)421 185 y(J.)f(J.)g(Dongarra,)i(J.)e(Langou,)h(A.)g(P)m
-(etitet)1899 152 y Fv(5)1941 185 y Fw(,)f(and)g(R.)g(C.)h(Whaley)2719
-152 y Fv(6)926 298 y Fw(Departmen)m(t)h(of)e(Computer)g(Science)1123
-411 y(Univ)m(ersit)m(y)i(of)e(T)-8 b(ennessee)943 524
-y(Kno)m(xville,)32 b(T)-8 b(ennessee)31 b(37996-3450)1517
-736 y(and)531 949 y(J.)f(Demmel,)h(I.)g(Dhillon)1395
-916 y Fv(7)1435 949 y Fw(,)g(O.)f(Marques)1956 916 y
-Fv(8)1995 949 y Fw(,)h(and)f(K.)g(Stanley)1054 1062 y(Computer)f
-(Science)i(Division)926 1175 y(Univ)m(ersit)m(y)g(of)g(California,)g
-(Berk)m(eley)1200 1288 y(Berk)m(eley)-8 b(,)33 b(CA)d(94720)1517
-1500 y(and)1369 1713 y(D.)h(W)-8 b(alk)m(er)1770 1680
-y Fv(9)1015 1925 y Fw(VERSION)30 b(1.8:)42 b(April)30
-b(5,)h(2007)1417 2138 y(Abstract)-210 2350 y(This)g(w)m(orking)h(note)h
-(describ)s(es)e(ho)m(w)g(to)i(install)g(and)e(test)i(v)m(ersion)f(1.8)h
-(of)f(ScaLAP)-8 b(A)m(CK.)32 b(The)g(most)-210 2463 y(signi\014can)m(t)
-43 b(c)m(hange)f(in)g(this)f(release)i(of)f(ScaLAP)-8
-b(A)m(CK)42 b(is)g(the)f(externalisation)j(of)e(the)g(LAP)-8
-b(A)m(CK)-210 2576 y(routines.)38 b(No)m(w)25 b(ScaLAP)-8
-b(A)m(CK)24 b(requires)f(to)h(ha)m(v)m(e)h(the)f(LAP)-8
-b(A)m(CK)23 b(library)h(installed)g(b)s(esides)f(BLA)m(CS,)-210
-2689 y(BLAS)33 b(and)f(MPI)h(or)g(PVM)g(.)g(This)f(will)i(allo)m(w)g
-(the)f(user)g(to)g(use)g(the)g(latest)i(LAP)-8 b(A)m(CK)33
-b(algorithms,)-210 2802 y(mo)s(di\014cations)f(without)g(the)h(need)e
-(of)i(reinstalling)g(the)f(ScaLAP)-8 b(A)m(CK)33 b(library)-8
-b(.)45 b(Tw)m(o)33 b(new)e(routines)-210 2915 y(to)f(allo)m(w)g(read)f
-(and)f(write)h(from)f(\014les)h(ha)m(v)m(e)h(b)s(een)e(added.)40
-b(Also)29 b(a)g(complete)i(ScaLAP)-8 b(A)m(CK)29 b(example)-210
-3028 y(has)34 b(b)s(een)f(added)g(in)h(the)g(main)g(directory)-8
-b(.)53 b(The)34 b(design)g(of)g(the)g(testing/timing)i(programs)e(for)g
-(the)-210 3141 y(ScaLAP)-8 b(A)m(CK)31 b(co)s(des)f(is)h(also)g
-(discussed.)p -210 3559 1440 4 v -106 3612 a Fu(1)-72
-3644 y Ft(This)36 b(w)n(ork)f(w)n(as)h(supp)r(orted)e(in)h(part)g(b)n
-(y)e(the)i(National)h(Science)f(F)-6 b(oundation)34 b(Gran)n(t)h(No.)62
-b(ASC-9005933;)42 b(b)n(y)-210 3735 y(the)29 b(Defense)h(Adv)l(anced)e
-(Researc)n(h)i(Pro)t(jects)h(Agency)e(under)g(con)n(tract)g(D)n
-(AAH04-95-1-0077,)j(administered)e(b)n(y)e(the)-210 3827
-y(Arm)n(y)g(Researc)n(h)h(O\016ce;)i(b)n(y)e(the)f(O\016ce)h(of)h
-(Scien)n(ti\014c)f(Computing,)i(U.S.)e(Departmen)n(t)f(of)i(Energy)-6
-b(,)30 b(under)e(Con)n(tract)-210 3918 y(DE-A)n(C05-84OR21400;)e(and)c
-(b)n(y)f(the)h(National)h(Science)g(F)-6 b(oundation)22
-b(Science)g(and)g(T)-6 b(ec)n(hnology)23 b(Cen)n(ter)f(Co)r(op)r
-(erativ)n(e)-210 4009 y(Agreemen)n(t)j(No.)35 b(CCR-8809615.)-106
-4069 y Fu(2)-72 4101 y Ft(Curren)n(t)26 b(address:)35
-b(Myricom)-106 4160 y Fu(3)-72 4192 y Ft(Curren)n(t)26
-b(address:)35 b(LLNL)-106 4252 y Fu(4)-72 4283 y Ft(Curren)n(t)26
-b(address:)35 b(So)r(ongsil)27 b(Univ)n(ersit)n(y)-6
-b(,)24 b(Seoul,)i(Korea)-106 4343 y Fu(5)-72 4375 y Ft(Curren)n(t)g
-(address:)35 b(Sun)24 b(F)-6 b(rance,)26 b(P)n(aris,)h(F)-6
-b(rance)-106 4434 y Fu(6)-72 4466 y Ft(Curren)n(t)26
-b(address:)35 b(UTSA)-106 4526 y Fu(7)-72 4557 y Ft(Curren)n(t)26
-b(address:)35 b(IBM)26 b(Austin)-106 4617 y Fu(8)-72
-4649 y Ft(Curren)n(t)g(address:)35 b(LBL)-106 4708 y
-Fu(9)-72 4740 y Ft(Curren)n(t)26 b(address:)35 b(Cardi\013)26
-b(Univ)n(ersit)n(y)-6 b(,)24 b(W)-6 b(ales)1567 4989
-y Fw(1)p eop end
-%%Page: 2 2
-TeXDict begin 2 1 bop -210 395 a Fs(Con)-6 b(ten)g(ts)-74
-840 y Fw(1)164 b(In)m(tro)s(duction)28 b(.)46 b(.)g(.)f(.)h(.)g(.)f(.)h
-(.)g(.)g(.)f(.)h(.)g(.)f(.)h(.)g(.)f(.)h(.)g(.)g(.)f(.)h(.)g(.)f(.)h(.)
-g(.)g(.)f(.)h(.)g(.)f(.)h(.)g(.)g(.)f(.)h(.)184 b(4)-74
-953 y(2)164 b(Installation)32 b(Pro)s(cedure)63 b(.)46
-b(.)g(.)g(.)f(.)h(.)g(.)f(.)h(.)g(.)f(.)h(.)g(.)g(.)f(.)h(.)g(.)f(.)h
-(.)g(.)g(.)f(.)h(.)g(.)f(.)h(.)g(.)g(.)f(.)h(.)184 b(4)135
-1066 y(2.1)176 b(Gunzip)30 b(and)g(tar)h(the)f(\014le)h
-Fr(scalapack.tgz)79 b Fw(.)46 b(.)g(.)f(.)h(.)g(.)g(.)f(.)h(.)g(.)f(.)h
-(.)g(.)g(.)f(.)h(.)184 b(5)135 1179 y(2.2)176 b(Edit)31
-b(the)f Fr(SLmake.inc)e Fw(include)i(\014le)69 b(.)46
-b(.)g(.)g(.)f(.)h(.)g(.)f(.)h(.)g(.)g(.)f(.)h(.)g(.)f(.)h(.)g(.)g(.)f
-(.)h(.)184 b(6)426 1292 y(2.2.1)k(F)-8 b(urther)47 b(Details)i(to)e
-(obtain)h(BLA)m(CS,)f(BLAS,)g(LAP)-8 b(A)m(CK)47 b(and)799
-1405 y(PVM)31 b(or)f(MPI)36 b(.)46 b(.)g(.)f(.)h(.)g(.)f(.)h(.)g(.)g(.)
-f(.)h(.)g(.)f(.)h(.)g(.)g(.)f(.)h(.)g(.)f(.)h(.)g(.)g(.)f(.)h(.)184
-b(6)135 1518 y(2.3)176 b(Edit)31 b(the)f(top-lev)m(el)j
-Fr(SCALAPACK/Makefile)25 b Fw(and)30 b(t)m(yp)s(e)h Fr(make)23
-b Fw(.)46 b(.)f(.)h(.)g(.)g(.)f(.)h(.)184 b(7)135 1631
-y(2.4)176 b(Run)30 b(the)g(PBLAS)g(T)-8 b(est)31 b(Suite)65
-b(.)46 b(.)g(.)f(.)h(.)g(.)g(.)f(.)h(.)g(.)f(.)h(.)g(.)g(.)f(.)h(.)g(.)
-f(.)h(.)g(.)g(.)f(.)h(.)184 b(8)135 1744 y(2.5)176 b(Run)30
-b(the)g(PBLAS)g(Timing)g(Suite)h(\(optional\))90 b(.)46
-b(.)f(.)h(.)g(.)g(.)f(.)h(.)g(.)f(.)h(.)g(.)g(.)f(.)h(.)138
-b(10)135 1857 y(2.6)176 b(Run)30 b(the)g(REDIST)g(T)-8
-b(est)31 b(Suite)90 b(.)46 b(.)f(.)h(.)g(.)g(.)f(.)h(.)g(.)f(.)h(.)g(.)
-g(.)f(.)h(.)g(.)f(.)h(.)g(.)g(.)f(.)h(.)138 b(10)135
-1970 y(2.7)176 b(Run)30 b(the)g(ScaLAP)-8 b(A)m(CK)31
-b(T)-8 b(est)31 b(Suite)61 b(.)46 b(.)g(.)g(.)f(.)h(.)g(.)f(.)h(.)g(.)g
-(.)f(.)h(.)g(.)f(.)h(.)g(.)g(.)f(.)h(.)138 b(10)135 2083
-y(2.8)176 b(Run)30 b(the)g(examples)85 b(.)46 b(.)f(.)h(.)g(.)f(.)h(.)g
-(.)f(.)h(.)g(.)g(.)f(.)h(.)g(.)f(.)h(.)g(.)g(.)f(.)h(.)g(.)f(.)h(.)g(.)
-g(.)f(.)h(.)138 b(11)135 2195 y(2.9)176 b(T)-8 b(roublesho)s(oting)88
-b(.)46 b(.)g(.)f(.)h(.)g(.)f(.)h(.)g(.)f(.)h(.)g(.)g(.)f(.)h(.)g(.)f(.)
-h(.)g(.)g(.)f(.)h(.)g(.)f(.)h(.)g(.)g(.)f(.)h(.)138 b(11)-74
-2308 y(3)164 b(More)32 b(Ab)s(out)d(the)i(ScaLAP)-8 b(A)m(CK)31
-b(T)-8 b(est)31 b(Suite)h(.)46 b(.)g(.)g(.)f(.)h(.)g(.)f(.)h(.)g(.)g(.)
-f(.)h(.)g(.)f(.)h(.)g(.)g(.)f(.)h(.)138 b(12)135 2421
-y(3.1)176 b(T)-8 b(ests)31 b(for)f(the)h(ScaLAP)-8 b(A)m(CK)31
-b(LU)f(routines)25 b(.)45 b(.)h(.)g(.)f(.)h(.)g(.)g(.)f(.)h(.)g(.)f(.)h
-(.)g(.)g(.)f(.)h(.)138 b(13)426 2534 y(3.1.1)188 b(Input)29
-b(File)j(for)e(T)-8 b(esting)31 b(the)g(ScaLAP)-8 b(A)m(CK)31
-b(LU)f(Routines)24 b(.)46 b(.)f(.)h(.)138 b(13)135 2647
-y(3.2)176 b(T)-8 b(ests)31 b(for)f(the)h(ScaLAP)-8 b(A)m(CK)31
-b(Band)f(and)g(T)-8 b(ridiagonal)31 b(LU)g(routines)43
-b(.)j(.)f(.)h(.)138 b(14)426 2760 y(3.2.1)188 b(Input)27
-b(File)j(for)e(T)-8 b(esting)29 b(the)g(ScaLAP)-8 b(A)m(CK)29
-b(Band)f(and)g(T)-8 b(ridiago-)799 2873 y(nal)31 b(LU)f(Routines)54
-b(.)45 b(.)h(.)g(.)f(.)h(.)g(.)g(.)f(.)h(.)g(.)f(.)h(.)g(.)g(.)f(.)h(.)
-g(.)f(.)h(.)g(.)g(.)f(.)h(.)138 b(14)135 2986 y(3.3)176
-b(T)-8 b(ests)31 b(for)f(the)h(ScaLAP)-8 b(A)m(CK)31
-b(LL)-8 b(T)30 b(routines)48 b(.)e(.)g(.)f(.)h(.)g(.)g(.)f(.)h(.)g(.)f
-(.)h(.)g(.)g(.)f(.)h(.)138 b(15)426 3099 y(3.3.1)188
-b(Input)29 b(File)j(for)e(T)-8 b(esting)31 b(the)g(ScaLAP)-8
-b(A)m(CK)31 b(LL)-8 b(T)30 b(Routines)48 b(.)d(.)h(.)138
-b(15)135 3212 y(3.4)176 b(T)-8 b(ests)31 b(for)f(the)h(ScaLAP)-8
-b(A)m(CK)31 b(Band)f(and)g(T)-8 b(ridiagonal)31 b(LL)-8
-b(T)30 b(routines)68 b(.)45 b(.)h(.)138 b(16)426 3325
-y(3.4.1)188 b(Input)24 b(File)i(for)f(T)-8 b(esting)26
-b(the)g(ScaLAP)-8 b(A)m(CK)26 b(Band)f(or)g(T)-8 b(ridiagonal)799
-3437 y(LL)g(T)30 b(Routines)88 b(.)46 b(.)f(.)h(.)g(.)f(.)h(.)g(.)g(.)f
-(.)h(.)g(.)f(.)h(.)g(.)g(.)f(.)h(.)g(.)f(.)h(.)g(.)g(.)f(.)h(.)138
-b(16)135 3550 y(3.5)176 b(T)-8 b(ests)31 b(for)f(the)h(ScaLAP)-8
-b(A)m(CK)31 b(QR,)f(R)m(Q,)h(LQ,)f(QL,)g(QP)-8 b(,)30
-b(and)g(TZ)g(routines)52 b(.)138 b(17)426 3663 y(3.5.1)188
-b(Input)34 b(File)i(for)f(T)-8 b(esting)37 b(the)e(ScaLAP)-8
-b(A)m(CK)36 b(QR,)f(R)m(Q,)g(LQ,)g(QL,)799 3776 y(QP)-8
-b(,)31 b(and)e(TZ)h(Routines)64 b(.)45 b(.)h(.)g(.)g(.)f(.)h(.)g(.)f(.)
-h(.)g(.)g(.)f(.)h(.)g(.)f(.)h(.)g(.)g(.)f(.)h(.)138 b(17)135
-3889 y(3.6)176 b(T)-8 b(ests)31 b(for)f(the)h(Linear)f(Least)h(Squares)
-f(\(LLS\))g(routines)93 b(.)45 b(.)h(.)g(.)f(.)h(.)g(.)g(.)f(.)h(.)138
-b(17)426 4002 y(3.6.1)188 b(Input)29 b(File)j(for)e(T)-8
-b(esting)31 b(the)g(ScaLAP)-8 b(A)m(CK)31 b(LLS)e(Routines)56
-b(.)45 b(.)h(.)138 b(18)135 4115 y(3.7)176 b(T)-8 b(ests)31
-b(for)f(the)h(ScaLAP)-8 b(A)m(CK)31 b(INV)f(routines)51
-b(.)46 b(.)g(.)f(.)h(.)g(.)g(.)f(.)h(.)g(.)f(.)h(.)g(.)g(.)f(.)h(.)138
-b(18)426 4228 y(3.7.1)188 b(Input)29 b(File)j(for)e(T)-8
-b(esting)31 b(the)g(ScaLAP)-8 b(A)m(CK)31 b(INV)f(Routines)51
-b(.)45 b(.)h(.)138 b(19)135 4341 y(3.8)176 b(T)-8 b(ests)31
-b(for)f(the)h(ScaLAP)-8 b(A)m(CK)31 b(HRD)g(routines)86
-b(.)46 b(.)f(.)h(.)g(.)g(.)f(.)h(.)g(.)f(.)h(.)g(.)g(.)f(.)h(.)138
-b(19)426 4454 y(3.8.1)188 b(Input)29 b(File)j(for)e(T)-8
-b(esting)31 b(the)g(ScaLAP)-8 b(A)m(CK)31 b(HRD)f(Routines)86
-b(.)46 b(.)138 b(20)135 4567 y(3.9)176 b(T)-8 b(ests)31
-b(for)f(the)h(ScaLAP)-8 b(A)m(CK)31 b(TRD)f(routines)89
-b(.)46 b(.)f(.)h(.)g(.)g(.)f(.)h(.)g(.)f(.)h(.)g(.)g(.)f(.)h(.)138
-b(20)426 4679 y(3.9.1)188 b(Input)29 b(File)j(for)e(T)-8
-b(esting)31 b(the)g(SCALAP)-8 b(A)m(CK)30 b(TRD)g(Routines)40
-b(.)46 b(.)138 b(20)1567 4989 y(2)p eop end
-%%Page: 3 3
-TeXDict begin 3 2 bop 135 -269 a Fw(3.10)131 b(T)-8 b(ests)31
-b(for)f(the)h(ScaLAP)-8 b(A)m(CK)31 b(BRD)g(routines)90
-b(.)46 b(.)f(.)h(.)g(.)g(.)f(.)h(.)g(.)f(.)h(.)g(.)g(.)f(.)h(.)138
-b(21)426 -156 y(3.10.1)143 b(Input)29 b(File)j(for)e(T)-8
-b(esting)31 b(the)g(ScaLAP)-8 b(A)m(CK)31 b(BRD)g(Routines)89
-b(.)46 b(.)138 b(21)135 -43 y(3.11)131 b(T)-8 b(ests)31
-b(for)f(the)h(ScaLAP)-8 b(A)m(CK)31 b(SEP)e(routines)46
-b(.)g(.)g(.)f(.)h(.)g(.)g(.)f(.)h(.)g(.)f(.)h(.)g(.)g(.)f(.)h(.)138
-b(21)426 70 y(3.11.1)143 b(T)-8 b(est)31 b(Matrices)h(for)e(the)h
-(Symmetric)f(Eigen)m(v)-5 b(alue)32 b(Routines)65 b(.)45
-b(.)h(.)138 b(22)426 183 y(3.11.2)143 b(Input)36 b(File)i(for)f(T)-8
-b(esting)39 b(the)e(Symmetric)g(Eigen)m(v)-5 b(alue)39
-b(Routines)799 296 y(and)30 b(Driv)m(ers)35 b(.)45 b(.)h(.)g(.)f(.)h(.)
-g(.)f(.)h(.)g(.)g(.)f(.)h(.)g(.)f(.)h(.)g(.)g(.)f(.)h(.)g(.)f(.)h(.)g
-(.)g(.)f(.)h(.)138 b(23)135 409 y(3.12)131 b(T)-8 b(ests)31
-b(for)f(the)h(ScaLAP)-8 b(A)m(CK)31 b(GSEP)f(routines)45
-b(.)h(.)f(.)h(.)g(.)g(.)f(.)h(.)g(.)f(.)h(.)g(.)g(.)f(.)h(.)138
-b(24)426 522 y(3.12.1)143 b(Input)20 b(File)h(for)g(T)-8
-b(esting)22 b(the)f(Generalized)h(Symmetric)f(Eigen)m(v)-5
-b(alue)799 635 y(Routines)31 b(and)e(Driv)m(ers)79 b(.)45
-b(.)h(.)g(.)g(.)f(.)h(.)g(.)f(.)h(.)g(.)g(.)f(.)h(.)g(.)f(.)h(.)g(.)g
-(.)f(.)h(.)138 b(24)135 748 y(3.13)131 b(T)-8 b(ests)31
-b(for)f(the)h(ScaLAP)-8 b(A)m(CK)31 b(NEP)f(routines)e(.)46
-b(.)g(.)f(.)h(.)g(.)g(.)f(.)h(.)g(.)f(.)h(.)g(.)g(.)f(.)h(.)138
-b(24)426 860 y(3.13.1)143 b(Input)29 b(File)j(for)e(T)-8
-b(esting)31 b(the)g(ScaLAP)-8 b(A)m(CK)31 b(NEP)f(Routines)e(.)45
-b(.)h(.)138 b(25)135 973 y(3.14)131 b(T)-8 b(ests)31
-b(for)f(the)h(ScaLAP)-8 b(A)m(CK)31 b(EV)m(C)f(routines)d(.)46
-b(.)g(.)f(.)h(.)g(.)g(.)f(.)h(.)g(.)f(.)h(.)g(.)g(.)f(.)h(.)138
-b(25)426 1086 y(3.14.1)143 b(Input)29 b(File)j(for)e(T)-8
-b(esting)31 b(the)g(ScaLAP)-8 b(A)m(CK)31 b(EV)m(C)f(Routines)d(.)45
-b(.)h(.)138 b(26)135 1199 y(3.15)131 b(T)-8 b(ests)31
-b(for)f(the)h(ScaLAP)-8 b(A)m(CK)31 b(SVD)f(routines)i(.)46
-b(.)g(.)f(.)h(.)g(.)g(.)f(.)h(.)g(.)f(.)h(.)g(.)g(.)f(.)h(.)138
-b(26)426 1312 y(3.15.1)143 b(T)-8 b(est)31 b(Matrices)h(for)e(the)h
-(Singular)f(V)-8 b(alue)31 b(Decomp)s(osition)h(Routines)53
-b(27)426 1425 y(3.15.2)143 b(Input)29 b(File)j(for)e(T)-8
-b(esting)31 b(the)g(ScaLAP)-8 b(A)m(CK)31 b(SVD)f(Routines)i(.)45
-b(.)h(.)138 b(27)-210 1629 y Fq(A)57 b(ScaLAP)-9 b(A)m(CK)36
-b(Routines)2325 b(28)-210 1833 y(B)62 b(ScaLAP)-9 b(A)m(CK)36
-b(Auxiliary)f(Routines)1862 b(32)-74 1946 y Fw(Bibliograph)m(y)86
-b(.)45 b(.)h(.)g(.)g(.)f(.)h(.)g(.)f(.)h(.)g(.)g(.)f(.)h(.)g(.)f(.)h(.)
-g(.)f(.)h(.)g(.)g(.)f(.)h(.)g(.)f(.)h(.)g(.)g(.)f(.)h(.)g(.)f(.)h(.)g
-(.)g(.)f(.)h(.)138 b(35)1567 4989 y(3)p eop end
-%%Page: 4 4
-TeXDict begin 4 3 bop -210 -269 a Fp(1)135 b(In)l(tro)t(duction)72
-84 y Fw(This)31 b(w)m(orking)i(note)f(describ)s(es)g(ho)m(w)g(to)g
-(install)h(and)f(test)h(v)m(ersion)f(1.8)h(of)f(ScaLAP)-8
-b(A)m(CK)33 b([1].)-210 197 y(This)d(release)h(of)g(ScaLAP)-8
-b(A)m(CK)31 b(includes:)-74 385 y Fo(\017)46 b Fw(Externalisation)h(of)
-e(the)g(LAP)-8 b(A)m(CK)46 b(routines.)84 b(No)m(w)46
-b(y)m(ou)f(NEED)h(the)f(LAP)-8 b(A)m(CK)45 b(library)17
-498 y(installed)31 b(on)g(y)m(our)f(mac)m(hine)h(in)f(order)g(to)h
-(link/run)e(a)i(ScaLAP)-8 b(A)m(CK)31 b(program.)-74
-685 y Fo(\017)46 b Fw(2)41 b(new)f(routines:)61 b(p[sdcz]la)m(write)42
-b(and)e([psdcz]laread)h(declined)g(in)f(the)h(4)g(precisions\()g(they)
-17 798 y(haev)31 b(b)s(een)f(adapated)h(from)e(ScaEx)i(example)g(from)f
-(An)m(toine)h(P)m(ettitet.)-74 986 y Fo(\017)46 b Fw(a)27
-b(new)e(directory)i(EXAMPLE)f(that)h(con)m(tains)g(a)g(ScaLAP)-8
-b(A)m(CK)26 b(example)h(in)f(the)g(4)h(precisions.)-74
-1174 y Fo(\017)46 b Fw(Sev)m(eral)32 b(bug)d(\014xes.)-210
-1361 y(F)-8 b(or)38 b(a)g(detailed)g(explanation)g(of)g(the)f(design)g
-(and)g(con)m(ten)m(ts)i(of)f(the)f(ScaLAP)-8 b(A)m(CK)38
-b(library)-8 b(,)39 b(please)-210 1474 y(refer)30 b(to)h(the)g(ScaLAP)
--8 b(A)m(CK)31 b(Users')f(Guide[1)q(].)-69 1587 y(ScaLAP)-8
-b(A)m(CK)30 b(is)g(freely)g(a)m(v)-5 b(ailable)32 b(on)d
-Fn(netlib)h Fw(and)f(can)h(b)s(e)f(obtained)h(via)g(the)g(W)-8
-b(orld)30 b(Wide)g(W)-8 b(eb)-210 1700 y(or)30 b(anon)m(ymous)h(ftp.)17
-1887 y Fr(http://www.netlib.org/sca)o(lapa)o(ck/s)o(cal)o(apac)o(k.tg)o
-(z)-210 2075 y Fw(Prebuilt)f(ScaLAP)-8 b(A)m(CK)31 b(libraries)g(are)f
-(a)m(v)-5 b(ailable)33 b(on)d Fn(netlib)h Fw(for)f(a)h(v)-5
-b(ariet)m(y)31 b(of)g(arc)m(hitectures.)17 2263 y Fr
-(http://www.netlib.org/sca)o(lapa)o(ck/a)o(rch)o(ives)o(/)-210
-2450 y Fw(Ho)m(w)m(ev)m(er,)d(if)c(a)h(prebuilt)e(library)h(do)s(es)g
-(not)g(exist)h(for)f(y)m(our)g(arc)m(hitecture,)k(y)m(ou)c(will)h(need)
-f(to)h(do)m(wnload)-210 2563 y(the)31 b(distribution)e(tar)i(\014le)f
-(and)g(build)g(the)g(library)g(as)h(instructed)f(in)g(this)g(guide.)-69
-2676 y(T)-8 b(o)21 b(install)g(and)f(test)h(ScaLAP)-8
-b(A)m(CK,)21 b(the)f(user)g(m)m(ust)g(ha)m(v)m(e)i(the)e(BLA)m(CS,)h
-(BLAS[9,)g(6,)g(5],)i(LAP)-8 b(A)m(CK[11)q(])-210 2789
-y(and)30 b(MPI)g([7)q(])g(or)h(PVM)f([8)q(])h(a)m(v)-5
-b(ailable)32 b(on)f(his)f(mac)m(hine.)-69 2902 y(ScaLAP)-8
-b(A)m(CK)41 b(has)f(b)s(een)f(tested)i(on)f(MPPs)g(lik)m(e)h(the)f(IBM)
-h(SP)e(series,)k(Cra)m(y)e(T3E,)f(and)f(SGI)-210 3015
-y(Origin)33 b(2000/3000,)38 b(and)32 b(tested)i(on)f(clusters)g(of)g
-(PCs)g(and)f(net)m(w)m(orks)i(of)f(w)m(orkstations)h(supp)s(orting)-210
-3128 y(MPI)c(or)h(PVM.)348 3095 y Fv(10)-69 3241 y Fw(Section)36
-b(2)f(con)m(tains)h(step-b)m(y-step)g(installation)h(and)d
-(testing/timing)k(instructions.)54 b(F)-8 b(or)36 b(users)-210
-3354 y(desiring)c(additional)g(information,)h(Section)f(3)g(giv)m(es)i
-(details)e(on)g(the)g(testing/timing)i(programs)d(for)-210
-3467 y(the)24 b(ScaLAP)-8 b(A)m(CK)24 b(co)s(des)f(and)g(their)g(input)
-g(\014les.)38 b(App)s(endices)23 b(A)g(and)g(B)h(describ)s(e)f(the)g
-(ScaLAP)-8 b(A)m(CK)-210 3579 y(driv)m(er,)30 b(computational,)j(and)c
-(auxiliary)i(routines)g(curren)m(tly)f(a)m(v)-5 b(ailable.)-210
-3866 y Fp(2)135 b(Installation)47 b(Pro)t(cedure)-69
-4069 y Fw(Installing,)31 b(testing,)h(and)e(timing)h(ScaLAP)-8
-b(A)m(CK)31 b(in)m(v)m(olv)m(es)h(the)f(follo)m(wing)h(steps:)-99
-4256 y(1.)46 b(Gunzip)30 b(and)g(tar)h(the)f(\014le)h
-Fr(scalapack.tgz)p Fw(.)p -210 4338 1440 4 v -137 4392
-a Fu(10)-72 4424 y Ft(It)f(is)g(v)n(ery)g(imp)r(ortan)n(t)g(to)g(note)g
-(that)g(only)g(PVM)g(v)n(ersion)g(3.3)h(or)g(later)f(is)h(supp)r(orted)
-f(with)g(the)g(BLA)n(CS[4,)h(10].)-210 4515 y(Due)c(to)i(ma)t(jor)g(c)n
-(hanges)g(in)e(PVM)i(and)e(the)h(resulting)g(c)n(hanges)h(required)e
-(in)h(the)g(BLA)n(CS,)g(earlier)i(v)n(ersions)e(of)h(PVM)-210
-4606 y(are)d(NOT)g(supp)r(orted.)1567 4989 y Fw(4)p eop
-end
-%%Page: 5 5
-TeXDict begin 5 4 bop -99 -269 a Fw(2.)46 b(Cop)m(y)37
-b(the)h(SLmak)m(e.inc.example)g(to)g(SLmak)m(e.inc)g(and)f(edit)g(the)g
-Fr(SLmake.inc)e Fw(include)i(\014le,)17 -156 y(sp)s(ecifying)i(the)f
-(lo)s(cation)j(of)d(the)h(MPI)g(or)f(PVM)h(library)-8
-b(,)41 b(the)e(BLA)m(CS)f(library)-8 b(,)41 b(the)e(BLAS)17
--43 y(library)30 b(and)g(the)h(LAP)-8 b(A)m(CK)30 b(library)-8
-b(.)-99 132 y(3.)46 b(Edit)31 b(the)f(top-lev)m(el)j
-Fr(Makefile)p Fw(,)28 b(and)i(t)m(yp)s(e)g Fr(make)g
-Fw(to)h(generate)h(the)e(ScaLAP)-8 b(A)m(CK)31 b(library)-99
-307 y(4.)46 b(T)m(yp)s(e)30 b Fr(make)47 b(exe)29 b Fw(to)i(generate)h
-(the)f(ScaLAP)-8 b(A)m(CK)31 b(T)-8 b(est)31 b(Suite\(s\).)-99
-482 y(5.)46 b(Run)30 b(the)g(T)-8 b(est)31 b(Suite\(s\).)-69
-638 y(If)26 b(failures)h(are)g(encoun)m(tered)h(during)d(an)m(y)i
-(phase)g(of)g(the)g(installation)h(or)f(testing)h(pro)s(cess,)f(please)
--210 751 y(\014rst)j(refer)g(to)h(the)f(F)-10 b(A)m(Q)31
-b(and)f(Errata)h(\014les)f(for)g(information)17 908 y
-Fr(http://www.netlib.org/sca)o(lapa)o(ck/f)o(aq.)o(html)17
-1083 y(http://www.netlib.org/sca)o(lapa)o(ck/e)o(rra)o(ta.h)o(tml)-210
-1239 y Fw(and)g(if)g(that)h(do)s(es)f(not)h(resolv)m(e)g(the)g
-(problem,)f(please)h(con)m(tact)i(the)e(dev)m(elop)s(ers)f(at)17
-1395 y Fr(scalapack at cs.utk.edu)-210 1633 y Fm(2.1)112
-b(Gunzip)38 b(and)h(tar)e(the)g(\014le)h Fl(scalapack.tgz)72
-1804 y Fw(The)21 b(soft)m(w)m(are)i(is)f(distributed)e(in)h(the)h(form)
-f(of)h(a)f(gzipp)s(ed)g(tar)h(\014le)g(whic)m(h)f(con)m(tains)i(the)e
-(ScaLA-)-210 1917 y(P)-8 b(A)m(CK)37 b(source)h(co)s(de)f(and)f(test)i
-(suite,)i(as)d(w)m(ell)h(as)g(the)f(PBLAS)g(source)g(co)s(de)g(and)g
-(testing/timing)-210 2030 y(programs.)i(The)25 b(PBLAS)g(are)h
-(parallel)h(v)m(ersions)f(of)f(the)h(Lev)m(el)h(1,)g(2,)g(and)e(3)h
-(BLAS.)g(F)-8 b(or)26 b(more)g(details)-210 2143 y(on)k(the)h(PBLAS,)f
-(refer)g(to)h([2)q(,)g(3].)17 2299 y Fr(http://www.netlib.org/sca)o
-(lapa)o(ck/s)o(cal)o(apac)o(k.tg)o(z)-69 2455 y Fw(T)-8
-b(o)31 b(unpac)m(k)f(the)h Fr(scalapack.tgz)26 b Fw(\014le,)31
-b(t)m(yp)s(e)g(the)f(follo)m(wing)i(command:)17 2630
-y Fr(gunzip)46 b(-c)i(scalapack.tgz)c(|)j(tar)g(xvf)g(-)-210
-2805 y Fw(This)33 b(will)i(create)h(a)e(top-lev)m(el)j(directory)e
-(called)g Fr(SCALAPACK)d Fw(as)i(sho)m(wn)g(in)g(Figure)g(1.)53
-b(Please)35 b(note)-210 2918 y(that)j(this)f(\014gure)g(do)s(es)g(not)g
-(re\015ect)h(ev)m(erything)g(that)g(is)f(con)m(tained)i(in)e(the)g
-Fr(SCALAPACK)e Fw(directory)-8 b(.)-210 3031 y(Input)31
-b(and)g(instructional)i(\014les)f(are)g(also)h(lo)s(cated)g(at)g(v)-5
-b(arious)32 b(lev)m(els.)47 b(Libraries)32 b(are)g(created)h(in)f(the)
-1069 3141 y(SCALAP)-8 b(A)m(CK)p 1388 3241 4 113 v 269
-3242 2840 4 v 267 3353 4 113 v 715 3353 V 1164 3353 V
-1612 3353 V 2060 3353 V 2583 3353 V 3106 3353 V 136 3440
-a(PBLAS)207 b(SR)m(C)150 b(TESTING)82 b(TOOLS)116 b(REDIST)i(EXAMPLE)59
-b(INST)-8 b(ALL)p 267 3577 V 44 3579 449 4 v 43 3689
-4 113 v 491 3689 V 1164 3577 V 941 3579 449 4 v 939 3689
-4 113 v 1388 3689 V 2060 3577 V 1838 3579 449 4 v 1836
-3689 4 113 v 2284 3689 V -27 3776 a(SR)m(C)149 b(TESTING)161
-b(LIN)286 b(EIG)275 b(SR)m(C)150 b(TESTING)808 3997 y(Figure)30
-b(1:)42 b(Organization)31 b(of)g(ScaLAP)-8 b(A)m(CK)-210
-4288 y Fr(SCALAPACK)31 b Fw(directory)i(and)g(executable)h(\014les)g
-(are)f(created)h(in)f(the)g Fr(TESTING)f Fw(directory\(ies\).)50
-b(Input)-210 4401 y(\014les)30 b(are)g(copied)g(in)m(to)h(the)f
-Fr(TESTING)e Fw(directory)i(at)g(the)g(time)h(eac)m(h)g(executable)g
-(is)f(created.)41 b(Y)-8 b(ou)31 b(will)-210 4514 y(need)g(appro)m
-(ximately)h(28)g(Mb)m(ytes)g(of)f(space)h(for)f(the)g(tar)g(\014le.)43
-b(Y)-8 b(our)31 b(total)i(space)f(requiremen)m(ts)f(will)-210
-4627 y(v)-5 b(ary)29 b(dep)s(ending)e(up)s(on)h(if)h(all)h(platforms)e
-(of)i(the)f(BLA)m(CS)g(are)g(installed)h(and)e(the)h(size)h(of)f
-(executable)-210 4740 y(\014les)h(that)h(y)m(our)g(con\014guration)f
-(can)h(handle.)1567 4989 y(5)p eop end
-%%Page: 6 6
-TeXDict begin 6 5 bop -210 -269 a Fm(2.2)112 b(Edit)37
-b(the)h Fl(SLmake.inc)i Fm(include)e(\014le)72 -97 y
-Fw(Example)28 b(mac)m(hine-sp)s(eci\014c)h Fr(SCALAPACK/SLmake.inc)22
-b Fw(\014les)27 b(are)h(pro)m(vided)g(in)f(the)h Fr(INSTALL)-210
-16 y Fw(sub)s(directory)33 b(for)g(the)h(In)m(tel)g(i860,)i(IBM)e(SP)-8
-b(,)34 b(Cra)m(y)g(T3E,)g(SGI)f(Origin,)h(and)f(v)-5
-b(arious)34 b(w)m(orkstations)-210 129 y(using)20 b(MPI)h(or)g(PVM.)h
-(When)e(y)m(ou)i(ha)m(v)m(e)g(selected)g(the)f(mac)m(hine)h(to)g(whic)m
-(h)e(y)m(ou)i(wish)e(to)i(install)f(ScaLA-)-210 242 y(P)-8
-b(A)m(CK,)21 b(cop)m(y)g(the)f(appropriate)h(sample)f(include)g(\014le)
-g(\(if)h(one)g(is)f(presen)m(t\))h(in)m(to)g Fr(SCALAPACK/SLmake.inc)p
-Fw(.)-210 355 y(F)-8 b(or)31 b(example,)g(if)g(y)m(ou)f(wish)g(to)h
-(run)e(ScaLAP)-8 b(A)m(CK)31 b(on)f(a)h(DEC)f(ALPHA,)17
-565 y Fr(cp)47 b(INSTALL/SLmake.ALPHA)c(SLmake.inc)-69
-775 y Fw(Edit)30 b(the)h Fr(SLmake.inc)d Fw(mak)m(e)j(include)f(\014le)
-h(to)g(con)m(tain)g(the)g(follo)m(wing:)-99 960 y(1.)46
-b(Sp)s(ecify)30 b(the)g(complete)i(path)e(to)i(the)e(top)h(lev)m(el)h
-Fr(SCALAPACK)c Fw(directory)j(called)g Fr(home)p Fw(.)-99
-1147 y(2.)46 b(Iden)m(tify)36 b(the)g(platform)f(to)h(whic)m(h)g(y)m
-(ou)g(will)f(b)s(e)g(installing)i(the)f(libraries.)56
-b(If)35 b(y)m(our)g(directory)17 1260 y(structure)24
-b(for)f(ScaLAP)-8 b(A)m(CK)25 b(is)f(di\013eren)m(t)g(than)g(the)g
-(aforemen)m(tioned)h(structure,)g(y)m(ou)f(will)g(also)17
-1373 y(need)30 b(to)i(sp)s(ecify)e(lo)s(cations)h(of)g
-Fr(SCALAPACK)d Fw(sub)s(directories.)-99 1560 y(3.)46
-b(De\014ne)41 b Fr(F77)p Fw(,)h Fr(NOOPT)p Fw(,)d Fr(F77FLAGS)p
-Fw(,)f Fr(CC)p Fw(,)i Fr(CCFLAGS)p Fw(,)f Fr(LOADER)p
-Fw(,)g Fr(LOADFLAGS)p Fw(,)f Fr(ARCH)p Fw(,)h Fr(ARCHFLAGS)p
-Fw(,)17 1672 y(and)28 b Fr(RANLIB)p Fw(,)e(to)j(refer)f(to)h(the)f
-(compiler)g(and)g(compiler)h(options,)g(loader)f(and)g(loader)g
-(options,)17 1785 y(library)33 b(arc)m(hiv)m(er)h(and)f(options,)h(and)
-e(ranlib)h(for)g(y)m(our)g(mac)m(hine.)49 b(If)33 b(y)m(our)g(mac)m
-(hine)h(do)s(es)f(not)17 1898 y(require)d(ranlib)g(set)h
-Fr(RANLIB)46 b(=)i(echo)p Fw(.)-99 2085 y(4.)e(Sp)s(ecify)30
-b(the)g(C)g(prepro)s(cessor)f(de\014nitions)h(for)g(compilation,)i
-Fr(BLACSDBGLVL)27 b Fw(and)i Fr(CDEFS)p Fw(.)g(The)17
-2198 y(p)s(ossible)42 b(v)-5 b(alues)42 b(for)g Fr(BLACSDBGLVL)d
-Fw(are)j(0)g(and)f(1.)76 b(The)42 b(p)s(ossible)f(options)h(for)g
-Fr(CDEFS)f Fw(are)17 2311 y Fr(-DAdd)p 263 2311 29 4
-v 33 w Fw(,)28 b Fr(-DNoChange)p Fw(,)d(and)h Fr(-DUPCASE)p
-Fw(.)e(If)i(y)m(ou)h(are)g(on)g(a)g(DEC)f(ALPHA,)h(y)m(ou)g(m)m(ust)g
-(also)h(add)17 2424 y Fr(-DNO)p 215 2424 V 34 w(IEEE)h
-Fw(to)i(the)f(de\014nition)g(of)h Fr(CDEFS)p Fw(.)-99
-2611 y(5.)46 b(Sp)s(ecify)30 b(the)g(lo)s(cations)i(of)f(the)f(needed)g
-(libraries:)41 b Fr(BLACS)p Fw(,)29 b Fr(PVM)h Fw(or)g
-Fr(MPI)p Fw(,)g Fr(BLAS)f Fw(and)h Fr(LAPACK)p Fw(.)-210
-2796 y(This)23 b(mak)m(e)i(include)f(\014le)g(is)g(referenced)g(inside)
-g(eac)m(h)h(of)f(the)g(mak)m(e\014les)h(in)f(the)g(v)-5
-b(arious)24 b(sub)s(directories.)-210 2909 y(As)37 b(a)h(result,)h
-(there)f(is)f(no)h(need)f(to)h(edit)g(the)f(mak)m(e\014les)i(in)e(the)g
-(sub)s(directories.)62 b(All)38 b(information)-210 3022
-y(that)31 b(is)f(mac)m(hine)h(sp)s(eci\014c)g(has)f(b)s(een)f
-(de\014ned)h(in)g(this)g(include)g(\014le.)-210 3262
-y Fq(2.2.1)105 b(F)-9 b(urther)35 b(Details)g(to)g(obtain)g(BLA)m(CS,)f
-(BLAS,)i(LAP)-9 b(A)m(CK)35 b(and)g(PVM)g(or)g(MPI)-69
-3433 y Fw(Prebuilt)20 b(BLA)m(CS)g(libraries)h(are)f(a)m(v)-5
-b(ailable)23 b(on)d Fn(netlib)g Fw(for)h(a)f(v)-5 b(ariet)m(y)22
-b(of)e(arc)m(hitectures)i(and)e(message)-210 3546 y(passing)30
-b(library)g(com)m(binations;)17 3732 y Fr(http://www.netlib.org/bla)o
-(cs/a)o(rchi)o(ves)-210 3917 y Fw(otherwise,)h(the)g(BLA)m(CS)f
-(distribution)g(tar)g(\014les)h(are)f(a)m(v)-5 b(ailable.)17
-4103 y Fr(http://www.netlib.org/bla)o(cs/m)o(pibl)o(acs)o(.tgz)17
-4216 y(http://www.netlib.org/bla)o(cs/p)o(vmbl)o(acs)o(.tgz)-210
-4401 y Fw(After)44 b(obtaining)g(the)g(source,)k(follo)m(w)d(the)f
-(instructions)f(in)g(\\A)i(User's)f(Guide)f(to)i(the)f(BLA)m(CS")-210
-4514 y(or)d(in)h(the)f("Installing)i(the)f(BLA)m(CS")g(section)g(of)g
-(the)g(BLA)m(CS)f(w)m(ebpage)h(to)h(install)f(the)g(library)-8
-b(.)-210 4627 y(Instructions)38 b(for)g(running)f(the)i(BLA)m(CS)g(T)-8
-b(est)39 b(Suite)f(can)h(b)s(e)f(found)g(in)g(\\A)h(User's)g(Guide)f
-(to)i(the)-210 4740 y(BLA)m(CS)30 b(T)-8 b(ester".)42
-b(Both)31 b(of)g(these)g(do)s(cumen)m(ts)f(are)g(a)m(v)-5
-b(ailable)33 b(via)e(the)g Fn(blacs)f(index)h Fw(on)f
-Fn(netlib)p Fw(.)1567 4989 y(6)p eop end
-%%Page: 7 7
-TeXDict begin 7 6 bop -69 -269 a Fw(If)31 b(an)f(v)m(endor)h(optimized)
-h(BLAS)f(library)f(is)h(not)g(a)m(v)-5 b(ailable,)34
-b(then)d(the)g(user)f(can)h(install)h(A)-8 b(TLAS)-210
--156 y(whic)m(h)39 b(will)h(generate)h(an)e(optimized)i(BLAS)e(library)
-g(for)g(the)h(giv)m(en)g(arc)m(hitecture,)k(or)39 b(install)i(the)-210
--43 y(F)-8 b(ortran77)32 b(reference)f(implemen)m(tation)h(of)e(the)h
-(BLAS.)17 130 y Fr(http://www.netlib.org/bla)o(s/fa)o(q.ht)o(ml#)o(1.6)
-17 243 y(http://www.netlib.org/atl)o(as/)17 356 y
-(http://www.netlib.org/bla)o(s/bl)o(as.t)o(gz)-210 529
-y Fw(An)41 b(optimized)h(BLAS)g(library)f(is)g(essen)m(tial)j(for)d(b)s
-(est)g(p)s(erformance,)j(and)d(use)g(of)h(the)f(F)-8
-b(ortran77)-210 642 y(reference)31 b(implemen)m(tation)h(BLAS)e(is)g
-(strongly)h(discouraged.)-69 755 y(If)45 b(an)g(v)m(endor)h(optimized)g
-(LAP)-8 b(A)m(CK)45 b(library)g(is)h(not)f(a)m(v)-5 b(ailable,)52
-b(then)45 b(the)h(user)e(can)i(install)-210 868 y(LAP)-8
-b(A)m(CK)31 b(from)f(netlib.)17 1041 y Fr(http://www.netlib.org/lap)o
-(ack/)o(faq.)o(htm)o(l#1.)o(1)17 1154 y(http://www.netlib.org/lap)o
-(ack/)17 1266 y(http://www.netlib.org/lap)o(ack/)o(lapa)o(ck.)o(tgz)-69
-1439 y Fw(If)g(a)h(v)m(endor-supplied)f(MPI)h(or)f(PVM)h(library)g(is)g
-(not)f(a)m(v)-5 b(ailable,)34 b(p)s(ortable)d(implemen)m(tations)h(of)
--210 1552 y(PVM)f(and)f(MPI)g(\(MPICH)h(and)f(LAM/MPI\))h(are)g(a)m(v)
--5 b(ailable:)43 b(If)30 b(a)h(v)m(endor-supplied)f(MPI)g(or)h(PVM)-210
-1665 y(library)38 b(is)g(not)g(a)m(v)-5 b(ailable,)43
-b(p)s(ortable)38 b(implemen)m(tations)i(of)f(PVM)f(and)g(MPI)g
-(\(MPICH,)g(MPICH2,)-210 1778 y(Op)s(en)29 b(MPI)h(and)g(LAM/MPI\))i
-(are)e(a)m(v)-5 b(ailable:)17 1951 y Fr(http://www.netlib.org/pvm)o(3/)
-17 2064 y(http://www-unix.mcs.anl.g)o(ov/m)o(pi/m)o(pic)o(h1/)17
-2177 y(http://www-unix.mcs.anl.g)o(ov/m)o(pi/m)o(pic)o(h//)17
-2290 y(http://www.lam-mpi.org/)24 b(http://www.open-mpi.org/)-210
-2463 y Fw(Installation)36 b(instructions)e(for)h(PVM)g(are)f(con)m
-(tained)i(in)e(the)h(PVM)g(Users')g(Guide)f([8)q(].)53
-b(An)34 b(Instal-)-210 2576 y(lation)h(Guide)f(for)g(MPICH/MPICH2)g(is)
-h(a)m(v)-5 b(ailable)36 b(on)e(the)g(aforemen)m(tioned)h(w)m(ebpage.)53
-b(Lik)m(ewise,)-210 2689 y(installation)41 b(instructions)e(for)g(Op)s
-(en)f(MPI)h(and)g(LAM/MPI)h(are)g(con)m(tained)g(on)f(their)h(resp)s
-(ectiv)m(e)-210 2802 y(w)m(ebpage.)-210 3042 y Fm(2.3)112
-b(Edit)37 b(the)h(top-lev)m(el)g Fl(SCALAPACK/Makefile)k
-Fm(and)c(t)m(yp)s(e)g Fl(make)-69 3214 y Fw(A)e(top-lev)m(el)i
-Fr(SCALAPACK/Makefile)31 b Fw(has)k(b)s(een)g(included)g(to)h(build)f
-(all)i(libraries,)g(testing)g(exe-)-210 3327 y(cutables)29
-b(and)f(examples.)41 b(This)28 b(mak)m(e\014le)i(is)f(v)m(ery)g(useful)
-f(if)g(y)m(ou)h(are)g(familiar)h(with)e(the)h(installation)-210
-3440 y(pro)s(cess)36 b(and)h(wish)f(to)i(do)f(a)g(quic)m(k)g
-(installation.)63 b(Y)-8 b(our)37 b(instructions)g(to)g(build)f(the)h
-(ScaLAP)-8 b(A)m(CK)-210 3553 y(library)30 b(are:)17
-3748 y Fr(cd)47 b(SCALAPACK)17 3929 y(make)-69 4124 y
-Fw(If)29 b(y)m(ou)h(wish)f(to)h(build)f(the)h(testing)g(executables)h
-(\(assuming)f(that)g(all)h(libraries)e(ha)m(v)m(e)i(previously)-210
-4237 y(b)s(een)f(built\),)g(y)m(ou)h(can)g(sp)s(ecify)17
-4432 y Fr(make)47 b(exe)p Fw(.)-69 4627 y(If)22 b(y)m(ou)h(wish)e(to)i
-(build)e(the)i(examples)g(\(assuming)f(that)h(all)g(libraries)f(ha)m(v)
-m(e)i(previously)e(b)s(een)g(built\),)-210 4740 y(y)m(ou)31
-b(can)f(sp)s(ecify)1567 4989 y(7)p eop end
-%%Page: 8 8
-TeXDict begin 8 7 bop 17 -269 a Fr(make)47 b(example)p
-Fw(.)-69 -56 y(If)35 b(y)m(ou)i(wish)e(to)h(build)f(only)h(selected)h
-(libraries)f(or)g(executables,)j(y)m(ou)d(can)g(mo)s(dify)f(the)h
-Fr(lib)f Fw(or)-210 57 y Fr(exe)29 b Fw(de\014nition)i(accordingly)-8
-b(.)-69 170 y(T)g(o)21 b(sp)s(ecify)f(the)g(data)h(t)m(yp)s(es)g(to)g
-(b)s(e)e(built,)k(y)m(ou)d(will)h(need)f(to)h(mo)s(dify)e(the)i
-(de\014nition)f(of)g Fr(PRECISIONS)p Fw(.)-210 283 y(By)31
-b(default,)f Fr(PRECISIONS)e Fw(is)i(set)h(to)-210 470
-y Fr(PRECISIONS)45 b(=)i(single)g(double)f(complex)f(complex16)-210
-658 y Fw(to)c(build)e(all)j(precisions)e(of)h(the)f(libraries)h(and)e
-(executables.)73 b(If)40 b(y)m(ou)g(only)h(wish)e(to)i(compile)h(the)
--210 771 y(single)f(precision)g(real)f(v)m(ersion)h(of)g(a)g(target)g
-(sp)s(ecify)f Fr(single)p Fw(,)i(for)e(double)g(precision)g(real)h(sp)s
-(ecify)-210 884 y Fr(double)p Fw(,)i(for)e(single)h(precision)f
-(complex)h(sp)s(ecify)f Fr(complex)p Fw(,)h(and)f(for)g(double)g
-(precision)g(complex)-210 997 y(sp)s(ecify)30 b Fr(complex16)p
-Fw(.)-69 1109 y(By)e(default,)g(the)g(presence)f(of)h(no)f(argumen)m
-(ts)h(follo)m(wing)h(the)e Fr(make)f Fw(command)i(will)f(result)h(in)f
-(the)-210 1222 y(building)j(of)g(all)h(data)g(t)m(yp)s(es.)41
-b(The)30 b(mak)m(e)i(command)e(can)g(b)s(e)g(run)f(more)i(than)f(once)h
-(to)g(add)f(another)-210 1335 y(data)h(t)m(yp)s(e)g(to)g(the)f(library)
-g(if)h(necessary)-8 b(.)-69 1448 y(Y)g(ou)31 b(ma)m(y)g(then)g(pro)s
-(ceed)f(to)h(running)e(eac)m(h)j(of)f(the)g(individual)f(test)h
-(suites.)42 b(See)31 b(section)g(2.4)h(for)-210 1561
-y(details)38 b(on)f(the)h(PBLAS)f(T)-8 b(est)38 b(Suite,)h(section)f
-(2.6)h(to)f(run)e(the)h(REDIST)f(test)j(suite,)g(and)e(section)-210
-1674 y(2.7)g(for)e(details)i(on)f(the)g(ScaLAP)-8 b(A)m(CK)36
-b(T)-8 b(est)36 b(Suite.)57 b(After)36 b(all)h(testing)g(has)e(b)s(een)
-g(completed,)k(y)m(ou)-210 1787 y(can)j(remo)m(v)m(e)h(all)g(ob)5
-b(ject)43 b(\014les)f(from)f(the)h(v)-5 b(arious)42 b(sub)s
-(directories)f(and)g(all)i(executables)g(from)f(the)-210
-1900 y Fr(SCALAPACK/TESTING)26 b Fw(directory)31 b(b)m(y)f(t)m(yping)17
-2112 y Fr(make)47 b(clean)p Fw(.)-69 2325 y(Or,)22 b(y)m(ou)f(can)h
-(selectiv)m(ely)h(remo)m(v)m(e)g(only)d(the)h(ob)5 b(ject)22
-b(\014les)f(with)f Fr(make)47 b(cleanlib)p Fw(,)21 b
-Fr(make)46 b(cleanexe)-210 2438 y Fw(to)31 b(remo)m(v)m(e)h(only)e(the)
-h(testing)g(routine)f(ob)5 b(ject)31 b(\014les)f(and)g(executable)i
-(\014les,)e(or)h Fr(make)46 b(cleanexample)-210 2551
-y Fw(to)31 b(remo)m(v)m(e)h(only)e(the)h(ob)5 b(ject)31
-b(\014les)g(created)g(for)f(the)h(examples.)-210 2794
-y Fm(2.4)112 b(Run)38 b(the)f(PBLAS)g(T)-9 b(est)37 b(Suite)-69
-2966 y Fw(The)29 b(PBLAS)f(testing)i(executables)h(are)e(created)h(in)f
-(the)g Fr(PBLASTSTdir)d Fw(directory)j(as)h(de\014ned)d(in)-210
-3079 y Fr(SLmake.inc)p Fw(.)37 b(By)29 b(default,)g(these)g(testing)h
-(executables)g(are)f(copied)g(in)m(to)g(the)g Fr(SCALAPACK/TESTING)-210
-3192 y Fw(directory)-8 b(.)40 b(F)-8 b(or)26 b(the)g(Lev)m(el)h(1)f
-(PBLAS)g(routines,)g(the)g(testing)h(executables)g(are)f(called)h
-Fr(xspblas1tst)p Fw(,)-210 3305 y Fr(xdpblas1tst)p Fw(,)36
-b Fr(xcpblas1tst)p Fw(,)g(and)g Fr(xzpblas1tst)p Fw(.)57
-b(Lik)m(ewise,)40 b(the)d(testing)i(executables)f(for)f(the)-210
-3417 y(Lev)m(el)43 b(2)g(PBLAS)e(are)i Fr(xspblas2tst)p
-Fw(,)f Fr(xdpblas2tst)p Fw(,)g Fr(xcpblas2tst)p Fw(,)g(and)f
-Fr(xzpblas2tst)p Fw(.)72 b(The)-210 3530 y(testing)33
-b(executables)g(for)e(the)h(Lev)m(el)h(3)f(PBLAS)f(are)h
-Fr(xspblas3tst)p Fw(,)e Fr(xdpblas3tst)p Fw(,)f Fr(xcpblas3tst)p
-Fw(,)-210 3643 y(and)40 b Fr(xzpblas3tst)p Fw(.)69 b(There)40
-b(is)g(one)h(input)f(\014le)h(asso)s(ciated)h(with)e(eac)m(h)i(testing)
-g(executable.)73 b(F)-8 b(or)-210 3756 y(example,)50
-b(the)45 b(input)f(\014le)i(for)f Fr(xspblas1tst)d Fw(is)j(called)h
-Fr(PSBLA1TST.dat)p Fw(.)82 b(The)44 b(input)g(\014les)i(are)-210
-3869 y(copied)31 b(to)g(the)g Fr(PBLASTSTdir)c Fw(directory)k(at)g(the)
-f(time)h(the)g(executables)h(are)f(built.)-69 3982 y(F)-8
-b(or)29 b(brevit)m(y)-8 b(,)29 b(w)m(e)g(shall)f(only)g(list)g
-(instructions)g(for)g(testing)h(PBLAS)e(executables)j(using)d(MPICH)
--210 4095 y(on)32 b(a)g(net)m(w)m(ork)g(of)g(w)m(orkstations,)i(and)d
-(PVM)h(on)f(a)h(net)m(w)m(ork)h(of)f(w)m(orkstations.)46
-b(Execution)32 b(instruc-)-210 4208 y(tions)f(for)f(the)g(v)-5
-b(arious)31 b(distributed-memory)e(computers)i(are)f(mac)m(hine-dep)s
-(enden)m(t.)-210 4448 y Fq(T)-9 b(esting)35 b(instructions)h(with)e
-(MPICH)g(on)i(a)e(net)m(w)m(ork)h(of)g(w)m(orkstations)-69
-4620 y Fw(F)-8 b(or)36 b(the)g(sak)m(e)h(of)e(an)h(example,)i(w)m(e)d
-(shall)h(assume)g(that)g(y)m(ou)f(ha)m(v)m(e)i(installed)f(the)g(p)s
-(ortable)g(im-)-210 4732 y(plemen)m(tation)30 b(of)e(MPI,)h(called)g
-Fr(MPICH)p Fw(,)e(and)h(built)g(the)h(PBLAS)f(tester)h(executables)h
-(for)e(eac)m(h)h(of)g(the)1567 4989 y(8)p eop end
-%%Page: 9 9
-TeXDict begin 9 8 bop -210 -269 a Fw(mac)m(hines)33 b(used)f(in)g(y)m
-(our)g(application.)49 b(The)32 b(executable)i(\014les)e(are)h(not)g
-(required)f(to)h(b)s(e)f(stored)g(in)h(a)-210 -156 y(particular)g
-(directory)-8 b(.)49 b(Then,)32 b(to)h(run)f(the)g(executable,)k(y)m
-(ou)d(will)g(use)f(the)h(command)f Fr(mpirun)p Fw(.)46
-b(F)-8 b(or)-210 -43 y(example,)17 159 y Fr(mpirun)46
-b(-np)h Fk(<)p Fr(number)f(of)h(processes)p Fk(>)e(<)p
-Fr(executable)p Fk(>)-69 361 y Fw(where)31 b Fk(<)p Fr(executable)p
-Fk(>)e Fw(is)i(replaced)i(b)m(y)e Fr(xspblas1tst)p Fw(,)e(and)i(so)h
-(on.)45 b(If)31 b(the)h(net)m(w)m(ork)h(of)f(w)m(ork-)-210
-474 y(stations)i(is)e(heterogeneous,)j(y)m(ou)d(will)h(need)f(to)i(sp)s
-(ecify)e(the)h Fr(-p4pg)e Fw(option)i(and)e(supply)g(a)i(text)h(\014le)
--210 587 y(con)m(taining)27 b(the)f(names)g(of)f(the)h(mac)m(hines)g
-(and)f(the)h(lo)s(cations)h(of)f(the)g(executables)h(to)f(whic)m(h)g(y)
-m(ou)g(will)-210 700 y(spa)m(wn)k(tasks.)41 b(Refer)30
-b(to)h(the)g Fr(mpirun)e Fw(manpage)i(for)f(complete)h(details.)-210
-938 y Fq(T)-9 b(esting)35 b(instructions)h(with)e(PVM)i(on)f(a)f(net)m
-(w)m(ork)h(of)g(w)m(orkstations)-69 1110 y Fw(First,)j(insure)d(that)i
-(the)f(PVM)g(library)g(and)f(tester)i(executable)g(\014les)f(ha)m(v)m
-(e)i(b)s(een)d(compiled)h(for)-210 1223 y(eac)m(h)27
-b(of)g(the)f(mac)m(hines)h(used)e(in)h(y)m(our)g(PVM)h(implemen)m
-(tation.)41 b(PVM)26 b(3.3)i(requires)e(that)g(executable)-210
-1336 y(\014les)37 b(b)s(e)g(stored)h(in)f(a)h(particular)g(directory)g
-(so)g(that)g(the)g(PVM)f(daemon)h(can)g(\014nd)e(them.)62
-b(In)37 b(the)-210 1448 y(general)32 b(case,)g(PVM)f(lo)s(oks)h(for)e
-(executable)j(\014les)e(in)f Fr(~/pvm3/bin/)p Fj(arch)p
-Fw(,)e(where)i Fn(ar)-5 b(ch)32 b Fw(sp)s(eci\014es)f(the)-210
-1561 y(arc)m(hitecture)f(for)e(whic)m(h)f(the)i(executable)g(has)f(b)s
-(een)g(built.)39 b(F)-8 b(or)29 b(example,)h(if)e(one)g(wished)f(to)i
-(run)e(the)-210 1674 y(test)32 b(program)f(on)g(a)g(SUN)g(SP)-8
-b(AR)m(Cstation)32 b(and)f(on)g(an)g(IBM)h(RS6000)g(w)m(orkstation,)h
-(appropriately)-210 1787 y(compiled)25 b(executable)h(\014les)f(need)g
-(to)g(b)s(e)f(placed)h(in)g Fr(~/pvm3/bin/SUN4)20 b Fw(and)k
-Fr(~/pvm3/bin/RS6K)d Fw(\(for)-210 1900 y(more)28 b(directory)h
-(information,)g(consult)g(the)f(PVM)h(do)s(cumen)m(tation\).)41
-b(If)28 b(y)m(ou)g(wish)g(to)h(run)e(the)h(tests)-210
-2013 y(on)36 b(mac)m(hines)g(that)g(are)g(not)g(connected)h(to)f(the)g
-(same)g(\014le)g(system,)i(y)m(ou)e(need)f(to)i(mak)m(e)f(sure)f(that)
--210 2126 y(the)c(executable)h(is)e(a)m(v)-5 b(ailable)33
-b(on)d(eac)m(h)h(\014le)g(system.)41 b(Next,)31 b(start)g(p)m(vm)f(b)m
-(y)h(t)m(yping)17 2328 y Fr(pvm)-69 2530 y Fw(A)m(t)f(this)f(p)s(oin)m
-(t,)h(y)m(ou)g(sp)s(ecify)f(the)g(mac)m(hines)h(that)g(are)f(to)h(tak)m
-(e)h(part)e(in)g(the)h(testing)g(pro)s(cess)f(\(see)-210
-2643 y(the)35 b(PVM)g(do)s(cumen)m(tation)g(for)g(more)f
-(information\).)54 b(Finally)-8 b(,)38 b(to)d(test)h(the)e(REAL)h(PVM)g
-(Lev)m(el)h(1)-210 2755 y(PBLAS,)30 b(start)h(the)g(test)g(program)f(b)
-m(y)g(t)m(yping:)17 2957 y Fr(xspblas1tst)-69 3159 y
-Fw(on)c(one)h(of)f(the)g(mac)m(hines)h(that)g(is)f(a)g(mem)m(b)s(er)g
-(of)g(y)m(our)g(PVM)h(mac)m(hine.)40 b(This)25 b(program)h(will)g(then)
--210 3272 y(instruct)h(the)g(PVM)h(daemon)f(to)h(start)g(pro)s(cesses)f
-(on)g(the)h(other)f(computers)g(in)g(y)m(our)h(PVM)f(mac)m(hine)-210
-3385 y(and)j(y)m(ou)i(will)f(b)s(e)f(prompted)g(b)m(y)h(the)g(program)g
-(for)f(the)h(name)g(of)h(the)f(executable.)44 b(Mak)m(e)32
-b(sure)e(that)-210 3498 y Fr(PSBLA1TST.dat)24 b Fw(is)j(lo)s(cated)i
-(in)e(the)h(same)g(directory)g(as)g Fr(xspblas1tst)p
-Fw(.)37 b(It)27 b(is)h(read)f(on)h(the)f(mac)m(hine)-210
-3611 y(from)33 b(whic)m(h)h(y)m(ou)g(t)m(yp)s(e)g Fr(xspblas1tst)d
-Fw(and)i(its)h(con)m(ten)m(ts)h(distributed)e(to)i(the)f(other)g
-(computers)f(in)-210 3724 y(y)m(our)d(PVM)h(mac)m(hine.)-69
-3837 y Fn(A)n(lternatively,)j(you)g(c)-5 b(an)34 b(use)f
-Fr(blacs)p 1246 3837 29 4 v 33 w(setup.dat)e Fn(to)j(p)-5
-b(erform)36 b(much)d(of)h(this)g(pr)-5 b(o)g(c)g(ess.)47
-b(This)34 b(\014le)-210 3950 y(sp)-5 b(e)g(ci\014es)31
-b(the)f(name)g(of)g(the)g(exe)-5 b(cutable)30 b(and)h(the)f(machines)h
-(to)f(sp)-5 b(awn)32 b(in)d(your)i(pvm)f(cluster,)g(as)h(wel)5
-b(l)-210 4063 y(as)33 b(a)g(few)f(other)h(fe)-5 b(atur)g(es.)43
-b(Se)-5 b(e)32 b(the)h(\\A)f(User's)g(Guide)g(to)h(the)g(BLA)n(CS")e
-(for)i(details.)43 b(However,)33 b(the)-210 4175 y(use)f(of)h(this)g
-(\014le)g(is)g(not)g(r)-5 b(e)g(c)g(ommende)g(d)36 b(for)d(the)g(naive)
-g(user.)-69 4288 y Fw(Similar)j(commands)f(should)g(b)s(e)g(used)g(for)
-g(the)h(other)g(test)h(programs,)g(with)e(the)h(second)g(letter)-210
-4401 y(`s')30 b(in)g(the)g(executable)i(and)d(data)i(\014le)f(replaced)
-g(b)m(y)g(`d',)g(`c',)h(or)f(`z'.)42 b(The)29 b(name)h(of)g(the)g
-(output)g(\014le)g(is)-210 4514 y(indicated)25 b(on)f(the)g(\014rst)g
-(line)g(of)h(the)f(input)g(\014le)g(and)g(is)g(curren)m(tly)g
-(de\014ned)f(to)i(b)s(e)f Fr(PSBLA1TST.SUMM)c Fw(for)-210
-4627 y(the)31 b(REAL)g(v)m(ersion,)g(with)g(similar)g(names)g(for)f
-(the)h(other)h(data)f(t)m(yp)s(es.)42 b(The)31 b(user)f(ma)m(y)h(also)h
-(c)m(ho)s(ose)-210 4740 y(to)f(send)f(all)h(output)f(to)h(standard)f
-(error.)1567 4989 y(9)p eop end
-%%Page: 10 10
-TeXDict begin 10 9 bop -210 -269 a Fm(2.5)112 b(Run)38
-b(the)f(PBLAS)g(Timing)h(Suite)g(\(optional\))-109 -97
-y Fw(a\))46 b(Go)31 b(to)g(the)g(directory)g Fr(SCALAPACK/PBLAS/TIMING)
-p Fw(.)-114 91 y(b\))45 b(T)m(yp)s(e)d Fr(make)f Fw(follo)m(w)m(ed)k(b)
-m(y)d(the)g(data)i(t)m(yp)s(es)e(desired.)76 b(F)-8 b(or)44
-b(the)e(Lev)m(el)i(1)f(PBLAS)f(routines,)17 203 y(the)48
-b(timing)g(executables)g(are)g(called)g Fr(xspblas1tim)p
-Fw(,)h Fr(xdpblas1tim)p Fw(,)g Fr(xcpblas1tim)p Fw(,)g(and)17
-316 y Fr(xzpblas1tim)p Fw(,)21 b(and)g(are)h(created)h(in)f(the)g
-Fr(PBLASTSTdir)c Fw(directory)k(as)g(de\014ned)f(in)g
-Fr(SLmake.inc)p Fw(.)17 429 y(Lik)m(ewise,)j(the)c(timing)h
-(executables)h(for)e(the)g(Lev)m(el)i(2)f(PBLAS)e(are)i
-Fr(xspblas2tim)p Fw(,)f Fr(xdpblas2tim)p Fw(,)17 542
-y Fr(xcpblas2tim)p Fw(,)28 b(and)i Fr(xzpblas2tim)p Fw(.)39
-b(The)30 b(timing)h(executables)h(for)e(the)h(Lev)m(el)h(3)f(PBLAS)g
-(are)17 655 y Fr(xspblas3tim)p Fw(,)26 b Fr(xdpblas3tim)p
-Fw(,)g Fr(xcpblas3tim)p Fw(,)g(and)i Fr(xzpblas3tim)p
-Fw(.)37 b(There)27 b(is)i(one)f(input)g(\014le)17 768
-y(asso)s(ciated)k(with)f(eac)m(h)h(timing)f(executable.)43
-b(F)-8 b(or)31 b(example,)h(the)f(input)f(\014le)h(for)f
-Fr(xspblas1tim)17 881 y Fw(is)h(called)g Fr(PSBLA1TIM.dat)p
-Fw(.)38 b(The)30 b(input)f(\014les)h(are)h(copied)g(to)g(the)g
-Fr(PBLASTSTdir)c Fw(directory)k(at)17 994 y(the)g(time)g(the)f
-(executables)i(are)f(built.)-104 1181 y(c\))46 b(Run)30
-b(the)i(timing)f(executables)i(on)e(the)g(desired)g(platform)g(as)h
-(analogously)g(describ)s(ed)f(in)f(Sec-)17 1294 y(tion)h(2.4.)-210
-1538 y Fm(2.6)112 b(Run)38 b(the)f(REDIST)g(T)-9 b(est)36
-b(Suite)-69 1709 y Fw(The)46 b(redistribution/cop)m(y)h(routines)f
-(allo)m(w)h(the)g(redistribution)e(of)i(a)f(2-D)i(blo)s(c)m(k)e(cyclic)
-i(dis-)-210 1822 y(tributed)24 b(general)i(or)e(trap)s(ezoidal)i
-(matrix)f(from)f(an)h(arbitrary)f Fk(P)e Fo(\002)9 b
-Fk(Q)23 b Fw(grid)i(with)f(arbitrary)g(blo)s(c)m(ksize)-210
-1935 y(to)31 b(another)g(grid)f(with)g(arbitrary)g(blo)s(c)m(ksize.)
--109 2148 y(a\))46 b(Go)31 b(to)g(the)g(directory)g Fr
-(SCALAPACK/REDIST/TESTING)o Fw(.)-114 2335 y(b\))45 b(T)m(yp)s(e)40
-b Fr(make)g Fw(follo)m(w)m(ed)i(b)m(y)f(the)g(data)g(t)m(yp)s(es)g
-(desired.)71 b(The)40 b(testing)i(executables)g(are)f(called)17
-2448 y Fr(xigemr)p Fw(,)34 b Fr(xsgemr)p Fw(,)g Fr(xdgemr)p
-Fw(,)g Fr(xcgemr)p Fw(,)g Fr(xzgemr)f Fw(for)h(the)h(redistribution)f
-(of)g(general)i(matrices.)17 2561 y(They)31 b(are)g(called)h
-Fr(xitrmr)p Fw(,)e Fr(xstrmr)p Fw(,)g Fr(xdtrmr)p Fw(,)g
-Fr(xctrmr)p Fw(,)g(and)g Fr(xztrmr)f Fw(for)i(trap)s(ezoidal)h(matri-)
-17 2674 y(ces,)j(and)d(are)h(created)h(in)f(the)g Fr(REDISTdir/TESTING)
-28 b Fw(directory)34 b(as)f(de\014ned)f(in)g Fr(SLmake.inc)p
-Fw(.)17 2787 y(There)23 b(is)f(one)i(input)e(\014le)g
-Fr(GEMR2D.dat)e Fw(for)j(general)h(matrices,)i(and)c(one)h(input)f
-(\014le)h Fr(TRMR2D.dat)17 2900 y Fw(for)30 b(trap)s(ezoidal)i
-(matrices.)42 b(Eac)m(h)31 b(line)f(of)h(the)f(input)g(\014le)g(is)h(a)
-g(separate)g(test.)-210 3143 y Fm(2.7)112 b(Run)38 b(the)f(ScaLAP)-9
-b(A)m(CK)36 b(T)-9 b(est)37 b(Suite)72 3315 y Fw(There)23
-b(are)i(eigh)m(teen)g(distinct)f(test)h(programs)e(for)g(testing)i(the)
-f(ScaLAP)-8 b(A)m(CK)24 b(routines)g(of)g(the)-210 3428
-y(follo)m(wing)32 b(t)m(yp)s(e:)42 b(LU,)31 b(Cholesky)-8
-b(,)32 b(Band)e(LU,)h(Band)g(Cholesky)-8 b(,)31 b(General)h(T)-8
-b(ridiagonal,)32 b(Band)f(T)-8 b(ridi-)-210 3541 y(agonal,)28
-b(QR)d(\(R)m(Q,)g(LQ,)g(QL,)g(QP)-8 b(,)25 b(and)g(TZ\),)g(Linear)g
-(Least)h(Squares,)f(upp)s(er)f(Hessen)m(b)s(erg)h(reduction,)-210
-3654 y(tridiagonal)30 b(reduction,)g(bidiagonal)f(reduction,)h(matrix)f
-(in)m(v)m(ersion,)h(the)f(symmetric)g(eigenproblem,)-210
-3767 y(the)f(generalized)h(symmetric)f(eigenproblem,)h(the)e
-(nonsymmetric)h(eigenproblem,)g(and)f(the)h(singular)-210
-3880 y(v)-5 b(alue)31 b(decomp)s(osition.)-69 3993 y(Eac)m(h)47
-b(of)f(the)g(test)h(programs)e(is)h(automatically)j(timed)d(and)f(rep)s
-(orts)h(a)g(table)h(of)f(execution)-210 4105 y(times)40
-b(and)f(mega\015op)i(rates.)69 b(There)39 b(is)h(one)g(input)f(\014le)h
-(for)f(eac)m(h)i(test)g(program.)68 b(As)40 b(previously)-210
-4218 y(stated,)e(the)e(input)f(\014les)h(reside)f(in)h(the)g
-Fr(SCALAPACK/TESTING)31 b Fw(sub)s(directory)j(and)i(are)g(copied)g(in)
-m(to)-210 4331 y(the)31 b Fr(TESTINGdir)c Fw(directory)k(\(as)g(sp)s
-(eci\014ed)e(in)h(the)h Fr(SLmake.inc)d Fw(\014le\))i(at)h(the)g(time)g
-(the)f(executables)-210 4444 y(are)i(built.)45 b(All)32
-b(testing)h(programs)e(o)s(ccur)h(in)f(four)h(precisions,)g(with)f(the)
-h(exception)h(of)f(the)g(singular)-210 4557 y(v)-5 b(alue)28
-b(decomp)s(osition)g(whic)m(h)e(only)i(o)s(ccurs)f(in)g(SINGLE)f(and)h
-(DOUBLE)g(PRECISION)f(REAL.)h(F)-8 b(or)-210 4670 y(more)31
-b(information)f(on)g(the)h(test)g(programs)f(and)g(ho)m(w)g(to)i(mo)s
-(dify)d(the)i(input)e(\014les)h(see)h(Section)h(3.)1545
-4989 y(10)p eop end
-%%Page: 11 11
-TeXDict begin 11 10 bop -69 -269 a Fw(Run)36 b(the)i(testing)h
-(executables)g(on)e(the)h(desired)f(platform)g(as)h(analogously)h
-(describ)s(ed)d(in)h(Sec-)-210 -156 y(tion)30 b(2.4.)42
-b(F)-8 b(or)30 b(example,)g(in)g(double)f(precision,)h(the)g(testing)g
-(executables)h(are)f(named)f Fr(xdlu)p Fw(,)g Fr(xdllt)p
-Fw(,)-210 -43 y Fr(xddblu)p Fw(,)44 b Fr(xdgblu)p Fw(,)h
-Fr(xddtlu)p Fw(,)f Fr(xdpbllt)p Fw(,)h Fr(xdptllt)p Fw(,)f
-Fr(xdls)p Fw(,)h Fr(xdqr)p Fw(,)g Fr(xdhrd)p Fw(,)g Fr(xdtrd)p
-Fw(,)f Fr(xdbrd)p Fw(,)h Fr(xdinv)p Fw(,)-210 70 y Fr(xdsep)p
-Fw(,)21 b Fr(xdgsep)p Fw(,)g Fr(xdnep)p Fw(,)g(and)f
-Fr(xdsvd)p Fw(.)36 b(The)19 b(input)h(\014les)g(are)h
-Fr(LU.dat)p Fw(,)f Fr(LLT.dat)p Fw(,)h Fr(BLU.dat)p Fw(,)g
-Fr(BLLT.dat)p Fw(,)-210 183 y Fr(LS.dat)p Fw(,)29 b Fr(QR.dat)p
-Fw(,)g Fr(HRD.dat)p Fw(,)f Fr(TRD.dat)p Fw(,)h Fr(BRD.dat)p
-Fw(,)g Fr(INV.dat)p Fw(,)f Fr(SEP.dat)p Fw(,)h Fr(NEP.dat)p
-Fw(,)g(and)g Fr(SVD.dat)p Fw(.)-69 296 y(Similar)24 b(commands)g(can)g
-(b)s(e)f(used)h(for)f(alternate)j(precisions)e(of)g(the)h(same)f(test)h
-(program)f(or)g(other)-210 409 y(test)37 b(programs.)57
-b(The)36 b(name)g(of)g(the)g(output)g(\014le)g(is)g(indicated)h(on)f
-(the)g(\014rst)f(line)h(of)h(the)f(input)f(\014le)-210
-522 y(and)f(is)g(curren)m(tly)g(de\014ned)f(to)i(b)s(e)e
-Fr(lu.out)g Fw(for)g(the)i(LU)f(tester,)i(with)e(similar)g(names)g(for)
-g(the)h(other)-210 635 y(data)c(t)m(yp)s(es.)41 b(The)30
-b(user)f(ma)m(y)i(also)h(c)m(ho)s(ose)f(to)g(send)f(all)h(output)f(to)h
-(standard)f(error.)-210 876 y Fm(2.8)112 b(Run)38 b(the)f(examples)72
-1048 y Fw(In)d(the)h(EXAMPLE)f(directory)-8 b(,)37 b(y)m(ou)e(ha)m(v)m
-(e)h(a)f(program)f(declined)h(in)f(the)h(4)g(precisions)f(that)-210
-1161 y(solv)m(es)29 b(a)g(linear)f(system)g(b)m(y)g(calling)h(the)g
-(ScaLAP)-8 b(A)m(CK)28 b(routine)g(PDGESV.)h(The)e(input)g(matrix)i
-(and)-210 1273 y(righ)m(t-and-sides)i(are)g(read)f(from)g(a)h(\014le.)
-40 b(The)30 b(solution)h(is)g(written)f(to)h(a)g(\014le.)-69
-1386 y(T)-8 b(o)30 b(compile)g(and)e(create)j(the)e(example)g
-(executables)i(\(assuming)e(that)g(all)h(librairies)g(ha)m(v)m(e)g
-(previ-)-210 1499 y(ously)g(b)s(een)g(built\),)h(t)m(yp)s(e)f
-Fr(make)47 b(example)28 b Fw(or)j Fr(make)e Fw(if)h(y)m(ou)h(are)g(in)f
-(the)g(EXAMPLE)h(directory)-8 b(.)-69 1612 y(This)30
-b(will)g(create)i(the)f(four)f(executables)h(in)f(the)h(TESTING)e
-(directory:)-74 1789 y Fo(\017)46 b Fw(xsscaex:)c(for)30
-b(the)h(example)g(using)f(single)h(precision)-74 1973
-y Fo(\017)46 b Fw(xdscaex:)c(for)30 b(the)g(example)h(using)f(double)g
-(precision)-74 2156 y Fo(\017)46 b Fw(xcscaex:)c(for)31
-b(the)f(example)h(using)f(complex)h(precision)-74 2340
-y Fo(\017)46 b Fw(xzscaex:)c(for)31 b(the)f(example)h(using)f(double)g
-(complex)h(precision.)-210 2517 y(and)36 b(cop)m(y)i(the)f(input)f
-(\014les)h(in)f(the)h(TESTING)f(directory)-8 b(.)61 b(The)36
-b(input)g(\014les)h(are)g Fr(CSCAEXMAT.dat)p Fw(,)-210
-2629 y Fr(CSCAEXRHS.dat)p Fw(,)19 b Fr(DSCAEXMAT.dat)p
-Fw(,)g Fr(DSCAEXRHS.dat)p Fw(,)g Fr(SCAEX.dat)p Fw(,)h
-Fr(SSCAEXMAT.dat)p Fw(,)f Fr(SSCAEXRHS.dat)p Fw(,)-210
-2742 y Fr(ZSCAEXMAT.dat)27 b Fw(and)j Fr(ZSCAEXRHS.dat)p
-Fw(.)-69 2855 y(T)-8 b(o)31 b(run)e(the)h(example)i(programs)e(using)f
-(MPI,)i(t)m(yp)s(e)g(\(for)f(single)h(precision)g(example\))17
-3032 y Fr(mpirun)46 b(-np)h Fk(<)p Fr(number)f(of)h(processes)p
-Fk(>)e Fr(xsscaex)-69 3209 y Fw(The)27 b(results)g(will)h(b)s(e)f
-(written)g(in)g Fr(CSCAEXSOL.dat)d Fw(for)j(xcscaex)i(,)f
-Fr(DSCAEXSOL.dat)c Fw(for)j(xdscaex,)-210 3322 y Fr(SSCAEXSOL.dat)g
-Fw(for)j(xsscaex)h(and)p Fr(ZSCAEXSOL.dat)26 b Fw(for)k(xzscaex.)-210
-3564 y Fm(2.9)112 b(T)-9 b(roublesho)s(oting)-69 3735
-y Fw(If)26 b(failures)h(are)g(encoun)m(tered)h(during)d(an)m(y)i(phase)
-g(of)g(the)g(installation)h(or)f(testing)h(pro)s(cess,)f(please)-210
-3848 y(\014rst)j(refer)g(to)h(the)f(F)-10 b(A)m(Q)31
-b(and)f(Errata)h(\014les)f(for)g(information)17 4025
-y Fr(http://www.netlib.org/sca)o(lapa)o(ck/f)o(aq.)o(html)17
-4209 y(http://www.netlib.org/sca)o(lapa)o(ck/e)o(rra)o(ta.h)o(tml)-210
-4386 y Fw(and)g(if)g(that)h(do)s(es)f(not)h(resolv)m(e)g(the)g
-(problem,)f(please)h(con)m(tact)i(the)e(dev)m(elop)s(ers)f(at)17
-4563 y Fr(scalapack at cs.utk.edu)-69 4740 y Fw(This)g(release)h(of)g
-(ScaLAP)-8 b(A)m(CK)31 b(is)f(compatible)i(with)e(the)h(previous)e
-(release)j(\(v)m(ersion)f(1.7\).)1545 4989 y(11)p eop
-end
-%%Page: 12 12
-TeXDict begin 12 11 bop -210 -269 a Fp(3)135 b(More)45
-b(Ab)t(out)f(the)h(ScaLAP)-11 b(A)l(CK)44 b(T)-11 b(est)45
-b(Suite)72 -66 y Fw(The)20 b(main)g(test)h(programs)f(for)g(the)h
-(ScaLAP)-8 b(A)m(CK)21 b(routines)f(are)g(lo)s(cated)i(in)e(the)g
-Fr(SCALAPACK/TESTING/LIN)-210 47 y Fw(and)h Fr(SCALAPACK/TESTING/EIG)15
-b Fw(sub)s(directories)21 b(and)g(are)h(called)g Fr(pd)p
-2213 47 29 4 v 2247 47 V 68 w(driver.f)e Fw(\()p Fr(ps)p
-2816 47 V 2849 47 V 68 w(driver.f)f Fw(for)-210 160 y(REAL,)28
-b Fr(pc)p 199 160 V 233 160 V 68 w(driver.f)e Fw(for)i(COMPLEX,)g(and)g
-Fr(pz)p 1607 160 V 1640 160 V 68 w(driver.f)e Fw(for)i(COMPLEX*16\),)i
-(where)d(the)p 3330 160 28 4 v 3363 160 V -210 273 a(is)41
-b(replaced)g(b)m(y)g Fr(lu)p Fw(,)i Fr(qr)p Fw(,)g Fr(llt)p
-Fw(,)g(and)d(so)h(on.)72 b(Eac)m(h)42 b(of)f(the)g(test)g(programs)g
-(for)f(the)h(ScaLAP)-8 b(A)m(CK)-210 386 y(routines)30
-b(has)g(a)h(similar)g(st)m(yle)g(of)g(input.)-69 499
-y(The)24 b(follo)m(wing)h(sections)g(describ)s(e)f(the)g(di\013eren)m
-(t)g(input)g(formats)g(and)f(testing)i(v)m(eri\014cations.)40
-b(The)-210 612 y(data)35 b(inside)f(the)g(input)f(\014les)h(is)h(only)f
-(test)h(data)g(designed)f(to)h(exercise)g(the)g(co)s(de.)52
-b(It)34 b(should)f(NOT)-210 725 y(b)s(e)i(in)m(terpreted)h(in)f(an)m(y)
-i(w)m(a)m(y)f(as)g(OPTIMAL)f(p)s(erformance)g(v)-5 b(alues)36
-b(for)g(an)m(y)g(of)g(the)g(routines.)56 b(F)-8 b(or)-210
-838 y(b)s(est)32 b(p)s(erformance,)h(the)g(v)-5 b(alue)33
-b(of)g(the)g(blo)s(c)m(ksize)h(NB)f(should)f(b)s(e)g(set)h(to)h(the)f
-(v)-5 b(alue)33 b(determined)f(b)m(y)-210 950 y(A)-8
-b(TLAS)30 b(as)h(optimal.)41 b(A)31 b(go)s(o)s(d)f(starting)h(p)s(oin)m
-(t)g(is)f(a)h(m)m(ultiple)g(of)f(16)i({)e(e.g.,)i(16,)g(32,)f(48,)h
-(64.)-69 1063 y(The)e(test)h(programs)f(for)g(the)h(routines)f(are)h
-(driv)m(en)f(b)m(y)g(separate)i(data)f(\014les.)-69 1176
-y(The)40 b(n)m(um)m(b)s(er)g(and)g(size)i(of)f(the)g(input)e(v)-5
-b(alues)42 b(are)f(limited)g(b)m(y)g(certain)h(program)e(maxim)m(ums)
--210 1289 y(whic)m(h)29 b(are)g(de\014ned)f(in)g(P)-8
-b(ARAMETER)29 b(statemen)m(ts)i(in)e(the)g(main)g(test)h(programs.)39
-b(These)29 b(program)-210 1402 y(maxim)m(ums)h(are:)-19
-1581 y(P)m(arameter)118 b(Description)2075 b(V)-8 b(alue)p
--69 1618 3380 4 v -19 1697 a(TOTMEM)99 b(T)-8 b(otal)32
-b(Memory)f(a)m(v)-5 b(ailable)33 b(for)d(testing)h(data)846
-b(2000000)-19 1810 y(INTGSZ)185 b(Length)30 b(in)h(b)m(ytes)f(to)i
-(store)f(a)f(INTEGER)g(elemen)m(t)879 b(4)-19 1923 y(REALSZ)169
-b(Length)30 b(in)h(b)m(ytes)f(to)i(store)f(a)f(REAL)g(elemen)m(t)1054
-b(4)-19 2036 y(DBLESZ)171 b(Length)30 b(in)h(b)m(ytes)f(to)i(store)f(a)
-f(DOUBLE)h(PRECISION)e(elemen)m(t)374 b(8)-19 2149 y(CPLXSZ)170
-b(Length)30 b(in)h(b)m(ytes)f(to)i(store)f(a)f(COMPLEX)g(elemen)m(t)839
-b(8)-19 2262 y(ZPLXSZ)180 b(Length)30 b(in)h(b)m(ytes)f(to)i(store)f(a)
-f(COMPLEX*16)h(elemen)m(t)657 b(16)-19 2374 y(NTESTS)166
-b(Maxim)m(um)31 b(n)m(um)m(b)s(er)e(of)i(tests)g(to)g(b)s(e)f(p)s
-(erformed)938 b(20)-69 2571 y(The)41 b(user)f(should)g(mo)s(dify)g
-(TOTMEM)h(to)g(indicate)i(the)e(maxim)m(um)g(amoun)m(t)g(of)g(memory)g
-(in)-210 2684 y(b)m(ytes)34 b(his)g(system)g(has)g(a)m(v)-5
-b(ailable.)53 b(Y)-8 b(ou)35 b(m)m(ust)f(remem)m(b)s(er)f(to)i(lea)m(v)
-m(e)h(ro)s(om)e(in)f(memory)h(for)g(the)g(op-)-210 2797
-y(erating)e(system,)g(the)g(BLA)m(CS)f(bu\013er,)g(etc.)44
-b(F)-8 b(or)32 b(example,)h(for)e(PVM,)h(the)f(parameters)h(w)m(e)g
-(use)f(are)-210 2910 y(TOTMEM=2,000,000,)41 b(and)c(the)f(length)i(of)e
-(a)i(DOUBLE)f(is)f(8.)61 b(Some)36 b(exp)s(erimen)m(ting)h(with)g(the)
--210 3023 y(maxim)m(um)g(allo)m(w)m(able)i(v)-5 b(alue)37
-b(of)g(TOTMEM)g(ma)m(y)g(b)s(e)f(required.)59 b(All)38
-b(arra)m(ys)f(used)f(b)m(y)h(the)g(factor-)-210 3136
-y(izations,)31 b(reductions,)f(solv)m(es,)h(and)e(condition)i(and)e
-(error)g(estimation)i(are)f(allo)s(cated)h(out)f(of)g(the)g(big)-210
-3249 y(arra)m(y)h(called)g(MEM.)-69 3361 y(Please)42
-b(note)f(that)g(these)f(parameter)h(maxim)m(ums)f(in)g(the)h(test)g
-(programs)f(assume)g(at)h(least)h(2)-210 3474 y(Megab)m(ytes)35
-b(of)e(memory)g(p)s(er)f(pro)s(cess.)48 b(Th)m(us,)33
-b(if)g(y)m(ou)g(do)g(not)g(ha)m(v)m(e)h(that)g(m)m(uc)m(h)f(space)g(p)s
-(er)f(pro)s(cess)-210 3587 y(then)e(y)m(ou)h(will)g(need)f(to)h(reduce)
-f(the)g(size)i(of)e(the)h(parameters.)-69 3700 y(F)-8
-b(or)37 b(eac)m(h)g(of)e(the)h(test)h(programs,)g(the)f(test)h(program)
-e(generates)i(test)g(matrices)g(\(nonsymmet-)-210 3813
-y(ric,)i(symmetric,)g(symmetric)e(p)s(ositiv)m(e-de\014nite,)j(or)d
-(upp)s(er)e(Hessen)m(b)s(erg\),)k(calls)f(the)f(ScaLAP)-8
-b(A)m(CK)-210 3926 y(routines)29 b(in)f(that)i(path,)f(and)f(computes)i
-(a)f(solv)m(e)h(and/or)f(factorization)i(and/or)e(reduction)g(residual)
--210 4039 y(error)24 b(c)m(hec)m(k)i(to)g(v)m(erify)f(that)g(eac)m(h)h
-(op)s(eration)f(has)f(p)s(erformed)f(correctly)-8 b(.)41
-b(The)24 b(factorization)j(residual)-210 4152 y(is)35
-b(only)g(calculated)i(if)e(the)h(residual)e(for)h(the)h(solv)m(e)g
-(step)f(exceeds)h(the)f(threshold)g(v)-5 b(alue)35 b(THRESH.)-210
-4265 y(Th)m(us,)30 b(if)g(a)h(user)e(w)m(an)m(ts)i(b)s(oth)f(c)m(hec)m
-(ks)i(automatically)h(done)d(then)g(he)h(should)e(set)i(THRESH)e(=)h
-(0.0.)-69 4378 y(When)35 b(the)h(tests)g(are)g(run,)g(eac)m(h)h(test)f
-(ratio)g(that)h(is)e(greater)i(than)e(or)h(equal)g(to)g(the)g
-(threshold)-210 4491 y(v)-5 b(alue)31 b(causes)g(a)f(line)h(of)g
-(information)f(to)h(b)s(e)f(prin)m(ted)g(to)h(the)g(output)f(\014le.)
--69 4603 y(A)e(table)g(of)g(timing)g(information)g(is)g(prin)m(ted)f
-(in)h(the)f(output)h(\014le)f(con)m(taining)j(execution)e(times)h(as)
--210 4716 y(w)m(ell)i(as)g(mega\015op)g(rates.)1545 4989
-y(12)p eop end
-%%Page: 13 13
-TeXDict begin 13 12 bop -69 -269 a Fw(After)31 b(all)g(of)g(the)f
-(tests)h(ha)m(v)m(e)h(b)s(een)d(completed,)j(summary)d(lines)i(are)g
-(prin)m(ted)f(of)g(the)h(form)-210 -83 y Fr(Finished)93
-b(180)47 b(tests,)f(with)h(the)g(following)e(results:)-115
-30 y(180)i(tests)g(completed)e(and)i(passed)f(residual)g(checks.)-19
-143 y(0)h(tests)g(completed)e(and)i(failed)f(residual)g(checks.)-19
-256 y(0)h(tests)g(skipped)f(because)f(of)j(illegal)d(input)i(values.)
--210 482 y(END)g(OF)g(TESTS.)-210 725 y Fm(3.1)112 b(T)-9
-b(ests)37 b(for)h(the)f(ScaLAP)-9 b(A)m(CK)37 b(LU)g(routines)-69
-897 y Fw(The)30 b(LU)g(test)i(program)e(generates)i(random)e
-(nonsymmetric)g(test)h(matrices)h(with)e(v)-5 b(alues)31
-b(in)f(the)-210 1010 y(in)m(terv)-5 b(al)23 b([-1,1],)i(calls)e(the)f
-(ScaLAP)-8 b(A)m(CK)22 b(routines)g(to)g(factor)h(and)e(solv)m(e)i(the)
-f(system,)i(and)d(computes)h(a)-210 1122 y(solv)m(e)32
-b(and/or)e(factorization)j(residual)d(error)g(c)m(hec)m(k)i(to)f(v)m
-(erify)g(that)g(eac)m(h)h(op)s(eration)e(has)g(p)s(erformed)-210
-1235 y(correctly)-8 b(.)88 b(Condition)45 b(estimation)i(and)e
-(iterativ)m(e)j(re\014nemen)m(t)d(routines)g(are)h(included)f(and)g
-(are)-210 1348 y(optionally)32 b(tested.)-69 1461 y(Sp)s(eci\014cally)
--8 b(,)32 b(eac)m(h)f(test)g(matrix)g(is)f(sub)5 b(jected)31
-b(to)g(the)f(follo)m(wing)i(tests:)-74 1672 y Fo(\017)46
-b Fw(F)-8 b(actor)33 b(the)d(matrix)h Fk(A)25 b Fw(=)g
-Fk(LU)40 b Fw(using)30 b(PxGETRF)-74 1859 y Fo(\017)46
-b Fw(Solv)m(e)32 b(the)e(system)h Fk(AX)i Fw(=)25 b Fk(B)34
-b Fw(using)c(PxGETRS,)g(and)g(compute)g(the)h(ratio)217
-2046 y Fi(SRESID)f Fw(=)25 b Fo(jj)p Fk(AX)j Fo(\000)20
-b Fk(B)5 b Fo(jj)p Fk(=)p Fw(\()p Fk(n)p Fo(jj)p Fk(A)p
-Fo(jj)15 b(jj)p Fk(X)7 b Fo(jj)p Fk(")p Fw(\))-74 2233
-y Fo(\017)46 b Fw(If)30 b Fi(SRESID)g Fk(>)g Fi(THRESH)p
-Fw(,)f(then)i(compute)f(the)h(ratio)217 2420 y Fi(FRESID)f
-Fw(=)25 b Fo(jj)p Fk(LU)31 b Fo(\000)20 b Fk(A)p Fo(jj)p
-Fk(=)p Fw(\()p Fk(n)p Fo(jj)p Fk(A)p Fo(jj)p Fk(")p Fw(\))-69
-2630 y(The)k(exp)s(ert)g(driv)m(er)g(\()p Fr(PxGESVX)p
-Fw(\))e(p)s(erforms)h(condition)i(estimation)g(and)f(iterativ)m(e)j
-(re\014nemen)m(t)d(and)-210 2743 y(th)m(us)30 b(incorp)s(orates)h(the)f
-(follo)m(wing)i(additional)f(test:)-74 2954 y Fo(\017)46
-b Fw(Compute)30 b(the)h(recipro)s(cal)g(condition)g(n)m(um)m(b)s(er)e
-(R)m(COND)i(using)f(PxGECON.)-74 3141 y Fo(\017)46 b
-Fw(Use)24 b(iterativ)m(e)i(re\014nemen)m(t)d(\(PxGERFS\))g(to)h(impro)m
-(v)m(e)g(the)g(solution,)h(and)e(recompute)g(the)h(ratio)217
-3328 y Fi(SRESID)30 b Fw(=)25 b Fo(jj)p Fk(AX)j Fo(\000)20
-b Fk(B)5 b Fo(jj)p Fk(=)p Fw(\()p Fk(n)p Fo(jj)p Fk(A)p
-Fo(jj)15 b(jj)p Fk(X)7 b Fo(jj)p Fk(")p Fw(\))-210 3567
-y Fq(3.1.1)105 b(Input)35 b(File)f(for)i(T)-9 b(esting)35
-b(the)f(ScaLAP)-9 b(A)m(CK)36 b(LU)f(Routines)72 3739
-y Fw(An)30 b(annotated)i(example)f(of)f(an)g(input)g(\014le)g(for)g
-(the)h(test)g(program)f(is)h(sho)m(wn)f(b)s(elo)m(w.)-210
-3950 y Fr('ScaLAPACK)45 b(LU)i(factorization)d(input)j(file')-210
-4063 y('MPI)g(machine.')-210 4175 y('lu.out')761 b(output)47
-b(file)f(name)h(\(if)g(any\))-210 4288 y(6)1097 b(device)47
-b(out)-210 4401 y(2)1097 b(number)47 b(of)g(problems)e(sizes)-210
-4514 y(250)i(553)810 b(values)47 b(of)g(N)-210 4627 y(3)1097
-b(number)47 b(of)g(NB's)-210 4740 y(2)g(3)h(5)906 b(values)47
-b(of)g(NB)1545 4989 y Fw(13)p eop end
-%%Page: 14 14
-TeXDict begin 14 13 bop -210 -269 a Fr(2)1097 b(number)47
-b(of)g(NRHS's)-210 -156 y(1)g(5)1002 b(values)47 b(of)g(NRHS)-210
--43 y(3)1097 b(Number)47 b(of)g(NBRHS's)-210 70 y(1)g(3)h(5)906
-b(values)47 b(of)g(NBRHS)-210 183 y(5)1097 b(Number)47
-b(of)g(processor)e(grids)h(\(ordered)g(pairs)g(of)h(P)h(&)f(Q\))-210
-296 y(1)g(4)h(2)f(1)h(8)715 b(values)47 b(of)g(P)-210
-409 y(1)g(2)h(4)f(8)h(1)715 b(values)47 b(of)g(Q)-210
-522 y(1.0)1001 b(threshold)-210 635 y(T)1097 b(\(T)48
-b(or)f(F\))g(Test)g(Cond.)f(Est.)h(and)g(Iter.)f(Ref.)h(Routines)-210
-878 y Fm(3.2)112 b(T)-9 b(ests)37 b(for)h(the)f(ScaLAP)-9
-b(A)m(CK)37 b(Band)h(and)g(T)-9 b(ridiagonal)39 b(LU)f(routines)-69
-1049 y Fw(The)33 b(LU)h(test)g(program)g(generates)h(random)e
-(nonsymmetric)g(band)g(test)i(matrices)f(with)g(v)-5
-b(alues)-210 1162 y(in)37 b(the)g(in)m(terv)-5 b(al)39
-b([-1,1],)i(calls)d(the)g(ScaLAP)-8 b(A)m(CK)37 b(routines)g(to)h
-(factor)h(and)d(solv)m(e)j(the)e(system,)j(and)-210 1275
-y(computes)27 b(a)g(solv)m(e)i(and/or)d(factorization)k(residual)d
-(error)f(c)m(hec)m(k)i(to)g(v)m(erify)f(that)h(eac)m(h)g(op)s(eration)f
-(has)-210 1388 y(p)s(erformed)i(correctly)-8 b(.)-69
-1501 y(Sp)s(eci\014cally)g(,)32 b(eac)m(h)f(test)g(matrix)g(is)f(sub)5
-b(jected)31 b(to)g(the)f(follo)m(wing)i(test:)-74 1712
-y Fo(\017)46 b Fw(Compute)32 b(the)g(Band)g(or)g(T)-8
-b(ridiagonal)33 b(LU)f(factorization)i(using)e(PxDBTRF)g(\(PxGBTRF)h
-(or)17 1825 y(PxDTTRF\))-74 2011 y Fo(\017)46 b Fw(Solv)m(e)28
-b(the)g(system)f Fk(AX)33 b Fw(=)25 b Fk(B)31 b Fw(using)c(PxDBTRS)f
-(\(PxGBTRS)h(or)h(PxDTTRS\),)e(and)h(compute)17 2124
-y(the)k(ratio)217 2311 y Fi(SRESID)f Fw(=)25 b Fo(jj)p
-Fk(AX)j Fo(\000)20 b Fk(B)5 b Fo(jj)p Fk(=)p Fw(\()p
-Fk(n)p Fo(jj)p Fk(A)p Fo(jj)15 b(jj)p Fk(X)7 b Fo(jj)p
-Fk(")p Fw(\))-210 2551 y Fq(3.2.1)105 b(Input)36 b(File)g(for)h(T)-9
-b(esting)36 b(the)g(ScaLAP)-9 b(A)m(CK)37 b(Band)f(and)g(T)-9
-b(ridiagonal)37 b(LU)f(Rou-)109 2664 y(tines)72 2836
-y Fw(An)30 b(annotated)i(example)f(of)f(an)g(input)g(\014le)g(for)g
-(the)h(test)g(program)f(is)h(sho)m(wn)f(b)s(elo)m(w.)-210
-3046 y Fr('ScaLAPACK,)45 b(Version)h(1.5,)g(banded)g(linear)g(systems)g
-(input)h(file')-210 3159 y('PVM.')-210 3272 y('')1431
-b(output)46 b(file)h(name)g(\(if)g(any\))-210 3385 y(6)1479
-b(device)46 b(out)-210 3498 y('T')1383 b(define)46 b(transpose)g(or)h
-(not)-162 3611 y(7)g(3)h(4)f(8)1527 b(number)46 b(of)h(problem)f(sizes)
--162 3724 y(2)h(5)h(17)f(28)g(37)g(121)g(200)g(1023)g(2048)f(3073)190
-b(values)46 b(of)h(N)-162 3837 y(6)1479 b(number)46 b(of)h(bandwidths)
--162 3950 y(1)g(2)h(3)f(15)g(6)95 b(8)621 b(values)46
-b(of)h(BWL)-162 4063 y(2)g(1)h(1)f(4)95 b(15)47 b(6)668
-b(values)46 b(of)i(BWU)-210 4175 y(1)1479 b(number)46
-b(of)i(NB's)-210 4288 y(-1)f(3)h(4)f(5)1145 b(values)46
-b(of)i(NB)f(\(-1)g(for)g(automatic)e(determination\))-210
-4401 y(1)1479 b(number)46 b(of)i(NRHS's)e(\(must)g(be)h(1\))-210
-4514 y(8)1479 b(values)46 b(of)i(NRHS)-210 4627 y(1)1479
-b(number)46 b(of)i(NBRHS's)d(\(ignored\))-210 4740 y(1)1479
-b(values)46 b(of)i(NBRHS)e(\(ignored\))1545 4989 y Fw(14)p
-eop end
-%%Page: 15 15
-TeXDict begin 15 14 bop -210 -269 a Fr(4)1432 b(number)46
-b(of)h(process)f(grids)-210 -156 y(1)h(2)h(3)f(4)h(5)f(7)h(8)f(15)g(26)
-h(47)f(64)286 b(values)46 b(of)h("Number)f(of)h(Process)f(Columns")-210
--43 y(3.0)1383 b(threshold)-210 199 y Fm(3.3)112 b(T)-9
-b(ests)37 b(for)h(the)f(ScaLAP)-9 b(A)m(CK)37 b(LL)-9
-b(T)37 b(routines)-69 371 y Fw(The)f(Cholesky)h(test)h(program)e
-(generates)i(random)e(symmetric)h(test)h(matrices)g(with)e(v)-5
-b(alues)37 b(in)-210 484 y(the)f(in)m(terv)-5 b(al)38
-b([-1,1])g(and)d(then)h(mo)s(di\014es)f(these)i(matrices)g(to)g(b)s(e)e
-(diagonally)j(dominan)m(t)e(with)g(p)s(osi-)-210 597
-y(tiv)m(e)c(diagonal)g(elemen)m(ts)g(th)m(us)e(creating)i(symmetric)f
-(p)s(ositiv)m(e-de\014nite)h(matrices.)42 b(It)31 b(then)f(calls)i(the)
--210 710 y(ScaLAP)-8 b(A)m(CK)31 b(routines)g(to)g(factor)h(and)e(solv)
-m(e)i(the)f(system,)h(and)e(computes)h(a)g(solv)m(e)h(and/or)f(factor-)
--210 823 y(ization)26 b(residual)d(error)h(c)m(hec)m(k)h(to)g(v)m
-(erify)f(that)h(eac)m(h)g(op)s(eration)g(has)e(p)s(erformed)g
-(correctly)-8 b(.)40 b(Condition)-210 935 y(estimation)32
-b(and)e(iterativ)m(e)j(re\014nemen)m(t)d(routines)g(are)h(included)e
-(and)h(optionally)i(tested.)-69 1048 y(Sp)s(eci\014cally)-8
-b(,)32 b(eac)m(h)f(test)g(matrix)g(is)f(sub)5 b(jected)31
-b(to)g(the)f(follo)m(wing)i(tests:)-74 1253 y Fo(\017)46
-b Fw(Compute)30 b(the)h(LL)-8 b(T)30 b(factorization)j(using)d(PxPOTRF)
--74 1437 y Fo(\017)46 b Fw(Solv)m(e)32 b(the)e(system)h
-Fk(AX)i Fw(=)25 b Fk(B)34 b Fw(using)c(PxPOTRS,)f(and)h(compute)h(the)f
-(ratio)217 1622 y Fi(SRESID)g Fw(=)25 b Fo(jj)p Fk(AX)j
-Fo(\000)20 b Fk(B)5 b Fo(jj)p Fk(=)p Fw(\()p Fk(n)p Fo(jj)p
-Fk(A)p Fo(jj)15 b(jj)p Fk(X)7 b Fo(jj)p Fk(")p Fw(\))-74
-1807 y Fo(\017)46 b Fw(IF)31 b Fi(SRESID)e Fk(>)h Fi(THRESH)p
-Fw(,)g(then)g(compute)h(the)f(ratio)217 1992 y Fi(FRESID)g
-Fw(=)25 b Fo(jj)p Fk(LL)858 1959 y Fh(T)934 1992 y Fo(\000)20
-b Fk(A)p Fo(jj)p Fk(=)p Fw(\()p Fk(n)p Fo(jj)p Fk(A)p
-Fo(jj)p Fk(")p Fw(\))-69 2196 y(The)k(exp)s(ert)g(driv)m(er)g(\()p
-Fr(PxPOSVX)p Fw(\))e(p)s(erforms)h(condition)i(estimation)g(and)f
-(iterativ)m(e)j(re\014nemen)m(t)d(and)-210 2309 y(th)m(us)30
-b(incorp)s(orates)h(the)f(follo)m(wing)i(additional)f(tests:)-74
-2514 y Fo(\017)46 b Fw(Compute)30 b(the)h(recipro)s(cal)g(condition)g
-(n)m(um)m(b)s(er)e(R)m(COND)i(using)f(PxPOCON.)-74 2698
-y Fo(\017)46 b Fw(Use)24 b(iterativ)m(e)i(re\014nemen)m(t)d
-(\(PxPORFS\))g(to)h(impro)m(v)m(e)g(the)g(solution,)h(and)e(recompute)g
-(the)h(ratio)217 2883 y Fi(SRESID)30 b Fw(=)25 b Fo(jj)p
-Fk(AX)j Fo(\000)20 b Fk(B)5 b Fo(jj)p Fk(=)p Fw(\()p
-Fk(n)p Fo(jj)p Fk(A)p Fo(jj)15 b(jj)p Fk(X)7 b Fo(jj)p
-Fk(")p Fw(\))-210 3122 y Fq(3.3.1)105 b(Input)35 b(File)f(for)i(T)-9
-b(esting)35 b(the)f(ScaLAP)-9 b(A)m(CK)36 b(LL)-9 b(T)34
-b(Routines)72 3294 y Fw(An)c(annotated)i(example)f(of)f(an)g(input)g
-(\014le)g(for)g(the)h(test)g(program)f(is)h(sho)m(wn)f(b)s(elo)m(w.)
--210 3498 y Fr('ScaLAPACK)45 b(LLT)i(factorization)d(input)i(file')-210
-3611 y('MPI)h(machine.')-210 3724 y('lltest.out')999
-b(output)46 b(file)h(name)f(\(if)h(any\))-210 3837 y(6)1479
-b(device)46 b(out)-210 3950 y(2)1479 b(number)46 b(of)i(problems)d
-(sizes)-210 4063 y(250)i(553)1192 b(values)46 b(of)i(N)-210
-4175 y(3)1479 b(number)46 b(of)i(NB's)-210 4288 y(2)f(3)h(5)1288
-b(values)46 b(of)i(NB)-210 4401 y(2)1479 b(number)46
-b(of)i(NRHS's)-210 4514 y(1)f(5)1384 b(values)46 b(of)i(NRHS)-210
-4627 y(3)1479 b(Number)46 b(of)i(NBRHS's)-210 4740 y(1)f(3)h(5)1288
-b(values)46 b(of)i(NBRHS)1545 4989 y Fw(15)p eop end
-%%Page: 16 16
-TeXDict begin 16 15 bop -210 -269 a Fr(5)1479 b(Number)46
-b(of)i(processor)d(grids)h(\(ordered)g(pairs)g(of)h(P)h(&)f(Q\))-210
--156 y(1)g(4)h(2)f(8)h(1)1097 b(values)46 b(of)i(P)-210
--43 y(1)f(2)h(4)f(1)h(8)1097 b(values)46 b(of)i(Q)-210
-70 y(1.0)1383 b(threshold)-210 183 y(T)1479 b(\(T)47
-b(or)h(F\))f(Test)f(Cond.)h(Est.)f(and)h(Iter.)g(Ref.)f(Routines)-210
-426 y Fm(3.4)112 b(T)-9 b(ests)37 b(for)h(the)f(ScaLAP)-9
-b(A)m(CK)37 b(Band)h(and)g(T)-9 b(ridiagonal)39 b(LL)-9
-b(T)37 b(routines)-69 598 y Fw(The)27 b(Cholesky)g(test)h(program)f
-(generates)h(random)f(symmetric)g(p)s(ositiv)m(e)h(de\014nite)g(band)e
-(or)h(tridi-)-210 711 y(agonal)e(test)f(matrices)h(with)e(v)-5
-b(alues)24 b(in)f(the)g(in)m(terv)-5 b(al)25 b([-1,1].)40
-b(It)24 b(then)f(calls)h(the)g(ScaLAP)-8 b(A)m(CK)24
-b(routines)-210 824 y(to)i(factor)h(and)e(solv)m(e)i(the)e(system,)i
-(and)e(computes)h(a)g(solv)m(e)h(residual)e(error)g(c)m(hec)m(k)i(to)g
-(v)m(erify)f(that)g(eac)m(h)-210 937 y(op)s(eration)31
-b(has)f(p)s(erformed)f(correctly)-8 b(.)-69 1050 y(Sp)s(eci\014cally)g
-(,)32 b(eac)m(h)f(test)g(matrix)g(is)f(sub)5 b(jected)31
-b(to)g(the)f(follo)m(wing)i(tests:)-74 1262 y Fo(\017)46
-b Fw(Compute)25 b(the)h(Band)f(or)g(T)-8 b(ridiagonal)27
-b(LL)-8 b(T)25 b(factorization)j(using)c(PxPBTRF)i(\(or)f(PxPTTRF\))-74
-1450 y Fo(\017)46 b Fw(Solv)m(e)32 b(the)e(system)h Fk(AX)i
-Fw(=)25 b Fk(B)34 b Fw(using)c(PxPBTRS)g(\(or)g(PxPTTRS\),)g(and)g
-(compute)g(the)h(ratio)217 1637 y Fi(SRESID)f Fw(=)25
-b Fo(jj)p Fk(AX)j Fo(\000)20 b Fk(B)5 b Fo(jj)p Fk(=)p
-Fw(\()p Fk(n)p Fo(jj)p Fk(A)p Fo(jj)15 b(jj)p Fk(X)7
-b Fo(jj)p Fk(")p Fw(\))-210 1878 y Fq(3.4.1)105 b(Input)39
-b(File)f(for)h(T)-9 b(esting)39 b(the)f(ScaLAP)-9 b(A)m(CK)40
-b(Band)f(or)g(T)-9 b(ridiagonal)39 b(LL)-9 b(T)38 b(Rou-)109
-1990 y(tines)72 2162 y Fw(An)30 b(annotated)i(example)f(of)f(an)g
-(input)g(\014le)g(for)g(the)h(test)g(program)f(is)h(sho)m(wn)f(b)s(elo)
-m(w.)-210 2375 y Fr('ScaLAPACK,)45 b(banded)h(linear)g(systems)g(input)
-g(file')-210 2488 y('PVM.')-210 2600 y('')1431 b(output)46
-b(file)h(name)g(\(if)g(any\))-210 2713 y(6)1479 b(device)46
-b(out)-210 2826 y('L')1383 b(define)46 b(Lower)h(or)g(Upper)-210
-2939 y(7)1479 b(number)46 b(of)i(problem)d(sizes)-210
-3052 y(1)i(5)h(17)f(28)g(37)g(121)g(200)572 b(values)46
-b(of)i(N)-210 3165 y(6)1479 b(number)46 b(of)i(bandwidths)-210
-3278 y(1)f(2)h(4)f(10)h(31)f(64)858 b(values)46 b(of)i(BW)-210
-3391 y(1)1479 b(number)46 b(of)i(NB's)-210 3504 y(-1)f(3)h(4)f(5)1145
-b(values)46 b(of)i(NB)f(\(-1)g(for)g(automatic)e(determination\))-210
-3617 y(1)1479 b(number)46 b(of)i(NRHS's)e(\(must)g(be)h(1\))-210
-3730 y(8)1479 b(values)46 b(of)i(NRHS)-210 3842 y(1)1479
-b(number)46 b(of)i(NBRHS's)d(\(ignored\))-210 3955 y(1)1479
-b(values)46 b(of)i(NBRHS)e(\(ignored\))-210 4068 y(4)1479
-b(number)46 b(of)i(process)d(grids)-210 4181 y(1)i(2)h(3)f(4)h(5)f(7)
-1002 b(values)46 b(of)i("Number)d(of)j(Process)d(Columns")-210
-4294 y(3.0)1383 b(threshold)1545 4989 y Fw(16)p eop end
-%%Page: 17 17
-TeXDict begin 17 16 bop -210 -269 a Fm(3.5)112 b(T)-9
-b(ests)37 b(for)h(the)f(ScaLAP)-9 b(A)m(CK)37 b(QR,)g(R)m(Q,)g(LQ,)h
-(QL,)g(QP)-9 b(,)37 b(and)h(TZ)g(routines)-69 -97 y Fw(The)43
-b(QR)g(test)i(program)e(generates)i(random)e(nonsymmetric)g(test)i
-(matrices)f(with)f(v)-5 b(alues)44 b(in)-210 16 y(the)c(in)m(terv)-5
-b(al)41 b([-1,1],)j(calls)c(the)g(ScaLAP)-8 b(A)m(CK)40
-b(routines)g(to)g(factor)h(the)e(system,)k(and)c(computes)h(a)-210
-129 y(factorization)33 b(residual)d(error)g(c)m(hec)m(k)i(to)f(v)m
-(erify)g(that)g(eac)m(h)h(op)s(eration)e(has)g(p)s(erformed)f
-(correctly)-8 b(.)-69 242 y(Sp)s(eci\014cally)g(,)32
-b(eac)m(h)f(test)g(matrix)g(is)f(sub)5 b(jected)31 b(to)g(the)f(follo)m
-(wing)i(tests:)-74 413 y Fo(\017)46 b Fw(Compute)28 b(the)g(QR)f
-(factorization)k(using)c(PxGEQRF,)h(and)g(generate)h(the)f(orthogonal)i
-(matrix)17 526 y Fk(Q)g Fw(from)g(the)h(Householder)f(v)m(ectors)-74
-700 y Fo(\017)46 b Fw(Compute)30 b(the)h(ratio)217 874
-y Fi(FRESID)f Fw(=)25 b Fo(jj)p Fk(QR)d Fo(\000)e Fk(A)p
-Fo(jj)p Fk(=)p Fw(\()p Fk(n)p Fo(jj)p Fk(A)p Fo(jj)p
-Fk(")p Fw(\))-69 1045 y(The)30 b(testing)h(of)f(the)g(R)m(Q,)g(LQ,)g
-(QL,)f(and)h(QP)f(routines)h(pro)s(ceeds)f(in)h(a)g(similar)g(fashion.)
-41 b(Simply)-210 1158 y(replace)34 b(all)g(o)s(ccurrences)f(of)g(QR)g
-(in)g(the)g(previous)g(discussion)f(with)h(R)m(Q,)h(LQ,)e(QL,)h(or)g
-(QP)g(resp)s(ec-)-210 1271 y(tiv)m(ely)-8 b(.)43 b(F)-8
-b(or)31 b(TZ,)f(the)g(factorization)j(routine)e(is)f(called)i(PxTZRZF.)
--210 1504 y Fq(3.5.1)105 b(Input)39 b(File)g(for)g(T)-9
-b(esting)40 b(the)f(ScaLAP)-9 b(A)m(CK)39 b(QR,)g(R)m(Q,)h(LQ,)e(QL,)h
-(QP)-9 b(,)39 b(and)g(TZ)109 1617 y(Routines)72 1789
-y Fw(An)30 b(annotated)i(example)f(of)f(an)g(input)g(\014le)g(for)g
-(the)h(test)g(program)f(is)h(sho)m(wn)f(b)s(elo)m(w.)-210
-1960 y Fr('ScaLAPACK,)45 b(Orthogonal)g(factorizations)f(input)i(file')
--210 2073 y('MPI)h(machine')-210 2186 y('QR.out')1143
-b(output)46 b(file)h(name)g(\(if)g(any\))-210 2299 y(6)1479
-b(device)46 b(out)-210 2412 y(6)1479 b(number)46 b(of)i(factorizations)
--210 2525 y('QR')f('QL')f('LQ')h('RQ')g('QP')f('TZ')142
-b(factorizations:)44 b(QR,)j(QL,)g(LQ,)g(RQ,)g(QP,)f(TZ)-210
-2638 y(4)1479 b(number)46 b(of)i(problems)d(sizes)-210
-2751 y(2)i(5)h(13)f(15)g(13)g(26)h(30)f(15)524 b(values)46
-b(of)i(M)-210 2864 y(2)f(7)h(8)95 b(10)47 b(17)g(20)h(30)f(35)524
-b(values)46 b(of)i(N)-210 2976 y(4)1479 b(number)46 b(of)i(blocking)d
-(sizes)-210 3089 y(4)i(3)h(5)f(5)h(4)f(6)1002 b(values)46
-b(of)i(MB)-210 3202 y(4)f(7)h(3)f(5)h(8)f(2)1002 b(values)46
-b(of)i(NB)-210 3315 y(4)1479 b(number)46 b(of)i(process)d(grids)i
-(\(ordered)e(pairs)i(P)g(&)h(Q\))-210 3428 y(1)f(2)h(1)f(4)h(2)f(3)h(8)
-906 b(values)46 b(of)i(P)-210 3541 y(1)f(2)h(4)f(1)h(3)f(2)h(1)906
-b(values)46 b(of)i(Q)-210 3654 y(3.0)1383 b(threshold)-210
-3891 y Fm(3.6)112 b(T)-9 b(ests)37 b(for)h(the)f(Linear)i(Least)f
-(Squares)g(\(LLS\))g(routines)-69 4063 y Fw(The)25 b(LLS)f(test)j
-(program)e(tests)h(the)g(PxGELS)e(driv)m(er)h(routine)h(for)f
-(computing)g(solutions)h(to)g(o)m(v)m(er-)-210 4175 y(and)36
-b(underdetermined,)g(full-rank)g(systems)g(of)h(linear)g(equations)g
-Fk(AX)43 b Fw(=)35 b Fk(B)41 b Fw(\()p Fk(A)c Fw(is)f
-Fk(m)p Fw(-b)m(y-)p Fk(n)p Fw(\).)59 b(F)-8 b(or)-210
-4288 y(eac)m(h)35 b(test)h(matrix)e(t)m(yp)s(e,)i(w)m(e)f(generate)h
-(three)e(matrices:)50 b(One)34 b(whic)m(h)g(is)g(scaled)h(near)f
-(under\015o)m(w,)h(a)-210 4401 y(matrix)c(with)f(mo)s(derate)h(norm,)e
-(and)h(one)h(whic)m(h)f(is)g(scaled)i(near)e(o)m(v)m(er\015o)m(w.)-69
-4514 y(The)20 b(PxGELS)f(driv)m(er)i(computes)f(the)g(least-squares)i
-(solutions)f(\(when)e Fk(m)25 b Fo(\025)g Fk(n)p Fw(\))20
-b(and)g(the)h(minim)m(um-)-210 4627 y(norm)35 b(solution)i(\(when)e
-Fk(m)g(<)f(n)p Fw(\))i(for)g(an)g Fk(m)p Fw(-b)m(y-)p
-Fk(n)g Fw(matrix)g Fk(A)g Fw(of)g(full)g(rank.)57 b(T)-8
-b(o)37 b(test)g(PxGELS,)e(w)m(e)-210 4740 y(generate)d(a)f(diagonally)h
-(dominan)m(t)e(matrix)h Fk(A)p Fw(,)g(and)e(for)h Fk(C)i
-Fw(=)25 b Fk(A)31 b Fw(and)e Fk(C)j Fw(=)25 b Fk(A)2537
-4707 y Fh(H)2604 4740 y Fw(,)31 b(w)m(e)1545 4989 y(17)p
-eop end
-%%Page: 18 18
-TeXDict begin 18 17 bop -74 -269 a Fo(\017)46 b Fw(generate)23
-b(a)e(consisten)m(t)h(righ)m(t-hand)f(side)f Fk(B)26
-b Fw(suc)m(h)20 b(that)h Fk(X)29 b Fw(is)20 b(in)h(the)g(range)g(space)
-g(of)g Fk(C)7 b Fw(,)23 b(compute)17 -156 y(a)31 b(matrix)g
-Fk(X)37 b Fw(using)30 b(PxGELS,)g(and)g(compute)h(the)f(ratio)1025
-48 y Fo(jj)p Fk(AX)f Fo(\000)20 b Fk(B)5 b Fo(jj)p Fk(=)p
-Fw(\(max)q(\()p Fk(m;)15 b(n)p Fw(\))p Fo(jj)p Fk(A)p
-Fo(jjjj)p Fk(X)7 b Fo(jj)p Fk(\017)p Fw(\))-74 290 y
-Fo(\017)46 b Fw(If)31 b Fk(C)39 b Fw(has)31 b(more)h(ro)m(ws)f(than)h
-(columns)f(\(i.e.)46 b(w)m(e)32 b(are)g(solving)g(a)h(least-squares)f
-(problem\),)g(form)17 403 y Fk(R)49 b Fw(=)f Fk(AX)37
-b Fo(\000)29 b Fk(B)5 b Fw(,)48 b(and)43 b(c)m(hec)m(k)j(whether)e
-Fk(R)h Fw(is)f(orthogonal)h(to)g(the)g(column)f(space)g(of)h
-Fk(A)f Fw(b)m(y)17 516 y(computing)976 629 y Fo(jj)p
-Fk(R)1096 591 y Fh(H)1164 629 y Fk(C)7 b Fo(jj)p Fk(=)p
-Fw(\(max)q(\()p Fk(m;)15 b(n;)g(nr)s(hs)p Fw(\))p Fo(jj)p
-Fk(A)p Fo(jjjj)p Fk(B)5 b Fo(jj)p Fk(\017)p Fw(\))-74
-833 y Fo(\017)46 b Fw(If)22 b Fk(C)28 b Fw(has)21 b(more)h(columns)g
-(than)g(ro)m(ws)f(\(i.e.)39 b(w)m(e)23 b(are)f(solving)g(an)g(o)m(v)m
-(erdetermined)h(system\),)h(c)m(hec)m(k)17 946 y(whether)36
-b(the)h(solution)g Fk(X)44 b Fw(is)37 b(in)f(the)h(ro)m(w)g(space)g(of)
-g Fk(C)43 b Fw(b)m(y)37 b(scaling)g(b)s(oth)f Fk(X)44
-b Fw(and)36 b Fk(C)43 b Fw(to)38 b(ha)m(v)m(e)17 1059
-y(norm)c(one,)h(and)f(forming)g(the)g(QR)g(factorization)i(of)f
-Fk(D)f Fw(=)d([)p Fk(A;)15 b(X)7 b Fw(])36 b(if)e Fk(C)k
-Fw(=)31 b Fk(A)2794 1026 y Fh(H)2861 1059 y Fw(,)36 b(and)d(the)h(LQ)17
-1172 y(factorization)29 b(of)d Fk(D)i Fw(=)d([)p Fk(A)932
-1139 y Fh(H)1000 1172 y Fk(;)15 b(X)7 b Fw(])1147 1139
-y Fh(H)1241 1172 y Fw(if)26 b Fk(C)32 b Fw(=)25 b Fk(A)p
-Fw(.)39 b(Letting)27 b Fk(E)k Fw(=)25 b Fk(D)s Fw(\()p
-Fk(n)g Fw(:)g Fk(n)12 b Fw(+)g Fk(nr)s(hs;)j(n)d Fw(+)g(1)p
-Fk(;)j(n)d Fw(+)g Fk(nr)s(hs)p Fw(\))17 1285 y(in)34
-b(the)g(\014rst)f(case,)j(and)d Fk(E)j Fw(=)30 b Fk(D)s
-Fw(\()p Fk(m)23 b Fw(+)f(1)31 b(:)h Fk(m)22 b Fw(+)g
-Fk(nr)s(hs;)15 b(m)22 b Fw(+)g(1)31 b(:)g Fk(m)23 b Fw(+)f
-Fk(nr)s(hs)p Fw(\))33 b(in)g(the)h(latter,)i(w)m(e)17
-1398 y(compute)1132 1510 y(max)15 b Fo(j)p Fk(d)1388
-1524 y Fh(ij)1449 1510 y Fo(j)p Fk(=)p Fw(\(max)q(\()p
-Fk(m;)g(n;)g(nr)s(hs)p Fw(\))p Fk(\017)p Fw(\))-210 1751
-y Fq(3.6.1)105 b(Input)35 b(File)f(for)i(T)-9 b(esting)35
-b(the)f(ScaLAP)-9 b(A)m(CK)36 b(LLS)e(Routines)72 1922
-y Fw(An)c(annotated)i(example)f(of)f(an)g(input)g(\014le)g(for)g(the)h
-(test)g(program)f(is)h(sho)m(wn)f(b)s(elo)m(w.)-210 2135
-y Fr('ScaLAPACK)45 b(LLS)i(input)f(file')-210 2248 y('MPI)h(machine')
--210 2361 y('LS.out')1143 b(output)46 b(file)h(name)g(\(if)g(any\))-210
-2473 y(6)1479 b(device)46 b(out)-210 2586 y(3)1479 b(number)46
-b(of)i(problems)d(sizes)-210 2699 y(55)i(17)g(31)1145
-b(values)46 b(of)i(M)-210 2812 y(5)f(71)h(31)1192 b(values)46
-b(of)i(N)-210 2925 y(3)1479 b(number)46 b(of)i(NB's)-210
-3038 y(2)f(3)h(5)1288 b(values)46 b(of)i(NB)-210 3151
-y(3)1479 b(number)46 b(of)i(NRHS's)-210 3264 y(2)f(3)h(5)1288
-b(values)46 b(of)i(NRHS)-210 3377 y(2)1479 b(number)46
-b(of)i(NBRHS's)-210 3490 y(1)f(2)1384 b(values)46 b(of)i(NBRHS)-210
-3603 y(4)1479 b(number)46 b(of)i(process)d(grids)i(\(ordered)e(pairs)i
-(P)g(&)h(Q\))-210 3715 y(1)f(2)h(1)f(4)h(2)f(3)h(8)906
-b(values)46 b(of)i(P)-210 3828 y(1)f(2)h(4)f(1)h(3)f(2)h(1)906
-b(values)46 b(of)i(Q)-210 3941 y(4.0)1383 b(threshold)-210
-4185 y Fm(3.7)112 b(T)-9 b(ests)37 b(for)h(the)f(ScaLAP)-9
-b(A)m(CK)37 b(INV)f(routines)-69 4356 y Fw(The)22 b(in)m(v)m(ersion)g
-(test)h(driv)m(er)f(tests)h(\014v)m(e)f(di\013eren)m(t)g(matrix)h(t)m
-(yp)s(es)f({)g(general)h(nonsymmetric)f(\(GEN\),)-210
-4469 y(general)31 b(upp)s(er)c(or)j(lo)m(w)m(er)h(triangular)f(\(UTR)g
-(and)f(L)-8 b(TR\),)30 b(and)f(symmetric)h(p)s(ositiv)m(e)h(de\014nite)
-f(\(upp)s(er)-210 4582 y(or)g(lo)m(w)m(er)i(triangular\))f(\(UPD)g(or)g
-(LPD\).)1545 4989 y(18)p eop end
-%%Page: 19 19
-TeXDict begin 19 18 bop -74 -269 a Fo(\017)46 b Fw(If)22
-b(GEN,)i(compute)f(the)g(LU)f(factorization)k(using)c(PxGETRF,)h(and)f
-(then)g(compute)h(the)g(in)m(v)m(erse)17 -156 y(b)m(y)31
-b(in)m(v)m(oking)g(PxGETRI)-74 32 y Fo(\017)46 b Fw(If)32
-b(UTR)f(or)h(L)-8 b(TR,)32 b(set)h(UPLO='U')f(or)f(UPLO='L')h(resp)s
-(ectiv)m(ely)-8 b(,)34 b(and)e(compute)g(the)g(in)m(v)m(erse)17
-145 y(b)m(y)f(in)m(v)m(oking)g(PxTR)-8 b(TRI)-74 332
-y Fo(\017)46 b Fw(If)39 b(UPD)h(or)g(LPD,)g(set)g(UPLO='U')f(or)h
-(UPLO='L')f(resp)s(ectiv)m(ely)-8 b(,)43 b(compute)d(the)g(Cholesky)17
-445 y(factorization)33 b(using)d(PxPOTRF,)g(and)g(then)g(compute)h(the)
-f(in)m(v)m(erse)h(b)m(y)g(in)m(v)m(oking)g(PxPOTRI)-74
-633 y Fo(\017)46 b Fw(Compute)30 b(the)h(ratio)217 821
-y Fi(FRESID)f Fw(=)25 b Fo(jj)p Fk(AA)870 788 y Fg(\000)p
-Fv(1)986 821 y Fo(\000)20 b Fk(I)7 b Fo(jj)p Fk(=)p Fw(\()p
-Fk(n)p Fo(jj)p Fk(A)p Fo(jj)p Fk(")p Fw(\))-210 1061
-y Fq(3.7.1)105 b(Input)35 b(File)f(for)i(T)-9 b(esting)35
-b(the)f(ScaLAP)-9 b(A)m(CK)36 b(INV)e(Routines)72 1232
-y Fw(An)c(annotated)i(example)f(of)f(an)g(input)g(\014le)g(for)g(the)h
-(test)g(program)f(is)h(sho)m(wn)f(b)s(elo)m(w.)-210 1445
-y Fr('ScaLAPACK,)45 b(Matrix)h(Inversion)f(Testing)h(input)g(file')-210
-1558 y('MPI)h(machine.')-210 1671 y('INV.out')1095 b(output)46
-b(file)h(name)g(\(if)g(any\))-210 1784 y(6)1479 b(device)46
-b(out)-210 1896 y(5)1479 b(number)46 b(of)i(matrix)e(types)g(\(next)g
-(line\))-210 2009 y('GEN')g('UTR')h('LTR')f('UPD')g('LPD')142
-b(GEN,)47 b(UTR,)g(LTR,)f(UPD,)h(LPD)-210 2122 y(4)1479
-b(number)46 b(of)i(problems)d(sizes)-210 2235 y(2)i(5)h(10)f(15)g(13)g
-(20)h(30)f(50)524 b(values)46 b(of)i(N)-210 2348 y(4)1479
-b(number)46 b(of)i(NB's)-210 2461 y(2)f(3)h(4)f(5)h(6)f(20)954
-b(values)46 b(of)i(NB)-210 2574 y(4)1479 b(number)46
-b(of)i(process)d(grids)i(\(ordered)e(P)j(&)f(Q\))-210
-2687 y(1)g(2)h(1)f(4)h(2)f(3)h(8)906 b(values)46 b(of)i(P)-210
-2800 y(1)f(1)h(4)f(1)h(3)f(2)h(1)906 b(values)46 b(of)i(Q)-210
-2913 y(1.0)1383 b(threshold)-210 3156 y Fm(3.8)112 b(T)-9
-b(ests)37 b(for)h(the)f(ScaLAP)-9 b(A)m(CK)37 b(HRD)f(routines)-69
-3328 y Fw(The)23 b(HRD)i(test)f(program)g(generates)h(random)e
-(nonsymmetric)h(test)h(matrices)g(with)e(v)-5 b(alues)24
-b(in)g(the)-210 3441 y(in)m(terv)-5 b(al)25 b([-1,1],)j(calls)d(the)f
-(ScaLAP)-8 b(A)m(CK)25 b(routines)f(to)h(reduce)e(the)i(test)g(matrix)f
-(to)h(upp)s(er)d(Hessen)m(b)s(erg)-210 3554 y(form,)48
-b(and)c(computes)g(a)h(reduction)g(residual)f(error)g(c)m(hec)m(k)i(to)
-g(v)m(erify)e(that)i(eac)m(h)f(op)s(eration)g(has)-210
-3666 y(p)s(erformed)29 b(correctly)-8 b(.)-69 3779 y(Sp)s(eci\014cally)
-g(,)32 b(eac)m(h)f(test)g(matrix)g(is)f(sub)5 b(jected)31
-b(to)g(the)f(follo)m(wing)i(tests:)-74 3992 y Fo(\017)46
-b Fw(Reduce)31 b(the)f(matrix)h Fk(A)f Fw(to)i(upp)s(er)c(Hessen)m(b)s
-(erg)i(form)g Fk(H)38 b Fw(using)29 b(PxGEHRD)217 4180
-y Fk(Q)289 4147 y Fh(T)364 4180 y Fo(\003)21 b Fk(A)f
-Fo(\003)h Fk(Q)k Fw(=)g Fk(H)7 b Fw(.)-74 4367 y Fo(\017)46
-b Fw(and)30 b(compute)h(the)f(ratio)217 4555 y Fi(FRESID)g
-Fw(=)25 b Fo(jj)p Fk(Q)c Fo(\003)g Fk(H)27 b Fo(\003)20
-b Fk(Q)1133 4522 y Fh(T)1209 4555 y Fo(\000)g Fk(A)p
-Fo(jj)p Fk(=)p Fw(\()p Fk(n)p Fo(jj)p Fk(A)p Fo(jj)p
-Fk(")p Fw(\))1545 4989 y(19)p eop end
-%%Page: 20 20
-TeXDict begin 20 19 bop -210 -269 a Fq(3.8.1)105 b(Input)35
-b(File)f(for)i(T)-9 b(esting)35 b(the)f(ScaLAP)-9 b(A)m(CK)36
-b(HRD)f(Routines)72 -97 y Fw(An)30 b(annotated)i(example)f(of)f(an)g
-(input)g(\014le)g(for)g(the)h(test)g(program)f(is)h(sho)m(wn)f(b)s(elo)
-m(w.)-210 112 y Fr('ScaLAPACK)45 b(HRD)i(input)f(file')-210
-225 y('MPI)h(machine.')-210 338 y('HRD.out')713 b(output)47
-b(file)f(name)h(\(if)g(any\))-210 451 y(6)1097 b(device)47
-b(out)-210 564 y(1)1097 b(number)47 b(of)g(problems)e(sizes)-210
-677 y(100)i(101)810 b(values)47 b(of)g(N)-210 790 y(1)g(1)1002
-b(values)47 b(of)g(ILO)-210 903 y(100)g(101)810 b(values)47
-b(of)g(IHI)-210 1016 y(1)1097 b(number)47 b(of)g(NB's)-210
-1129 y(2)g(1)h(2)f(3)h(4)f(5)620 b(values)47 b(of)g(NB)-210
-1242 y(1)1097 b(number)47 b(of)g(processor)e(grids)h(\(ordered)g(pairs)
-g(of)h(P)h(&)f(Q\))-210 1354 y(2)g(1)h(4)906 b(values)47
-b(of)g(P)-210 1467 y(2)g(4)h(1)906 b(values)47 b(of)g(Q)-210
-1580 y(1.0)1001 b(threshold)-210 1823 y Fm(3.9)112 b(T)-9
-b(ests)37 b(for)h(the)f(ScaLAP)-9 b(A)m(CK)37 b(TRD)f(routines)-69
-1995 y Fw(The)g(TRD)g(test)h(program)f(generates)i(random)d(symmetric)i
-(test)g(matrices)g(with)f(v)-5 b(alues)37 b(in)f(the)-210
-2108 y(in)m(terv)-5 b(al)30 b([-1,1],)h(calls)f(the)f(ScaLAP)-8
-b(A)m(CK)29 b(routines)f(to)i(reduce)e(the)h(test)g(matrix)g(to)h
-(symmetric)f(tridi-)-210 2221 y(agonal)37 b(form,)e(and)g(computes)g(a)
-h(reduction)e(residual)h(error)g(c)m(hec)m(k)h(to)g(v)m(erify)g(that)f
-(eac)m(h)h(op)s(eration)-210 2334 y(has)30 b(p)s(erformed)f(correctly)
--8 b(.)-69 2447 y(Sp)s(eci\014cally)g(,)32 b(eac)m(h)f(test)g(matrix)g
-(is)f(sub)5 b(jected)31 b(to)g(the)f(follo)m(wing)i(tests:)-74
-2656 y Fo(\017)46 b Fw(Reduce)31 b(the)f(symmetric)h(matrix)g
-Fk(A)f Fw(to)h(symmetric)g(tridiagonal)h(form)e Fk(T)43
-b Fw(using)30 b(PxSYTRD)217 2843 y Fk(Q)289 2810 y Fh(T)364
-2843 y Fo(\003)21 b Fk(A)f Fo(\003)h Fk(Q)k Fw(=)g Fk(T)13
-b Fw(.)-74 3029 y Fo(\017)46 b Fw(and)30 b(compute)h(the)f(ratio)217
-3216 y Fi(FRESID)g Fw(=)25 b Fo(jj)p Fk(Q)c Fo(\003)g
-Fk(T)33 b Fo(\003)20 b Fk(Q)1116 3183 y Fh(T)1191 3216
-y Fo(\000)g Fk(A)p Fo(jj)p Fk(=)p Fw(\()p Fk(n)p Fo(jj)p
-Fk(A)p Fo(jj)p Fk(")p Fw(\))-210 3456 y Fq(3.9.1)105
-b(Input)35 b(File)f(for)i(T)-9 b(esting)35 b(the)f(SCALAP)-9
-b(A)m(CK)35 b(TRD)g(Routines)72 3627 y Fw(An)30 b(annotated)i(example)f
-(of)f(an)g(input)g(\014le)g(for)g(the)h(test)g(program)f(is)h(sho)m(wn)
-f(b)s(elo)m(w.)-210 3837 y Fr('ScaLAPACK)45 b(TRD)i(computation)e
-(input)h(file')-210 3950 y('MPI)h(machine.')-210 4063
-y('TRD.out')332 b(output)46 b(file)g(name)-210 4175 y(6)716
-b(device)46 b(out)-210 4288 y('L')620 b(define)46 b(Lower)g(or)h(Upper)
--210 4401 y(2)716 b(number)46 b(of)h(problems)e(sizes)-210
-4514 y(16)i(17)g(100)g(101)143 b(values)46 b(of)h(N)-210
-4627 y(3)716 b(number)46 b(of)h(NB's)-210 4740 y(3)g(4)h(5)525
-b(values)46 b(of)h(NB)1545 4989 y Fw(20)p eop end
-%%Page: 21 21
-TeXDict begin 21 20 bop -210 -269 a Fr(3)716 b(Number)46
-b(of)h(processor)e(grids)i(\(ordered)e(pairs)h(of)i(P)f(&)h(Q\))-210
--156 y(2)f(4)h(1)525 b(values)46 b(of)h(P)-210 -43 y(2)g(1)h(4)525
-b(values)46 b(of)h(Q)-210 70 y(1.0)620 b(threshold)-210
-308 y Fm(3.10)112 b(T)-9 b(ests)37 b(for)h(the)f(ScaLAP)-9
-b(A)m(CK)37 b(BRD)f(routines)-69 480 y Fw(The)h(BRD)i(test)g(program)e
-(generates)i(random)e(nonsymmetric)h(test)h(matrices)g(with)e(v)-5
-b(alues)38 b(in)-210 593 y(the)h(in)m(terv)-5 b(al)41
-b([-1,1],)i(calls)d(the)g(ScaLAP)-8 b(A)m(CK)39 b(routines)g(to)h
-(reduce)f(the)g(test)h(matrix)g(to)g(upp)s(er)d(or)-210
-706 y(lo)m(w)m(er)h(bidiagonal)f(form,)h(and)d(computes)i(a)g
-(reduction)f(residual)g(error)g(c)m(hec)m(k)i(to)f(v)m(erify)g(that)g
-(eac)m(h)-210 819 y(op)s(eration)31 b(has)f(p)s(erformed)f(correctly)-8
-b(.)-69 932 y(Sp)s(eci\014cally)g(,)32 b(eac)m(h)f(test)g(matrix)g(is)f
-(sub)5 b(jected)31 b(to)g(the)f(follo)m(wing)i(tests:)-74
-1111 y Fo(\017)46 b Fw(Reduce)31 b(the)f(matrix)h Fk(A)f
-Fw(to)i(upp)s(er)c(or)i(lo)m(w)m(er)i(bidiagonal)f(form)f
-Fk(B)35 b Fw(using)30 b(PxGEBRD)217 1288 y Fk(Q)289 1255
-y Fh(T)364 1288 y Fo(\003)21 b Fk(A)f Fo(\003)h Fk(P)38
-b Fw(=)25 b Fk(B)5 b Fw(.)-74 1464 y Fo(\017)46 b Fw(and)30
-b(compute)h(the)f(ratio)217 1641 y Fi(FRESID)g Fw(=)25
-b Fo(jj)p Fk(Q)c Fo(\003)g Fk(B)j Fo(\003)d Fk(P)1123
-1608 y Fh(T)1198 1641 y Fo(\000)f Fk(A)p Fo(jj)p Fk(=)p
-Fw(\()p Fk(n)p Fo(jj)p Fk(A)p Fo(jj)p Fk(")p Fw(\))-210
-1876 y Fq(3.10.1)106 b(Input)34 b(File)h(for)g(T)-9 b(esting)35
-b(the)f(ScaLAP)-9 b(A)m(CK)36 b(BRD)g(Routines)72 2047
-y Fw(An)30 b(annotated)i(example)f(of)f(an)g(input)g(\014le)g(for)g
-(the)h(test)g(program)f(is)h(sho)m(wn)f(b)s(elo)m(w.)-210
-2227 y Fr('ScaLAPACK)45 b(BRD)i(input)f(file')-210 2340
-y('MPI)h(machine.')-210 2452 y('BRD.out')332 b(output)46
-b(file)g(name)h(\(if)g(any\))-210 2565 y(6)716 b(device)46
-b(out)-210 2678 y(3)716 b(number)46 b(of)h(problems)e(sizes)-210
-2791 y(16)i(14)g(25)h(15)f(16)95 b(values)46 b(of)h(M)-210
-2904 y(9)95 b(13)47 b(20)h(15)f(16)95 b(values)46 b(of)h(N)-210
-3017 y(2)716 b(number)46 b(of)h(NB's)-210 3130 y(3)g(4)h(5)525
-b(values)46 b(of)h(NB)-210 3243 y(3)716 b(Number)46 b(of)h(processor)e
-(grids)i(\(ordered)e(pairs)h(of)i(P)f(&)h(Q\))-210 3356
-y(2)f(4)h(1)525 b(values)46 b(of)h(P)-210 3469 y(2)g(1)h(4)525
-b(values)46 b(of)h(Q)-210 3582 y(1.0)620 b(threshold)-210
-3820 y Fm(3.11)112 b(T)-9 b(ests)37 b(for)h(the)f(ScaLAP)-9
-b(A)m(CK)37 b(SEP)f(routines)72 3991 y Fw(The)22 b(follo)m(wing)i
-(tests)g(will)f(b)s(e)e(p)s(erformed)g(on)i(PxSYEV/PxHEEV,)g
-(PxSYEVX/PxHEEVX)-210 4104 y(and)30 b(PxSYEVD/PxHEEVD:)1090
-4413 y Fk(r)1131 4427 y Fv(1)1254 4413 y Fw(=)1514 4352
-y Fo(k)p Fk(AZ)d Fo(\000)20 b Fk(Z)7 b(L)p Fo(k)p 1417
-4392 663 4 v 1417 4476 a Fk(abstol)22 b Fw(+)e Fk(ul)r(p)30
-b Fo(k)p Fk(A)p Fo(k)1090 4701 y Fk(r)1131 4715 y Fv(2)1254
-4701 y Fw(=)1417 4639 y Fo(k)q Fk(Z)1532 4606 y Fg(\003)1571
-4639 y Fk(Z)c Fo(\000)20 b Fk(I)7 b Fo(k)p 1417 4680
-426 4 v 1472 4763 a Fk(ul)r(p)30 b Fo(k)p Fk(A)p Fo(k)1545
-4989 y Fw(21)p eop end
-%%Page: 22 22
-TeXDict begin 22 21 bop -210 -269 a Fw(where)34 b Fk(Z)40
-b Fw(is)34 b(the)h(matrix)f(of)g(eigen)m(v)m(ectors)j(returned)c(when)g
-(the)i(eigen)m(v)m(ector)i(option)e(is)f(giv)m(en,)i
-Fk(L)e Fw(is)-210 -156 y(the)e(matrix)g(of)g(eigen)m(v)-5
-b(alues,)35 b Fk(ul)r(p)c Fw(represen)m(ts)h(PxLAMCH\()g(ICTXT,)f('P')h
-(\),)g(and)g Fk(abstol)h Fw(represen)m(ts)-210 -43 y
-Fk(ul)r(p)20 b Fo(\003)h(k)p Fk(A)p Fo(k)q Fw(.)-69 70
-y(The)33 b(tester)h(allo)m(ws)g(m)m(ultiple)g(test)f(requests)g(to)h(b)
-s(e)e(con)m(trolled)j(from)e(a)g(single)h(input)e(\014le.)48
-b(Eac)m(h)-210 183 y(test)31 b(request)g(is)f(con)m(trolled)i(b)m(y)e
-(the)h(follo)m(wing)h(inputs:)-165 395 y(V)-8 b(alues)32
-b(of)e(N)17 508 y(N)h(=)f(The)g(matrix)g(size)-165 696
-y(V)-8 b(alues)32 b(of)e(P)-8 b(,)31 b(Q,)f(NB)17 809
-y(P)g(=)g(NPR)m(O)m(W,)i(the)f(n)m(um)m(b)s(er)e(of)h(pro)s(cessor)g
-(ro)m(ws)17 922 y(Q)g(=)g(NPCOL,)g(the)h(n)m(um)m(b)s(er)e(of)h(pro)s
-(cessor)g(columns)17 1035 y(NB)h(=)f(the)h(blo)s(c)m(k)g(size)-165
-1222 y(V)-8 b(alues)32 b(of)e(the)h(matrix)g(t)m(yp)s(es)17
-1335 y(See)g(Section)g(3.11.1.)-165 1523 y(Num)m(b)s(er)f(of)g(eigen)i
-(requests)17 1636 y(1)f(=)f(T)-8 b(est)31 b(full)f(eigendecomp)s
-(osition)i(only)17 1749 y(8)f(=)f(T)-8 b(est)31 b(the)g(follo)m(wing)g
-(eigen)h(requests:)17 1862 y(F)-8 b(ull)31 b(eigendecomp)s(osition)17
-1975 y(All)g(eigen)m(v)-5 b(alues,)33 b(no)d(eigen)m(v)m(ectors)17
-2087 y(Eigen)m(v)-5 b(alues)32 b(requested)e(b)m(y)h(v)-5
-b(alue)30 b(\(i.e.)42 b(VL,VU\))17 2200 y(Eigen)m(v)-5
-b(alues)32 b(and)e(v)m(ectors)i(requested)e(b)m(y)g(v)-5
-b(alue)17 2313 y(Eigen)m(v)g(alues)32 b(requested)e(b)m(y)h(index)e
-(\(i.e.)42 b(IL,)31 b(IU\))17 2426 y(Eigen)m(v)-5 b(alues)32
-b(and)e(v)m(ectors)i(requested)e(b)m(y)g(index)17 2539
-y(F)-8 b(ull)31 b(eigendecomp)s(osition)h(with)e(minimal)h(w)m
-(orkspace)g(pro)m(vided)17 2652 y(F)-8 b(ull)31 b(eigendecomp)s
-(osition)h(with)e(random)g(w)m(orkspace)h(pro)m(vided)-165
-2840 y(Threshold)17 2953 y(The)f(highest)h(v)-5 b(alue)31
-b(of)f Fk(r)897 2967 y Fv(1)937 2953 y Fk(;)15 b(r)1018
-2967 y Fv(2)1088 2953 y Fw(and)30 b Fk(r)1306 2967 y
-Fv(3)1375 2953 y Fw(that)h(will)g(b)s(e)f(accepted.)-165
-3140 y(Absolute)h(tolerance)17 3253 y(Must)g(b)s(e)e(-1.0)j(to)f
-(ensure)f(orthogonal)i(eigen)m(v)m(ectors)-165 3441 y(Prin)m(t)f
-(Request)17 3554 y(1)g(=)f(Prin)m(t)g(ev)m(ery)i(test)17
-3667 y(2)f(=)f(Prin)m(t)g(only)h(failing)g(tests)g(and)f(a)h(summary)e
-(of)i(the)f(request)-210 3907 y Fq(3.11.1)106 b(T)-9
-b(est)34 b(Matrices)i(for)f(the)f(Symmetric)i(Eigen)m(v)-6
-b(alue)35 b(Routines)72 4078 y Fw(Tw)m(en)m(t)m(y-t)m(w)m(o)45
-b(di\013eren)m(t)e(t)m(yp)s(es)f(of)g(test)h(matrices)h(ma)m(y)e(b)s(e)
-g(generated)h(for)f(the)h(symmetric)-210 4191 y(eigen)m(v)-5
-b(alue)34 b(routines.)47 b(T)-8 b(able)32 b(1)h(sho)m(ws)f(the)h(t)m
-(yp)s(es,)g(along)g(with)f(the)g(n)m(um)m(b)s(ers)f(used)h(to)h(refer)f
-(to)h(the)-210 4304 y(matrix)24 b(t)m(yp)s(es.)38 b(Except)24
-b(as)g(noted,)h(all)g(matrices)f(ha)m(v)m(e)h(norm)e
-Fk(O)s Fw(\(1\).)39 b(The)23 b(expression)g Fk(U)10 b(D)s(U)3024
-4271 y Fg(\000)p Fv(1)3142 4304 y Fw(means)-210 4417
-y(a)33 b(real)g(diagonal)h(matrix)f Fk(D)i Fw(with)d(en)m(tries)h(of)g
-(magnitude)f Fk(O)s Fw(\(1\))i(conjugated)f(b)m(y)g(a)f(unitary)g(\(or)
-h(real)-210 4530 y(orthogonal\))f(matrix)f Fk(U)10 b
-Fw(.)1545 4989 y(22)p eop end
-%%Page: 23 23
-TeXDict begin 23 22 bop -126 -357 3433 4 v -128 -244
-4 113 v 1166 -244 V 1767 -278 a Fw(Eigen)m(v)-5 b(alue)32
-b(Distribution)p 3305 -244 V 1167 -240 2140 4 v -128
--131 4 113 v -77 -165 a(T)m(yp)s(e)p 1166 -131 V 1123
-w(Arithmetic)p 1764 -131 V 134 w(Geometric)p 2274 -131
-V 101 w(Clustered)p 2753 -131 V 209 w(Other)p 3305 -131
-V -126 -128 3433 4 v -128 -15 4 113 v -77 -49 a(Zero)p
-1166 -15 V 2753 -15 V 2908 w(1)p 3305 -15 V -126 -11
-3433 4 v -128 102 4 113 v -77 68 a(Iden)m(tit)m(y)p 1166
-102 V 2753 102 V 2773 w(2)p 3305 102 V -126 105 3433
-4 v -128 223 4 118 v -77 189 a(Diagonal)p 1166 223 V
-1171 w(3)p 1764 223 V 374 w(4,)f(6)2009 157 y Ff(y)2044
-189 y Fw(,)f(7)2144 157 y Ff(z)p 2274 223 V 2492 189
-a Fw(5)p 2753 223 V 3305 223 V -126 226 3433 4 v -128
-344 4 118 v -77 310 a Fk(U)10 b(D)s(U)145 277 y Fg(\000)p
-Fv(1)p 1166 344 V 1251 310 a Fw(8,)31 b(11)1442 278 y
-Ff(y)1477 310 y Fw(,)f(12)1622 278 y Ff(z)1657 310 y
-Fw(,)p 1764 344 V 224 w(9,)h(17)2097 278 y Ff(\003)p
-2274 344 V 2377 310 a Fw(10,)h(18)2614 278 y Ff(\003)p
-2753 344 V 3305 344 V -128 457 4 113 v 1166 457 V 1217
-423 a Fw(16)1307 391 y Ff(\003)1346 423 y Fw(,)f(19)1492
-391 y Fe(?)1531 423 y Fw(,)g(20)1677 391 y Ff(\017)p
-1764 457 V 2274 457 V 2753 457 V 3305 457 V -126 460
-3433 4 v -128 578 4 118 v -77 544 a Fw(Symmetric)g(w/Random)f(en)m
-(tries)p 1166 578 V 2753 578 V 1688 w(13,)h(14)3041 512
-y Ff(y)3076 544 y Fw(,)g(15)3222 512 y Ff(z)p 3305 578
-V -126 582 3433 4 v -128 695 4 113 v -77 661 a Fw(T)-8
-b(ridiagonal)p 1166 695 V 1764 695 V 2274 695 V 2753
-695 V 2591 w(21)3055 628 y Fe(a)p 3305 695 V -126 698
-3433 4 v -128 816 4 118 v -77 782 a Fw(Multiple)31 b(Clusters)p
-1166 816 V 1764 816 V 2274 816 V 2753 816 V 2355 w(22)3059
-750 y Fe(b)p 3305 816 V -126 819 3433 4 v -77 898 a Fo(y)p
-Fw({)g(matrix)g(en)m(tries)g(are)g Fe(O)r Ft(\()868 834
-y Ff(p)p 933 834 274 4 v 933 898 a Ft(o)n(v)n(er\015o)n(w\))-77
-1011 y Fo(z)p Fw({)g(matrix)g(en)m(tries)g(are)g Fe(O)r
-Ft(\()868 947 y Ff(p)p 933 947 327 4 v 933 1011 a Ft(under\015o)n(w)o
-(\))-77 1124 y Fo(\003)g Fw({)g(diagonal)g(en)m(tries)h(are)e(p)s
-(ositiv)m(e)-77 1237 y Fk(?)h Fw({)g(matrix)g(en)m(tries)g(are)f
-Fe(O)r Ft(\()903 1173 y Ff(p)p 968 1173 274 4 v 968 1237
-a Ft(o)n(v)n(er\015o)n(w\))g Fw(and)g(diagonal)i(en)m(tries)f(are)g(p)s
-(ositiv)m(e)-77 1350 y Fo(\017)g Fw({)g(matrix)g(en)m(tries)g(are)f
-Fe(O)r Ft(\()903 1286 y Ff(p)p 968 1286 327 4 v 968 1350
-a Ft(under\015o)n(w)o(\))h Fw(and)e(diagonal)j(en)m(tries)f(are)g(p)s
-(ositiv)m(e)-77 1463 y Fk(a)g Fw({)f(Some)h(of)f(the)h(immediately)h
-(o\013-diagonal)g(elemen)m(ts)g(are)f(zero)g(-)f(guaran)m(teeing)i
-(splitting)-77 1576 y Fk(b)f Fw({)f(Clusters)g(are)h(sized:)41
-b(1,)31 b(2,)g(4,)g(.)15 b(.)h(.)f(,)31 b(2)1358 1543
-y Fh(i)1386 1576 y Fw(.)379 1764 y(T)-8 b(able)31 b(1:)41
-b(T)-8 b(est)31 b(matrices)h(for)e(the)g(symmetric)h(eigen)m(v)-5
-b(alue)32 b(problem)-210 2039 y Fq(3.11.2)106 b(Input)33
-b(File)g(for)h(T)-9 b(esting)34 b(the)f(Symmetric)h(Eigen)m(v)-6
-b(alue)34 b(Routines)h(and)e(Driv)m(ers)72 2211 y Fw(An)28
-b(annotated)h(example)g(of)g(an)f(input)f(\014le)h(for)g(testing)i(the)
-e(symmetric)h(eigen)m(v)-5 b(alue)30 b(routines)-210
-2323 y(and)g(driv)m(ers)g(is)g(sho)m(wn)g(b)s(elo)m(w.)-210
-2536 y Fr('ScaLAPACK)45 b(Symmetric)g(Eigensolver)g(Test)i(File')-210
-2649 y(')g(')-210 2762 y('sep.out')1095 b(output)46 b(file)h(name)g
-(\(if)g(any\))-210 2875 y(6)1479 b(device)46 b(out)h(\(13)g(&)h(14)f
-(reserved)e(for)i(internal)f(testing\))-210 2988 y(4)95
-b(maximum)46 b(number)g(of)h(processes)-210 3101 y('N'disable)e(pxsyev)
-h(tests,)g(recommended)f(for)i(heterogeneous)d(systems.)-210
-3213 y(')j(')-210 3326 y('TEST)f(1)i(-)f(test)g(tiny)g(matrices)e(-)j
-(different)d(process)h(configurations')-210 3439 y(3)1479
-b(number)46 b(of)i(matrices)-210 3552 y(0)f(1)h(2)f(matrix)f(size)-210
-3665 y(1)h(number)g(of)g(uplo)f(choices)-210 3778 y('L'uplo)g(choices)
--210 3891 y(2)h(number)g(of)g(processor)e(configurations)f(\(P,)j(Q,)g
-(NB\))-210 4004 y(1)g(1)525 b(values)46 b(of)h(P)h(\(NPROW\))-210
-4117 y(2)f(1)143 b(values)46 b(of)i(Q)f(\(NPCOL\))-210
-4230 y(1)g(1)143 b(values)46 b(of)i(NB)-210 4343 y(1)f(number)g(of)g
-(matrix)f(types)-210 4455 y(8)191 b(matrix)46 b(types)g(\(see)h
-(pdseptst.f\))-210 4568 y('N'perform)e(subset)h(tests?)-210
-4681 y(80.0)h(Threshold)e(\(*)i(5)h(for)e(generalized)f(tests\))1545
-4989 y Fw(23)p eop end
-%%Page: 24 24
-TeXDict begin 24 23 bop -210 -269 a Fr(-1)95 b(Absolute)45
-b(Tolerance)-210 -156 y(')i(')-210 -43 y('End)g(of)g(tests')-210
-70 y(-1)-210 310 y Fm(3.12)112 b(T)-9 b(ests)37 b(for)h(the)f(ScaLAP)-9
-b(A)m(CK)37 b(GSEP)f(routines)-69 482 y Fw(Finding)23
-b(the)h(eigen)m(v)-5 b(alues)25 b(and)e(eigen)m(v)m(ectors)k(of)c
-(symmetric)h(matrices)g(A)g(and)f(B,)h(where)f(B)g(is)h(also)-210
-595 y(p)s(ositiv)m(e)32 b(de\014nite,)g(follo)m(ws)h(the)e(same)h
-(stages)h(as)e(the)h(symmetric)g(eigen)m(v)-5 b(alue)33
-b(problem)e(except)h(that)-210 708 y(the)24 b(problem)g(is)g(\014rst)f
-(reduced)g(from)g(generalized)j(to)f(standard)e(form)g(using)h
-(PxSYGST/PxHEGST.)-69 821 y(T)-8 b(o)31 b(c)m(hec)m(k)h(these)f
-(calculations,)h(the)f(follo)m(wing)h(test)f(ratios)g(are)g(computed:)
-191 1049 y Fk(r)232 1063 y Fv(1)355 1049 y Fw(=)519 987
-y Fo(k)p Fk(A)15 b(Z)27 b Fo(\000)20 b Fk(B)g(Z)h(D)s
-Fo(k)p 519 1027 605 4 v 533 1111 a(k)p Fk(A)p Fo(k)31
-b(k)q Fk(Z)7 b Fo(k)30 b Fk(n)15 b(ul)r(p)509 1235 y
-Fw(calling)32 b(PxSYGVX/PxHEGVX)f(with)f(ITYPE=1)g(and)g(UPLO='U')191
-1421 y Fk(r)232 1435 y Fv(2)355 1421 y Fw(=)519 1359
-y Fo(k)p Fk(A)15 b(Z)27 b Fo(\000)20 b Fk(B)g(Z)h(D)s
-Fo(k)p 519 1400 V 533 1483 a(k)p Fk(A)p Fo(k)31 b(k)q
-Fk(Z)7 b Fo(k)30 b Fk(n)15 b(ul)r(p)509 1607 y Fw(calling)32
-b(PxSYGVX/PxHEGVX)f(with)f(ITYPE=1)g(and)g(UPLO='L')191
-1793 y Fk(r)232 1807 y Fv(5)355 1793 y Fw(=)519 1731
-y Fo(k)p Fk(A)15 b(Z)27 b Fo(\000)20 b Fk(B)g(Z)h(D)s
-Fo(k)p 519 1772 V 533 1855 a(k)p Fk(A)p Fo(k)31 b(k)q
-Fk(Z)7 b Fo(k)30 b Fk(n)15 b(ul)r(p)509 1979 y Fw(calling)32
-b(PxSYGVX/PxHEEVX)f(with)f(ITYPE=2)g(and)f(UPLO='U')191
-2165 y Fk(r)232 2179 y Fv(8)355 2165 y Fw(=)519 2103
-y Fo(k)p Fk(A)15 b(B)20 b(Z)27 b Fo(\000)20 b Fk(Z)h(D)s
-Fo(k)p 519 2144 V 533 2227 a(k)p Fk(A)p Fo(k)31 b(k)q
-Fk(Z)7 b Fo(k)30 b Fk(n)15 b(ul)r(p)509 2351 y Fw(calling)32
-b(PxSYGVX/PxHEEVX)f(with)f(ITYPE=2)g(and)f(UPLO='L')156
-2537 y Fk(r)197 2551 y Fv(10)355 2537 y Fw(=)519 2475
-y Fo(k)p Fk(A)15 b(B)20 b(Z)27 b Fo(\000)20 b Fk(Z)h(D)s
-Fo(k)p 519 2516 V 533 2599 a(k)p Fk(A)p Fo(k)31 b(k)q
-Fk(Z)7 b Fo(k)30 b Fk(n)15 b(ul)r(p)509 2723 y Fw(calling)32
-b(PxSYGVX/PxHEEVX)f(with)f(ITYPE=3)g(and)f(UPLO='U')156
-2909 y Fk(r)197 2923 y Fv(12)355 2909 y Fw(=)519 2848
-y Fo(k)p Fk(B)20 b(A)15 b(Z)27 b Fo(\000)20 b Fk(Z)h(D)s
-Fo(k)p 519 2888 V 533 2971 a(k)p Fk(A)p Fo(k)31 b(k)q
-Fk(Z)7 b Fo(k)30 b Fk(n)15 b(ul)r(p)509 3096 y Fw(calling)32
-b(PxSYGVX/PxHEEVX)f(with)f(ITYPE=3)g(and)f(UPLO='L')156
-3281 y Fk(r)197 3295 y Fv(14)355 3281 y Fw(=)519 3220
-y Fo(k)p Fk(B)20 b(A)15 b(Z)27 b Fo(\000)20 b Fk(Z)h(D)s
-Fo(k)p 519 3260 V 533 3343 a(k)p Fk(A)p Fo(k)31 b(k)q
-Fk(Z)7 b Fo(k)30 b Fk(n)15 b(ul)r(p)3274 3468 y Fw(\(1\))-210
-3705 y Fq(3.12.1)106 b(Input)32 b(File)h(for)h(T)-9 b(esting)33
-b(the)g(Generalized)h(Symmetric)g(Eigen)m(v)-6 b(alue)33
-b(Routines)162 3818 y(and)i(Driv)m(ers)72 3989 y Fw(The)c(input)f
-(\014le)h(for)f(testing)i(the)g(generalized)g(symmetric)f(eigen)m(v)-5
-b(alue)33 b(routines)e(and)f(driv)m(ers)-210 4102 y(is)j(the)g(same)h
-(as)f(that)g(for)g(testing)h(the)f(symmetric)h(eigenproblem)f
-(routines.)48 b(Refer)33 b(to)h(the)f(Section)-210 4215
-y(3.11.2)g(for)d(further)f(details.)-210 4455 y Fm(3.13)112
-b(T)-9 b(ests)37 b(for)h(the)f(ScaLAP)-9 b(A)m(CK)37
-b(NEP)f(routines)-69 4627 y Fw(The)31 b(PxLAHQR)h(test)h(program)e
-(generates)i(random)e(upp)s(er)f(Hessen)m(b)s(erg)i(matrices,)i
-(completes)-210 4740 y(a)26 b(Sc)m(h)m(ur)g(decomp)s(osition)g(on)g
-(them,)h(and)e(then)h(tests)g(the)g(resulting)g(Sc)m(h)m(ur)g(decomp)s
-(osition)g(for)g(main-)1545 4989 y(24)p eop end
-%%Page: 25 25
-TeXDict begin 25 24 bop -210 -269 a Fw(taining)31 b(similarit)m(y)-8
-b(.)43 b(The)30 b(follo)m(wing)h(tests)g(will)g(b)s(e)f(p)s(erformed)f
-(on)h(P)p 2238 -269 28 4 v 33 w(LAHQR:)1148 108 y Fk(r)1189
-122 y Fv(1)1312 108 y Fw(=)1476 -76 y Fd(\015)1476 -26
-y(\015)1476 23 y(\015)1522 21 y Fk(H)d Fo(\000)20 b Fk(QS)5
-b(Q)1921 -12 y Fh(T)1976 -76 y Fd(\015)1976 -26 y(\015)1976
-23 y(\015)p 1476 87 547 4 v 1548 170 a Fk(n)15 b(ul)r(p)30
-b Fo(k)p Fk(H)7 b Fo(k)1148 449 y Fk(r)1189 463 y Fv(2)1312
-449 y Fw(=)1476 265 y Fd(\015)1476 315 y(\015)1476 365
-y(\015)1522 363 y Fk(I)27 b Fo(\000)20 b Fk(Q)1752 330
-y Fh(T)1807 363 y Fk(Q)1879 265 y Fd(\015)1879 315 y(\015)1879
-365 y(\015)p 1476 428 450 4 v 1602 511 a Fk(n)15 b(ul)r(p)3274
-669 y Fw(\(2\))-210 854 y(where)39 b Fk(Q)g Fw(is)g(the)h(Sc)m(h)m(ur)e
-(v)m(ectors)j(of)e(the)h(upp)s(er)d(Hessen)m(b)s(erg)i(matrix)h
-Fk(H)46 b Fw(when)38 b(the)i(Sc)m(h)m(ur)e(v)m(ector)-210
-967 y(and)j(Sc)m(h)m(ur)h(decomp)s(osition)g(option)h(is)f(giv)m(en.)77
-b Fk(N)52 b Fw(is)42 b(the)g(order)f(of)i(the)f(matrix,)j
-Fk(ul)r(p)d Fw(represen)m(ts)-210 1079 y(PxLAMCH\()31
-b(ICTXT,)e('P')i(\),)g(and)f(the)g(one-norm)g(is)h(used)e(for)i(the)f
-(norm)g(computations.)-210 1316 y Fq(3.13.1)106 b(Input)34
-b(File)h(for)g(T)-9 b(esting)35 b(the)f(ScaLAP)-9 b(A)m(CK)36
-b(NEP)f(Routines)72 1488 y Fw(An)30 b(annotated)i(example)f(of)f(an)g
-(input)g(\014le)g(for)g(the)h(test)g(program)f(is)h(sho)m(wn)f(b)s(elo)
-m(w.)-210 1681 y Fr('SCALAPACK)45 b(NEP)i(\(Nonsymmetric)d(Eigenvalue)h
-(Problem\))h(input)g(file')-210 1794 y('MPI)h(Machine')-210
-1906 y('NEP.out')713 b(output)47 b(file)f(name)h(\(if)g(any\))-210
-2019 y(6)1097 b(device)47 b(out)-210 2132 y(8)1097 b(number)47
-b(of)g(problems)e(sizes)-210 2245 y(1)i(2)h(3)f(4)h(6)f(10)g(100)g(200)
-190 b(values)47 b(of)g(N)-210 2358 y(3)1097 b(number)47
-b(of)g(NB's)-210 2471 y(6)g(20)h(40)810 b(values)47 b(of)g(NB)-210
-2584 y(4)1097 b(number)47 b(of)g(process)f(grids)g(\(ordered)f(pairs)i
-(of)g(P)g(&)h(Q\))-210 2697 y(1)f(2)h(1)f(4)811 b(values)47
-b(of)g(P)-210 2810 y(1)g(2)h(4)f(1)811 b(values)47 b(of)g(Q)-210
-2923 y(20.0)953 b(threshold)-210 3163 y Fm(3.14)112 b(T)-9
-b(ests)37 b(for)h(the)f(ScaLAP)-9 b(A)m(CK)37 b(EV)m(C)f(routines)-69
-3335 y Fw(The)27 b(PCTREV)m(C/PZTREV)m(C)g(test)h(program)f(p)s
-(erforms)f(a)i(righ)m(t)g(and)f(left)h(eigen)m(v)m(ector)j(calcula-)
--210 3447 y(tion)g(of)f(a)h(triangular)g(matrix)g(follo)m(w)m(ed)h(b)m
-(y)e(a)h(residual)f(c)m(hec)m(ks)i(of)e(the)h(calculated)h(eigen)m(v)m
-(ectors.)-69 3560 y(The)e(follo)m(wing)i(tests)f(will)g(b)s(e)e(p)s
-(erformed)g(on)i(P)p 1639 3560 28 4 v 32 w(TREV)m(C.)f(The)g(basic)h
-(test)g(is:)1171 3883 y Fk(r)1212 3897 y Fv(1)1335 3883
-y Fw(=)1499 3821 y Fo(k)p Fk(H)7 b(Z)27 b Fo(\000)20
-b Fk(Z)7 b(D)s Fo(k)p 1499 3862 500 4 v 1557 3945 a Fk(n)15
-b(ul)r(p)30 b Fo(k)p Fk(T)13 b Fo(k)3274 4108 y Fw(\(3\))-210
-4292 y(using)30 b(the)g(1-norm.)41 b(It)31 b(also)g(tests)g(the)g
-(normalization)h(of)e Fk(Z)7 b Fw(.)832 4519 y Fk(r)873
-4533 y Fv(2)995 4519 y Fw(=)1159 4458 y Fk(max)1339 4472
-y Fh(j)1390 4458 y Fo(k)q Fk(m)20 b Fo(\000)g Fk(nor)s(m)p
-Fw(\()p Fk(Z)7 b Fw(\()p Fk(j)e Fw(\)\))20 b Fo(\000)g
-Fw(1)p Fo(k)q Fw(\))p 1159 4498 1180 4 v 1650 4582 a
-Fk(n)15 b(ul)r(p)3274 4740 y Fw(\(4\))1545 4989 y(25)p
-eop end
-%%Page: 26 26
-TeXDict begin 26 25 bop -210 -269 a Fw(where)39 b Fk(H)47
-b Fw(is)40 b(the)g(upp)s(er)e(Hessen)m(b)s(erg)i(matrix,)i
-Fk(n)e Fw(is)f(the)i(order)e(of)h(the)g(matrix,)j Fk(Z)7
-b Fw(\()p Fk(j)e Fw(\))40 b(is)g(the)g(j-th)-210 -156
-y(eigen)m(v)m(ector,)51 b(and)43 b(m-norm)g(is)h(the)g(max-norm)g(of)g
-(a)h(v)m(ector,)k(and)43 b Fk(ul)r(p)h Fw(represen)m(ts)g(PxLAMCH\()
--210 -43 y(ICTXT,)e('P')h(\).)g(The)f(max-norm)g(of)h(a)g(complex)h
-(n-v)m(ector)g Fk(x)e Fw(in)h(this)f(case)i(is)e(the)h(maxim)m(um)g(of)
--210 70 y Fo(k)p Fk(r)s(e)p Fw(\()p Fk(x)p Fw(\()p Fk(i)p
-Fw(\)\))p Fo(k)33 b Fw(+)d Fo(k)p Fk(im)p Fw(\()p Fk(x)p
-Fw(\()p Fk(i)p Fw(\)\))p Fo(k)j Fw(o)m(v)m(er)f Fk(i)25
-b Fw(=)g(1)p Fk(;)15 b(:)g(:)g(:)i(;)e(n)p Fw(.)-210
-306 y Fq(3.14.1)106 b(Input)34 b(File)h(for)g(T)-9 b(esting)35
-b(the)f(ScaLAP)-9 b(A)m(CK)36 b(EV)m(C)e(Routines)72
-478 y Fw(An)c(annotated)i(example)f(of)f(an)g(input)g(\014le)g(for)g
-(the)h(test)g(program)f(is)h(sho)m(wn)f(b)s(elo)m(w.)-210
-664 y Fr('SCALAPACK)45 b(NEP)i(\(Nonsymmetric)d(Eigenvalue)h(Problem\))
-h(input)g(file')-210 777 y('MPI)h(Machine')-210 890 y('EVC.out')713
-b(output)47 b(file)f(name)h(\(if)g(any\))-210 1003 y(6)1097
-b(device)47 b(out)-210 1116 y(1)1097 b(number)47 b(of)g(problems)e
-(sizes)-210 1229 y(100)i(1000)g(1500)f(2000)h(2500)f(3000)190
-b(Probs)-210 1342 y(1)1097 b(number)47 b(of)g(NB's)-210
-1455 y(8)1050 b(values)46 b(of)h(NB)-210 1568 y(4)1097
-b(number)47 b(of)g(process)f(grids)g(\(ordered)f(pairs)i(of)g(P)g(&)h
-(Q\))-210 1681 y(1)f(1)h(4)f(2)h(3)f(2)h(2)f(1)525 b(values)46
-b(of)h(P)-210 1793 y(1)g(4)h(1)f(2)h(3)f(1)h(4)f(8)525
-b(values)46 b(of)h(Q)-210 1906 y(20.0)953 b(threshold)-210
-2146 y Fm(3.15)112 b(T)-9 b(ests)37 b(for)h(the)f(ScaLAP)-9
-b(A)m(CK)37 b(SVD)g(routines)-69 2317 y Fw(The)c(follo)m(wing)i(tests)f
-(will)g(b)s(e)e(p)s(erformed)g(on)h(PSGESVD/PDGESVD.)i(A)e(n)m(um)m(b)s
-(er)f(of)i(matrix)-210 2430 y(\\t)m(yp)s(es")e(are)f(sp)s(eci\014ed,)g
-(as)g(denoted)g(in)g(T)-8 b(able)31 b(2.)43 b(F)-8 b(or)32
-b(eac)m(h)g(t)m(yp)s(e)f(of)g(matrix,)h(and)e(for)h(the)g(minimal)-210
-2543 y(w)m(orkspace)c(as)g(w)m(ell)g(as)g(for)f(larger)i(than)e
-(minimal)h(w)m(orkspace)g(an)f Fk(M)10 b Fw(-b)m(y)p
-Fk(N)37 b Fw(matrix)27 b(\\A")g(with)f(kno)m(wn)-210
-2656 y(singular)k(v)-5 b(alues)30 b(is)g(generated)h(and)f(used)f(to)i
-(test)g(the)f(SVD)g(routines.)40 b(F)-8 b(or)31 b(eac)m(h)g(matrix,)g
-(A)f(will)h(b)s(e)-210 2769 y(factored)g(as)g Fk(A)56
-b Fw(=)f Fk(U)40 b(diag)s Fw(\()p Fk(S)5 b Fw(\))32 b
-Fk(V)21 b(T)43 b Fw(and)30 b(the)g(follo)m(wing)i(9)f(tests)g
-(computed:)62 3085 y Fk(r)103 3099 y Fv(1)226 3085 y
-Fw(=)389 3024 y Fo(k)q Fk(A)20 b Fo(\000)g Fk(U)10 b
-Fw(1diag)q(\()p Fk(S)5 b Fw(1\))p Fk(V)21 b(T)13 b Fw(1)p
-Fo(k)p 389 3064 916 4 v 461 3148 a(k)p Fk(A)p Fo(k)j
-Fw(max\()p Fk(M)5 b(;)15 b(N)10 b Fw(\))15 b Fk(ul)r(p)62
-3387 y(r)103 3401 y Fv(2)226 3387 y Fw(=)389 3204 y Fd(\015)389
-3253 y(\015)389 3303 y(\015)435 3301 y Fk(I)28 b Fo(\000)20
-b Fw(\()p Fk(U)10 b Fw(1\))781 3268 y Fh(T)837 3301 y
-Fk(U)g Fw(1)954 3204 y Fd(\015)954 3253 y(\015)954 3303
-y(\015)p 389 3366 612 4 v 575 3450 a Fk(M)25 b(ul)r(p)62
-3684 y(r)103 3698 y Fv(3)226 3684 y Fw(=)389 3501 y Fd(\015)389
-3550 y(\015)389 3600 y(\015)435 3598 y Fk(I)j Fo(\000)20
-b Fk(V)g(T)13 b Fw(1\()p Fk(V)21 b(T)13 b Fw(1\))1033
-3565 y Fh(T)1088 3501 y Fd(\015)1088 3550 y(\015)1088
-3600 y(\015)p 389 3663 746 4 v 649 3747 a Fk(N)25 b(ul)r(p)62
-3945 y(r)103 3959 y Fv(4)226 3945 y Fw(=)379 3801 y Fd(\()488
-3883 y Fw(0)156 b(if)30 b Fk(S)5 b Fw(1)31 b(con)m(tains)g(SIZE)f
-(nonnegativ)m(e)i(v)-5 b(alues)30 b(in)g(decreasing)h(order.)529
-3960 y Fv(1)p 498 3975 99 4 v 498 4027 a Fh(ul)q(p)689
-3996 y Fw(otherwise)62 4210 y Fk(r)103 4224 y Fv(5)226
-4210 y Fw(=)446 4148 y Fo(k)q Fk(S)5 b Fw(1)21 b Fo(\000)e
-Fk(S)5 b Fw(2)p Fo(k)p 389 4189 530 4 v 389 4272 a Fk(S)g(I)i(Z)g(E)20
-b(M)26 b Fo(k)p Fk(S)5 b Fo(k)62 4458 y Fk(r)103 4472
-y Fv(6)226 4458 y Fw(=)389 4396 y Fo(k)q Fk(U)10 b Fw(1)20
-b Fo(\000)g Fk(U)10 b Fw(2)p Fo(k)p 389 4437 437 4 v
-488 4520 a Fk(M)25 b(ul)r(p)62 4701 y(r)103 4715 y Fv(7)226
-4701 y Fw(=)461 4639 y Fo(k)p Fk(S)5 b Fw(1)21 b Fo(\000)f
-Fk(S)5 b Fw(3)p Fo(k)p 389 4680 558 4 v 389 4763 a Fk(S)g(I)i(Z)g(E)20
-b(ul)r(p)15 b Fo(k)q Fk(S)5 b Fo(k)1545 4989 y Fw(26)p
-eop end
-%%Page: 27 27
-TeXDict begin 27 26 bop 62 -230 a Fk(r)103 -216 y Fv(8)226
--230 y Fw(=)389 -292 y Fo(k)q Fk(V)20 b(T)13 b Fw(1)20
-b Fo(\000)g Fk(V)g(T)13 b Fw(3)p Fo(k)p 389 -251 571
-4 v 562 -168 a Fk(N)25 b(ul)r(p)62 13 y(r)103 27 y Fv(9)226
-13 y Fw(=)468 -49 y Fo(k)q Fk(S)5 b Fw(1)20 b Fo(\000)g
-Fk(S)5 b Fw(4)p Fo(k)p 389 -8 574 4 v 389 75 a Fk(S)g(I)i(Z)g(E)20
-b(ul)r(p)30 b Fo(k)q Fk(S)5 b Fo(k)-210 239 y Fw(where)30
-b Fk(ul)r(p)g Fw(represen)m(ts)g(PxLAMCH\(ICTXT,)g('P'\).)-210
-475 y Fq(3.15.1)106 b(T)-9 b(est)34 b(Matrices)i(for)f(the)f(Singular)i
-(V)-9 b(alue)35 b(Decomp)s(osition)h(Routines)72 646
-y Fw(Six)c(di\013eren)m(t)h(t)m(yp)s(es)g(of)f(test)i(matrices)f(ma)m
-(y)g(b)s(e)f(generated)h(for)f(the)h(singular)f(v)-5
-b(alue)33 b(decom-)-210 759 y(p)s(osition)e(routines.)44
-b(T)-8 b(able)32 b(2)f(sho)m(ws)g(the)h(t)m(yp)s(es)f(a)m(v)-5
-b(ailable,)34 b(along)e(with)f(the)h(n)m(um)m(b)s(ers)e(used)g(to)i
-(refer)-210 872 y(to)i(the)g(matrix)g(t)m(yp)s(es.)51
-b(Except)34 b(as)g(noted,)h(all)f(matrix)g(t)m(yp)s(es)g(other)g(than)f
-(the)h(random)f(bidiagonal)-210 985 y(matrices)40 b(ha)m(v)m(e)g
-Fk(O)s Fw(\(1\))g(en)m(tries.)67 b(The)38 b(expression)h
-Fk(U)10 b(D)s(V)59 b Fw(means)38 b(a)i(real)f(diagonal)h(matrix)g
-Fk(D)h Fw(with)-210 1098 y Fk(O)s Fw(\(1\))31 b(en)m(tries)g(m)m
-(ultiplied)g(b)m(y)g(unitary)f(\(or)g(real)h(orthogonal\))h(matrices)g
-(on)e(the)h(left)g(and)f(righ)m(t.)p 766 1215 1648 4
-v 764 1328 4 113 v 1217 1328 V 1268 1294 a(Singular)g(V)-8
-b(alue)31 b(Distribution)p 2412 1328 V 1218 1331 1196
-4 v 764 1441 4 113 v 816 1407 a(T)m(yp)s(e)p 1217 1441
-V 247 w(Arithmetic)p 1748 1441 V 267 w(Other)p 2412 1441
-V 766 1444 1648 4 v 764 1557 4 113 v 816 1523 a(Zero)p
-1217 1557 V 1748 1557 V 1066 w(1)p 2412 1557 V 766 1560
-1648 4 v 764 1673 4 113 v 816 1639 a(Iden)m(tit)m(y)p
-1217 1673 V 1748 1673 V 931 w(2)p 2412 1673 V 766 1676
-1648 4 v 764 1789 4 113 v 816 1755 a(Diagonal)p 1217
-1789 V 295 w(3)p 1748 1789 V 2412 1789 V 766 1793 1648
-4 v 764 1911 4 118 v 816 1877 a Fk(U)10 b(D)s(V)p 1217
-1911 V 307 w Fw(4,)31 b(5)1472 1845 y Ff(y)1507 1877
-y Fw(,)f(6)1607 1845 y Ff(z)p 1748 1911 V 2412 1911 V
-766 1914 1648 4 v 816 1993 a Fo(y)p Fw({)h(matrix)g(en)m(tries)g(are)g
-Fe(O)r Ft(\()1761 1929 y Ff(p)p 1825 1929 274 4 v 64
-x Ft(o)n(v)n(er\015o)n(w)q(\))816 2106 y Fo(z)p Fw({)g(matrix)g(en)m
-(tries)g(are)g Fe(O)r Ft(\()1761 2042 y Ff(p)p 1825 2042
-327 4 v 64 x Ft(under\015o)n(w\))406 2294 y Fw(T)-8 b(able)31
-b(2:)41 b(T)-8 b(est)31 b(matrices)g(for)f(the)h(singular)f(v)-5
-b(alue)31 b(decomp)s(osition)-210 2616 y Fq(3.15.2)106
-b(Input)34 b(File)h(for)g(T)-9 b(esting)35 b(the)f(ScaLAP)-9
-b(A)m(CK)36 b(SVD)f(Routines)72 2787 y Fw(An)30 b(annotated)i(example)f
-(of)f(an)g(input)g(\014le)g(for)g(the)h(test)g(program)f(is)h(sho)m(wn)
-f(b)s(elo)m(w.)-210 2973 y Fr('ScaLAPACK)45 b(Singular)h(Value)g
-(Decomposition)92 b(input)46 b(file')-210 3086 y(6)1479
-b(device)46 b(out)-210 3199 y(4)h(maxnodes)-210 3312
-y(')g(')-210 3425 y('TEST)f(1)i(-)f(test)g(medium)f(matrices)g(-)h(all)
-g(types)f(and)h(requests')-210 3538 y(20.0)1335 b(Threshold)-210
-3651 y(1)1479 b(number)46 b(of)i(matrices)-210 3764 y(100)1383
-b(number)46 b(of)i(rows)-210 3877 y(25)1431 b(number)46
-b(of)i(columns)-210 3990 y(1)1479 b(number)46 b(of)i(processor)d
-(configurations)f(\(P,)j(Q,)g(NB\))-210 4102 y(2)1479
-b(values)46 b(of)i(P)f(\(NPROW\))-210 4215 y(2)1479 b(values)46
-b(of)i(Q)f(\(NPCOL\))-210 4328 y(8)1479 b(values)46 b(of)i(NB)-210
-4441 y(')f(')-210 4554 y('End)g(of)g(tests')-210 4667
-y(-1)1545 4989 y Fw(27)p eop end
-%%Page: 28 28
-TeXDict begin 28 27 bop -210 354 a Fc(App)5 b(endix)64
-b(A)-210 769 y Fs(ScaLAP)-19 b(A)-6 b(CK)77 b(Routines)-69
-1214 y Fw(In)22 b(this)h(app)s(endix,)g(w)m(e)g(review)h(the)f
-(subroutine)e(naming)i(sc)m(heme)h(for)e(ScaLAP)-8 b(A)m(CK)24
-b(and)e(indicate)-210 1327 y(b)m(y)32 b(means)g(of)h(a)g(table)g(whic)m
-(h)f(subroutines)f(are)h(included)g(in)g(this)g(release.)48
-b(W)-8 b(e)33 b(also)h(list)f(the)f(driv)m(er)-210 1440
-y(routines.)-69 1553 y(Eac)m(h)39 b(subroutine)f(name)g(in)g(ScaLAP)-8
-b(A)m(CK,)40 b(whic)m(h)e(has)g(an)h(LAP)-8 b(A)m(CK)39
-b(equiv)-5 b(alen)m(t,)42 b(is)c(simply)-210 1666 y(the)f(LAP)-8
-b(A)m(CK)36 b(name)g(prep)s(ended)f(b)m(y)h(a)g Fr(P)p
-Fw(.)h(All)g(names)f(consist)h(of)f(sev)m(en)h(c)m(haracters)h(in)e
-(the)g(form)-210 1779 y(PTXXYYY.)31 b(The)f(second)g(letter,)i(T,)e
-(indicates)i(the)e(matrix)h(data)g(t)m(yp)s(e)g(as)f(follo)m(ws:)-210
-1966 y(S)257 b(REAL)-210 2079 y(D)239 b(DOUBLE)31 b(PRECISION)-210
-2192 y(C)242 b(COMPLEX)-210 2305 y(Z)252 b(COMPLEX*16)31
-b(\(if)g(a)m(v)-5 b(ailable\))-69 2493 y(The)34 b(next)h(t)m(w)m(o)g
-(letters,)i(XX,)e(indicate)g(the)g(t)m(yp)s(e)f(of)h(matrix.)53
-b(Most)35 b(of)g(these)f(t)m(w)m(o-letter)k(co)s(des)-210
-2606 y(apply)e(to)h(b)s(oth)f(real)h(and)e(complex)i(routines;)j(a)d
-(few)f(apply)g(sp)s(eci\014cally)h(to)g(one)f(or)h(the)f(other,)j(as)
--210 2718 y(indicated)31 b(b)s(elo)m(w:)-210 2931 y(DB)175
-b(general)31 b(band)f(\(diagonally-dominan)m(t)j(lik)m(e\))-210
-3044 y(DT)173 b(general)31 b(tridiagonal)h(\(diagonally-dominan)m(t)h
-(lik)m(e\))-210 3157 y(GB)173 b(general)31 b(band)-210
-3270 y(GE)175 b(general)31 b(\(i.e.)42 b(unsymmetric,)30
-b(in)g(some)h(cases)g(rectangular\))-210 3383 y(GG)166
-b(general)31 b(matrices,)h(generalized)g(problem)e(\(i.e.)42
-b(a)31 b(pair)f(of)g(general)i(matrices\))-210 3496 y(HE)178
-b(\(complex\))32 b(Hermitian)-210 3608 y(OR)170 b(\(real\))32
-b(orthogonal)-210 3721 y(PB)182 b(symmetric)31 b(or)f(Hermitian)h(p)s
-(ositiv)m(e)h(de\014nite)e(band)-210 3834 y(PO)175 b(symmetric)31
-b(or)f(Hermitian)h(p)s(ositiv)m(e)h(de\014nite)-210 3947
-y(PT)180 b(symmetric)31 b(or)f(Hermitian)h(p)s(ositiv)m(e)h(de\014nite)
-e(tridiagonal)-210 4060 y(ST)191 b(symmetric)31 b(tridiagonal)-210
-4173 y(SY)189 b(symmetric)-210 4286 y(TR)175 b(triangular)31
-b(\(or)g(in)f(some)g(cases)i(quasi-triangular\))-210
-4399 y(TZ)186 b(trap)s(ezoidal)-210 4512 y(UN)172 b(\(complex\))32
-b(unitary)1545 4989 y(28)p eop end
-%%Page: 29 29
-TeXDict begin 29 28 bop -69 -269 a Fw(The)28 b(last)i(three)f(c)m
-(haracters,)i(YYY,)e(indicate)h(the)f(computation)h(done)e(b)m(y)h(a)g
-(particular)g(subrou-)-210 -156 y(tine.)41 b(Included)29
-b(in)h(this)h(release)g(are)g(subroutines)e(to)i(p)s(erform)e(the)i
-(follo)m(wing)h(computations:)-210 32 y(BRD)108 b(reduce)30
-b(to)h(bidiagonal)h(form)e(b)m(y)g(orthogonal)i(transformations)-210
-145 y(CON)103 b(estimate)32 b(condition)f(n)m(um)m(b)s(er)-210
-258 y(EBZ)126 b(compute)31 b(selected)h(eigen)m(v)-5
-b(alues)32 b(b)m(y)e(bisection)-210 371 y(EDC)111 b(compute)31
-b(eigen)m(v)m(ectors)i(using)d(divide)g(and)g(conquer)-210
-484 y(EIN)145 b(compute)31 b(selected)h(eigen)m(v)m(ectors)h(b)m(y)d
-(in)m(v)m(erse)i(iteration)-210 596 y(EQU)107 b(equilibrate)31
-b(a)g(matrix)g(to)g(reduce)f(its)h(condition)g(n)m(um)m(b)s(er)-210
-709 y(EV)m(C)115 b(compute)31 b(the)f(eigen)m(v)m(ectors)k(from)c(the)g
-(Sc)m(h)m(ur)g(factorization)-210 822 y(GBR)106 b(generate)32
-b(the)f(orthogonal/unitary)g(matrix)g(from)f(PxGEBRD)-210
-935 y(GHR)102 b(generate)32 b(the)f(orthogonal/unitary)g(matrix)g(from)
-f(PxGEHRD)-210 1048 y(GLQ)109 b(generate)32 b(the)f(orthogonal/unitary)
-g(matrix)g(from)f(PxGELQF)-210 1161 y(GQL)109 b(generate)32
-b(the)f(orthogonal/unitary)g(matrix)g(from)f(PxGEQLF)-210
-1274 y(GQR)99 b(generate)32 b(the)f(orthogonal/unitary)g(matrix)g(from)
-f(PxGEQRF)-210 1387 y(GR)m(Q)102 b(generate)32 b(the)f
-(orthogonal/unitary)g(matrix)g(from)f(PxGER)m(QF)-210
-1500 y(GST)120 b(reduce)30 b(a)h(symmetric-de\014nite)g(generalized)h
-(eigen)m(v)-5 b(alue)32 b(problem)e(to)h(standard)f(form)-210
-1613 y(HRD)104 b(reduce)30 b(to)h(upp)s(er)e(Hessen)m(b)s(erg)h(form)g
-(b)m(y)g(orthogonal)i(transformations)-210 1726 y(LQF)121
-b(compute)31 b(an)f(LQ)g(factorization)j(without)d(piv)m(oting)-210
-1838 y(MBR)94 b(m)m(ultiply)31 b(b)m(y)f(the)h(orthogonal/unitary)g
-(matrix)g(from)f(PxGEBRD)-210 1951 y(MHR)90 b(m)m(ultiply)31
-b(b)m(y)f(the)h(orthogonal/unitary)g(matrix)g(from)f(PxGEHRD)-210
-2064 y(MLQ)97 b(m)m(ultiply)31 b(b)m(y)f(the)h(orthogonal/unitary)g
-(matrix)g(from)f(PxGELQF)-210 2177 y(MQL)97 b(m)m(ultiply)31
-b(b)m(y)f(the)h(orthogonal/unitary)g(matrix)g(from)f(PxGEQLF)-210
-2290 y(MQR)87 b(m)m(ultiply)31 b(b)m(y)f(the)h(orthogonal/unitary)g
-(matrix)g(from)f(PxGEQRF)-210 2403 y(MR)m(Q)90 b(m)m(ultiply)31
-b(b)m(y)f(the)h(orthogonal/unitary)g(matrix)g(from)f(PxGER)m(QF)-210
-2516 y(MRZ)102 b(m)m(ultiply)31 b(b)m(y)f(the)h(orthogonal/unitary)g
-(matrix)g(from)f(PxTZRZF)-210 2629 y(MTR)92 b(m)m(ultiply)31
-b(b)m(y)f(the)h(orthogonal/unitary)g(matrix)g(from)f(PxxxTRD)-210
-2742 y(QLF)121 b(compute)31 b(a)g(QL)e(factorization)k(without)e(piv)m
-(oting)-210 2855 y(QPF)116 b(compute)31 b(a)g(QR)e(factorization)k
-(with)e(column)f(piv)m(oting)-210 2968 y(QRF)111 b(compute)31
-b(a)g(QR)e(factorization)k(without)e(piv)m(oting)-210
-3080 y(RFS)131 b(re\014ne)30 b(initial)h(solution)g(returned)f(b)m(y)g
-(TRS)f(routines)-210 3193 y(R)m(QF)114 b(compute)31 b(an)f(R)m(Q)g
-(factorization)j(without)e(piv)m(oting)-210 3306 y(RZF)126
-b(compute)31 b(an)f(RZ)g(factorization)j(without)d(piv)m(oting)-210
-3419 y(TRD)106 b(reduce)30 b(a)h(symmetric)g(matrix)f(to)h(real)g
-(symmetric)g(tridiagonal)h(form)-210 3532 y(TRF)116 b(compute)31
-b(a)g(triangular)f(factorization)j(\(LU,)e(Cholesky)-8
-b(,)31 b(etc.\))-210 3645 y(TRI)142 b(compute)31 b(in)m(v)m(erse)g
-(\(based)f(on)h(triangular)f(factorization\))-210 3758
-y(TRS)124 b(solv)m(e)32 b(systems)e(of)h(linear)f(equations)i(\(based)e
-(on)g(triangular)h(factorization\))-69 3987 y(Giv)m(en)36
-b(these)g(de\014nitions,)h(the)e(follo)m(wing)i(table)f(indicates)h
-(the)e(ScaLAP)-8 b(A)m(CK)36 b(subroutines)e(for)-210
-4100 y(the)d(solution)g(of)f(systems)g(of)h(linear)g(equations:)1545
-4989 y(29)p eop end
-%%Page: 30 30
-TeXDict begin 30 29 bop 2439 -281 a Fw(HE)553 b(UN)338
--168 y(GE)100 b(GG)h(DB)f(GB)g(DT)g(GT)g(PO)f(PB)h(PT)105
-b(SY)g(TR)99 b(TZ)g(OR)-19 -55 y(TRF)197 b Fo(\002)404
-b(\002)164 b(\002)g(\002)399 b(\002)158 b(\002)d(\002)-19
-58 y Fw(TRS)205 b Fo(\002)404 b(\002)164 b(\002)g(\002)399
-b(\002)158 b(\002)d(\002)389 b(\002)-19 171 y Fw(RFS)212
-b Fo(\002)1344 b(\002)844 b(\002)-19 284 y Fw(TRI)223
-b Fo(\002)1344 b(\002)844 b(\002)-19 396 y Fw(CON)184
-b Fo(\002)1344 b(\002)844 b(\002)-19 509 y Fw(EQU)188
-b Fo(\002)1344 b(\002)-19 622 y Fw(QPF)197 b Fo(\002)-19
-750 y Fw(QRF)178 714 y Fb(y)370 750 y Fo(\002)166 b(\002)-19
-862 y Fw(RZF)2763 b Fo(\002)-19 990 y Fw(GQR)190 954
-y Fb(y)3155 990 y Fo(\002)-19 1117 y Fw(MQR)202 1081
-y Fb(z)3155 1117 y Fo(\002)-19 1230 y(y)p Fw({)31 b(also)g(R)m(Q,)g
-(QL,)f(and)g(LQ)-19 1343 y Fo(z)p Fw({)h(also)g(R)m(Q,)g(RZ,)f(QL,)g
-(and)g(LQ)-69 1539 y(The)j(follo)m(wing)i(table)g(indicates)f(the)g
-(ScaLAP)-8 b(A)m(CK)34 b(subroutines)f(for)g(\014nding)f(eigen)m(v)-5
-b(alues)36 b(and)-210 1652 y(eigen)m(v)m(ectors)d(or)e(singular)f(v)-5
-b(alues)31 b(and)e(singular)i(v)m(ectors:)1687 1799 y(HE)285
-1912 y(GE)100 b(GG)g(HS)g(HG)g(TR)f(TG)105 b(SY)g(ST)99
-b(PT)g(BD)-19 2025 y(HRD)131 b Fo(\002)-19 2138 y Fw(TRD)1533
-b Fo(\002)-19 2251 y Fw(BRD)135 b Fo(\002)-19 2363 y
-Fw(EQZ)-19 2476 y(EIN)1795 b Fo(\002)-19 2589 y Fw(EBZ)1776
-b Fo(\002)-19 2702 y Fw(EDC)1761 b Fo(\002)-19 2815 y
-Fw(EV)m(C)1075 b Fo(\002)619 b(\002)-19 2928 y Fw(GST)1547
-b Fo(\002)-69 3038 y Fw(Orthogonal/unitary)30 b(transformation)f
-(routines)g(ha)m(v)m(e)h(also)g(b)s(een)f(pro)m(vided)f(for)h(the)g
-(reductions)-210 3151 y(that)i(use)f(elemen)m(tary)i(transformations.)
-300 3256 y(UN)299 3369 y(OR)-19 3482 y(GHR)145 b Fo(\002)-19
-3595 y Fw(GTR)i Fo(\002)-19 3708 y Fw(GBR)i Fo(\002)-19
-3821 y Fw(MHR)133 b Fo(\002)-19 3934 y Fw(MTR)i Fo(\002)-19
-4047 y Fw(MBR)i Fo(\002)-69 4193 y Fw(In)38 b(addition,)i(a)f(n)m(um)m
-(b)s(er)e(of)h(driv)m(er)g(routines)g(are)h(pro)m(vided)f(with)g(this)g
-(release.)65 b(The)38 b(naming)-210 4306 y(con)m(v)m(en)m(tion)h(for)e
-(the)h(driv)m(er)e(routines)h(is)h(the)f(same)g(as)h(for)f(the)g(LAP)-8
-b(A)m(CK)37 b(routines,)i(but)e(the)g(last)-210 4419
-y(3)d(c)m(haracters)h(YYY)f(ha)m(v)m(e)h(the)f(follo)m(wing)h(meanings)
-f(\(note)h(an)e(`X')i(in)e(the)h(last)h(c)m(haracter)g(p)s(osition)-210
-4532 y(indicates)c(a)g(more)g(exp)s(ert)f(driv)m(er\):)-210
-4715 y(SV)189 b(factor)31 b(the)g(matrix)g(and)e(solv)m(e)j(a)f(system)
-f(of)h(equations)1545 4989 y(30)p eop end
-%%Page: 31 31
-TeXDict begin 31 30 bop -210 -269 a Fw(SVX)121 b(equilibrate,)32
-b(factor,)f(solv)m(e,)h(compute)f(error)f(b)s(ounds)e(and)i(do)g
-(iterativ)m(e)j(re\014nemen)m(t,)d(and)98 -156 y(estimate)i(the)f
-(condition)g(n)m(um)m(b)s(er)-210 -43 y(LS)200 b(solv)m(e)32
-b(o)m(v)m(er-)g(or)e(underdetermined)f(linear)h(system)h(using)f
-(orthogonal)i(factorizations)-210 70 y(EV)178 b(compute)31
-b(all)g(eigen)m(v)-5 b(alues)32 b(and/or)f(eigen)m(v)m(ectors)-210
-183 y(EVD)109 b(compute)31 b(all)g(eigen)m(v)-5 b(alues)32
-b(and,)e(optionally)-8 b(,)33 b(eigen)m(v)m(ectors)g(\(using)d(divide)g
-(and)g(conquer)g(algorithm\))-210 296 y(EVX)110 b(compute)31
-b(selected)h(eigen)m(v)-5 b(alues)32 b(and)e(eigen)m(v)m(ectors)-210
-409 y(GVX)101 b(compute)31 b(selected)h(generalized)g(eigen)m(v)-5
-b(alues)32 b(and/or)e(generalized)i(eigen)m(v)m(ectors)-210
-522 y(SVD)120 b(compute)31 b(the)f(SVD)h(and/or)f(singular)g(v)m
-(ectors)-69 734 y(The)g(driv)m(er)g(routines)g(pro)m(vided)g(in)g
-(ScaLAP)-8 b(A)m(CK)31 b(are)g(indicated)g(b)m(y)f(the)h(follo)m(wing)h
-(table:)2389 881 y(HE)100 b(HB)288 994 y(GE)g(GG)g(DB)h(GB)f(DT)g(GT)g
-(PO)f(PB)h(PT)105 b(SY)113 b(SB)c(ST)-19 1107 y(SV)220
-b Fo(\002)404 b(\002)163 b(\002)h(\002)400 b(\002)158
-b(\002)d(\002)-19 1219 y Fw(SVX)d Fo(\002)1344 b(\002)-19
-1332 y Fw(LS)231 b Fo(\002)-19 1445 y Fw(EV)2308 b Fo(\002)-19
-1558 y Fw(EVD)2239 b Fo(\002)-19 1671 y Fw(EVX)h Fo(\002)-19
-1784 y Fw(GVX)2231 b Fo(\002)-19 1897 y Fw(SVD)151 b
-Fo(\002)1545 4989 y Fw(31)p eop end
-%%Page: 32 32
-TeXDict begin 32 31 bop -210 354 a Fc(App)5 b(endix)64
-b(B)-210 769 y Fs(ScaLAP)-19 b(A)-6 b(CK)77 b(Auxiliary)f(Routines)-69
-1214 y Fw(This)35 b(app)s(endix)g(lists)i(all)g(of)f(the)g(auxiliary)h
-(routines)f(\(except)i(for)e(the)g(BLAS)g(and)f(LAP)-8
-b(A)m(CK\))-210 1327 y(that)34 b(are)h(called)g(from)e(the)h(ScaLAP)-8
-b(A)m(CK)34 b(routines.)51 b(These)34 b(routines)f(are)i(found)d(in)h
-(the)h(directory)-210 1440 y Fr(SCALAPACK/SRC)p Fw(.)f(Routines)k(sp)s
-(eci\014ed)f(with)h(a)g(\014rst)f(c)m(haracter)i(P)f(follo)m(w)m(ed)h
-(b)m(y)f(an)g(underscore)f(as)-210 1553 y(the)k(second)g(c)m(haracter)i
-(are)e(a)m(v)-5 b(ailable)43 b(in)c(all)i(four)f(data)g(t)m(yp)s(es)g
-(\(S,)g(D,)h(C,)f(and)f(Z\),)h(except)h(those)-210 1666
-y(mark)m(ed)28 b(\(real\),)i(for)e(whic)m(h)g(the)g(\014rst)f(c)m
-(haracter)j(ma)m(y)e(b)s(e)f(`S')h(or)g(`D',)h(and)f(those)g(mark)m(ed)
-g(\(complex\),)-210 1779 y(for)i(whic)m(h)g(the)h(\014rst)e(c)m
-(haracter)j(ma)m(y)f(b)s(e)f(`C')h(or)f(`Z'.)-210 1892
-y(F)-8 b(unctions)31 b(for)f(computing)h(norms:)-210
-2079 y(P)p -143 2079 28 4 v 33 w(LANGE)59 b(General)31
-b(matrix)-210 2192 y(P)p -143 2192 V 33 w(LANHE)62 b(\(complex\))32
-b(Hermitian)f(matrix)-210 2305 y(P)p -143 2305 V 33 w(LANHS)73
-b(Upp)s(er)29 b(Hessen)m(b)s(erg)h(matrix)-210 2418 y(P)p
--143 2418 V 33 w(LANSY)73 b(Symmetric)30 b(matrix)-210
-2531 y(P)p -143 2531 V 33 w(LANTR)59 b(T)-8 b(rap)s(ezoidal)31
-b(matrix)-210 2718 y(Lev)m(el)h(2)e(BLAS)h(v)m(ersions)f(of)h(the)f
-(blo)s(c)m(k)h(routines:)-210 2906 y(P)p -143 2906 V
-33 w(GEBD2)74 b(reduce)30 b(a)h(general)g(matrix)g(to)g(bidiagonal)g
-(form)-210 3019 y(P)p -143 3019 V 33 w(GEHD2)70 b(reduce)30
-b(a)h(square)f(matrix)h(to)g(upp)s(er)d(Hessen)m(b)s(erg)i(form)-210
-3132 y(P)p -143 3132 V 33 w(GELQ2)79 b(compute)30 b(an)h(LQ)f
-(factorization)j(without)d(piv)m(oting)-210 3245 y(P)p
--143 3245 V 33 w(GEQL2)79 b(compute)30 b(a)h(QL)f(factorization)j
-(without)d(piv)m(oting)-210 3358 y(P)p -143 3358 V 33
-w(GEQR2)69 b(compute)30 b(a)h(QR)f(factorization)j(without)e(piv)m
-(oting)-210 3471 y(P)p -143 3471 V 33 w(GER)m(Q2)72 b(compute)30
-b(an)h(R)m(Q)f(factorization)j(without)e(piv)m(oting)-210
-3584 y(P)p -143 3584 V 33 w(GETF2)82 b(compute)30 b(the)h(LU)f
-(factorization)j(of)e(a)g(general)g(matrix)-210 3696
-y(P)p -143 3696 V 33 w(HETD2)75 b(\(complex\))32 b(reduce)e(a)g
-(Hermitian)i(matrix)e(to)h(real)g(tridiagonal)h(form)-210
-3809 y(P)p -143 3809 V 33 w(OR)m(G2L)77 b(\(real\))32
-b(generate)f(the)g(orthogonal)h(matrix)e(from)g(PxGEQLF)-210
-3922 y(P)p -143 3922 V 33 w(OR)m(G2R)67 b(\(real\))32
-b(generate)f(the)g(orthogonal)h(matrix)e(from)g(PxGEQRF)-210
-4035 y(P)p -143 4035 V 33 w(OR)m(GL2)77 b(\(real\))32
-b(generate)f(the)g(orthogonal)h(matrix)e(from)g(PxGEQLF)-210
-4148 y(P)p -143 4148 V 33 w(OR)m(GR2)67 b(\(real\))32
-b(generate)f(the)g(orthogonal)h(matrix)e(from)g(PxGER)m(QF)-210
-4261 y(P)p -143 4261 V 33 w(ORM2L)62 b(\(real\))32 b(m)m(ultiply)e(b)m
-(y)g(the)h(orthogonal)h(matrix)e(from)g(PxGEQLF)-210
-4374 y(P)p -143 4374 V 33 w(ORM2R)52 b(\(real\))32 b(m)m(ultiply)e(b)m
-(y)g(the)h(orthogonal)h(matrix)e(from)g(PxGEQRF)-210
-4487 y(P)p -143 4487 V 33 w(ORML2)62 b(\(real\))32 b(m)m(ultiply)e(b)m
-(y)g(the)h(orthogonal)h(matrix)e(from)g(PxGELQF)-210
-4600 y(P)p -143 4600 V 33 w(ORMR2)52 b(\(real\))32 b(m)m(ultiply)e(b)m
-(y)g(the)h(orthogonal)h(matrix)e(from)g(PxGER)m(QF)-210
-4713 y(P)p -143 4713 V 33 w(ORMR3)52 b(\(real\))32 b(m)m(ultiply)e(b)m
-(y)g(the)h(orthogonal)h(matrix)e(from)g(PxTZRZF)1545
-4989 y(32)p eop end
-%%Page: 33 33
-TeXDict begin 33 32 bop -210 -269 a Fw(P)p -143 -269
-28 4 v 33 w(POTF2)82 b(compute)30 b(the)h(Cholesky)f(factorization)j
-(of)e(a)g(p)s(ositiv)m(e)g(de\014nite)f(matrix)-210 -156
-y(P)p -143 -156 V 33 w(SYGS2)99 b(\(real\))32 b(reduce)e(a)g
-(symmetric-de\014nite)h(generalized)h(eigen)m(v)-5 b(alue)33
-b(problem)c(to)-210 -43 y(P)p -143 -43 V 33 w(SYTD2)86
-b(\(real\))32 b(reduce)e(a)g(symmetric)h(matrix)g(to)g(tridiagonal)h
-(form)-210 70 y(P)p -143 70 V 33 w(TR)-8 b(TI2)116 b(compute)30
-b(the)h(in)m(v)m(erse)g(of)g(a)g(triangular)f(matrix)-210
-183 y(P)p -143 183 V 33 w(UNG2L)76 b(\(complex\))32 b(generate)f(the)g
-(unitary)f(matrix)h(from)f(PxGEQLF)-210 296 y(P)p -143
-296 V 33 w(UNG2R)66 b(\(complex\))32 b(generate)f(the)g(unitary)f
-(matrix)h(from)f(PxGEQRF)-210 409 y(P)p -143 409 V 33
-w(UNGL2)76 b(\(complex\))32 b(generate)f(the)g(unitary)f(matrix)h(from)
-f(PxGEQLF)-210 522 y(P)p -143 522 V 33 w(UNGR2)66 b(\(complex\))32
-b(generate)f(the)g(unitary)f(matrix)h(from)f(PxGER)m(QF)-210
-635 y(P)p -143 635 V 33 w(UNM2L)64 b(\(complex\))32 b(m)m(ultiply)e(b)m
-(y)g(the)h(unitary)f(matrix)h(from)f(PxGEQLF)-210 748
-y(P)p -143 748 V 33 w(UNM2R)54 b(\(complex\))32 b(m)m(ultiply)e(b)m(y)g
-(the)h(unitary)f(matrix)h(from)f(PxGEQRF)-210 860 y(P)p
--143 860 V 33 w(UNML2)64 b(\(complex\))32 b(m)m(ultiply)e(b)m(y)g(the)h
-(unitary)f(matrix)h(from)f(PxGELQF)-210 973 y(P)p -143
-973 V 33 w(UNMR2)54 b(\(complex\))32 b(m)m(ultiply)e(b)m(y)g(the)h
-(unitary)f(matrix)h(from)f(PxGER)m(QF)-210 1086 y(P)p
--143 1086 V 33 w(UNMR3)54 b(\(complex\))32 b(m)m(ultiply)e(b)m(y)g(the)
-h(unitary)f(matrix)h(from)f(PxTZRZF)-210 1274 y(Other)g(ScaLAP)-8
-b(A)m(CK)31 b(auxiliary)g(routines:)-210 1461 y(P)p -143
-1461 V 33 w(LABAD)438 b(\(real\))31 b(returns)e(square)i(ro)s(ot)f(of)h
-(under\015o)m(w)e(and)g(o)m(v)m(er\015o)m(w)j(if)f(exp)s(onen)m(t)f
-(range)h(is)f(large)-210 1574 y(P)p -143 1574 V 33 w(LABRD)439
-b(reduce)30 b(NB)h(ro)m(ws)f(or)g(columns)g(of)h(a)g(matrix)f(to)h(upp)
-s(er)e(or)h(lo)m(w)m(er)i(bidiagonal)f(form)-210 1687
-y(P)p -143 1687 V 33 w(LA)m(CGV)437 b(\(complex\))31
-b(conjugates)h(a)f(complex)g(v)m(ector)h(of)e(length)h(n)-210
-1800 y(P)p -143 1800 V 33 w(LA)m(CHKIEEE)218 b(\(real\))31
-b(p)s(erforms)e(a)i(simple)f(c)m(hec)m(k)i(for)e(the)h(features)g(of)f
-(the)h(IEEE)e(standard)-210 1913 y(P)p -143 1913 V 33
-w(LA)m(CON)437 b(estimate)32 b(the)e(norm)g(of)g(a)h(matrix)g(for)f
-(use)g(in)g(condition)h(estimation)-210 2026 y(P)p -143
-2026 V 33 w(LA)m(CONSB)322 b(\(real\))31 b(lo)s(oks)g(for)f(t)m(w)m(o)i
-(consecutiv)m(e)g(small)f(sub)s(diagonal)f(elemen)m(ts)-210
-2139 y(P)p -143 2139 V 33 w(LA)m(CP2)469 b(copies)31
-b(all)g(or)f(part)h(of)f(a)h(distributed)e(matrix)i(to)g(another)g
-(distributed)e(matrix)-210 2252 y(P)p -143 2252 V 33
-w(LA)m(CP3)469 b(\(real\))31 b(copies)g(from)f(a)h(global)h(parallel)f
-(arra)m(y)g(in)m(to)h(a)e(lo)s(cal)649 2365 y(replicated)h(arra)m(y)g
-(or)f(vice)i(v)m(ersa.)-210 2478 y(P)p -143 2478 V 33
-w(LA)m(CPY)446 b(cop)m(y)31 b(all)g(or)f(part)h(of)f(a)h(distributed)e
-(matrix)i(to)g(another)g(distributed)e(matrix)-210 2591
-y(P)p -143 2591 V 33 w(LAED0)463 b(Used)30 b(b)m(y)g(PxSTEDC.)-210
-2704 y(P)p -143 2704 V 33 w(LAED1)463 b(\(real\))31 b(Used)g(b)m(y)f
-(PxSTEDC.)-210 2816 y(P)p -143 2816 V 33 w(LAED2)463
-b(\(real\))31 b(Used)g(b)m(y)f(PxSTEDC.)-210 2929 y(P)p
--143 2929 V 33 w(LAED3)463 b(\(real\))31 b(Used)g(b)m(y)f(PxSTEDC.)-210
-3042 y(P)p -143 3042 V 33 w(LAEDZ)452 b(\(real\))31 b(Used)g(b)m(y)f
-(PxSTEDC.)-210 3155 y(P)p -143 3155 V 33 w(LAEVSWP)303
-b(mo)m(v)m(es)31 b(the)g(eigen)m(v)m(ectors)i(from)d(where)g(they)h
-(are)f(computed)g(to)i(a)649 3268 y(standard)d(blo)s(c)m(k)i(cyclic)h
-(arra)m(y)-210 3381 y(P)p -143 3381 V 33 w(LAHEF)450
-b(\(complex\))31 b(compute)g(part)f(of)h(the)f(diagonal)i(piv)m(oting)g
-(factorization)h(of)d(a)h(Hermitian)649 3494 y(matrix)-210
-3607 y(P)p -143 3607 V 33 w(LAHQR)433 b(Find)29 b(the)i(Sc)m(h)m(ur)f
-(factorization)j(of)d(a)h(Hessen)m(b)s(erg)g(matrix)f(\(mo)s(di\014ed)g
-(v)m(ersion)h(of)649 3720 y(HQR)f(from)g(EISP)-8 b(A)m(CK\))-210
-3833 y(P)p -143 3833 V 33 w(LAHRD)435 b(reduce)30 b(NB)h(columns)f(of)g
-(a)h(general)g(matrix)g(to)g(Hessen)m(b)s(erg)g(form)-210
-3946 y(P)p -143 3946 V 33 w(LAIECTB)348 b(\(real\))31
-b(computes)g(the)f(n)m(um)m(b)s(er)f(of)i(negativ)m(e)i(eigen)m(v)-5
-b(alues)32 b(in)e(\()p Fk(A)21 b Fo(\000)f Fw(\006)p
-Fk(I)7 b Fw(\))649 4058 y(where)29 b(the)i(sign)f(bit)h(is)f(assumed)g
-(to)h(b)s(e)f(bit)g(32.)-210 4171 y(P)p -143 4171 V 33
-w(LAIECTL)355 b(\(real\))31 b(computes)g(the)f(n)m(um)m(b)s(er)f(of)i
-(negativ)m(e)i(eigen)m(v)-5 b(alues)32 b(in)e(\()p Fk(A)21
-b Fo(\000)f Fw(\006)p Fk(I)7 b Fw(\))649 4284 y(where)29
-b(the)i(sign)f(bit)h(is)f(assumed)g(to)h(b)s(e)f(bit)g(64.)p
--205 4397 V -177 4397 a(LANV2)520 b(\(complex\))31 b(computes)g(the)f
-(Sc)m(h)m(ur)g(factorization)j(of)e(a)g(real)g(2-b)m(y-2)g
-(nonsymmetric)g(matrix)-210 4510 y(P)p -143 4510 V 33
-w(LAPIV)476 b(applies)30 b(p)s(erm)m(utation)h(matrix)f(to)h(a)g
-(general)h(distributed)d(matrix)-210 4623 y(P)p -143
-4623 V 33 w(LAPV2)464 b(piv)m(oting)-210 4736 y(P)p -143
-4736 V 33 w(LA)m(QGE)438 b(equilibrate)31 b(a)g(general)g(matrix)1545
-4989 y(33)p eop end
-%%Page: 34 34
-TeXDict begin 34 33 bop -210 -269 a Fw(P)p -143 -269
-28 4 v 33 w(LA)m(QSY)452 b(equilibrate)31 b(a)g(symmetric)f(matrix)-210
--156 y(P)p -143 -156 V 33 w(LARED1D)327 b(\(real\))31
-b(Redistributes)f(an)h(arra)m(y)g(assuming)e(that)i(the)g(input)649
--43 y(arra)m(y)-8 b(,)31 b(BYCOL,)f(is)h(distributed)e(across)i(ro)m
-(ws)g(and)e(that)i(all)649 70 y(pro)s(cess)f(columns)g(con)m(tain)h
-(the)g(same)g(cop)m(y)g(of)f(BYCOL.)-210 183 y(P)p -143
-183 V 33 w(LARED2D)327 b(Redistributes)30 b(an)g(arra)m(y)h(assuming)f
-(that)h(the)f(input)g(arra)m(y)-8 b(,)649 296 y(BYR)m(O)m(W,)32
-b(is)e(distributed)g(across)g(columns)h(and)e(that)i(all)h(pro)s(cess)
-649 409 y(ro)m(ws)e(con)m(tain)i(the)e(same)h(cop)m(y)g(of)g(BYR)m(O)m
-(W.)h(The)e(output)g(arra)m(y)-8 b(,)649 522 y(BY)g(ALL,)31
-b(will)g(b)s(e)e(iden)m(tical)k(on)d(all)h(pro)s(cesses.)-210
-635 y(P)p -143 635 V 33 w(LARF)513 b(apply)30 b(\(m)m(ultiply)h(b)m
-(y\))f(an)g(elemen)m(tary)i(re\015ector)f(to)h(a)e(general)649
-748 y(rectangular)h(matrix.)-210 860 y(P)p -143 860 V
-33 w(LARFB)449 b(apply)30 b(\(m)m(ultiply)h(b)m(y\))f(a)h(blo)s(c)m(k)g
-(re\015ector)g(or)f(its)h(transp)s(ose/)649 973 y(conjugate-transp)s
-(ose)g(to)g(a)g(general)g(rectangular)h(matrix.)-210
-1086 y(P)p -143 1086 V 33 w(LARF)m(C)450 b(\(complex\))31
-b(apply)f(\(m)m(ultiply)h(b)m(y\))g(the)g(conjugate-transp)s(ose)649
-1199 y(of)f(an)g(elemen)m(tary)i(re\015ector)f(to)g(a)g(general)h
-(matrix.)-210 1312 y(P)p -143 1312 V 33 w(LARF)m(G)445
-b(generate)31 b(an)g(elemen)m(tary)h(re\015ector)f(\(Householder)f
-(matrix\).)-210 1425 y(P)p -143 1425 V 33 w(LARFT)447
-b(form)29 b(the)i(triangular)g(factor)g(of)g(a)f(blo)s(c)m(k)h
-(re\015ector)-210 1538 y(P)p -143 1538 V 33 w(LARZ)516
-b(apply)30 b(\(m)m(ultiply)h(b)m(y\))f(an)g(elemen)m(tary)i
-(re\015ector)f(as)g(returned)e(b)m(y)649 1651 y(P)p 716
-1651 V 32 w(TZRZF)h(to)h(a)f(general)i(matrix.)-210 1764
-y(P)p -143 1764 V 33 w(LARZB)452 b(apply)30 b(\(m)m(ultiply)h(b)m(y\))f
-(a)h(blo)s(c)m(k)g(re\015ector)g(or)f(its)h(transp)s(ose/)649
-1877 y(conjugate)g(transp)s(ose)f(as)h(returned)e(b)m(y)h(P)p
-2142 1877 V 33 w(TZRZF)f(to)i(a)g(general)g(matrix.)-210
-1990 y(P)p -143 1990 V 33 w(LARZC)450 b(\(complex\))31
-b(apply)f(\(m)m(ultiply)h(b)m(y\))g(the)g(conjugate)g(transp)s(ose)f
-(of)649 2102 y(an)g(elemen)m(tary)i(re\015ector)f(as)f(returned)g(b)m
-(y)g(P)p 2268 2102 V 32 w(TZRZF)g(to)h(a)649 2215 y(general)g(matrix.)
--210 2328 y(P)p -143 2328 V 33 w(LARZT)450 b(form)29
-b(the)i(triangular)g(factor)g(of)g(a)f(blo)s(c)m(k)h(re\015ector)g(as)g
-(returned)649 2441 y(b)m(y)f(P)p 842 2441 V 32 w(TZRZF.)-210
-2554 y(P)p -143 2554 V 33 w(LASCL)465 b(m)m(ultiplies)31
-b(a)g(general)g(rectangular)g(matrix)g(b)m(y)f(a)h(real)g(scalar)g
-(CTO/CFR)m(OM)-210 2667 y(P)p -143 2667 V 33 w(LASE2)-210
-2780 y(P)p -143 2780 V 33 w(LASET)460 b(initializes)32
-b(a)f(matrix)g(to)g(BET)-8 b(A)31 b(on)f(the)g(diagonal)i(and)e(ALPHA)g
-(on)649 2893 y(the)g(o\013-diagonals)-210 3006 y(P)p
--143 3006 V 33 w(LASMSUB)322 b(\(real\))31 b(lo)s(oks)g(for)f(a)h
-(small)g(sub)s(diagonal)f(elemen)m(t)i(from)e(the)g(b)s(ottom)649
-3119 y(of)g(the)h(matrix)f(that)h(it)g(can)g(safely)g(set)g(to)g(zero.)
--210 3232 y(P)p -143 3232 V 33 w(LASNBT)390 b(computes)30
-b(the)h(p)s(osition)f(of)h(the)f(sign)h(bit)f(of)h(a)f(double)g
-(precision)649 3344 y(\015oating)h(p)s(oin)m(t)f(n)m(um)m(b)s(er)-210
-3457 y(P)p -143 3457 V 33 w(LASR)-8 b(T)-210 3570 y(P)p
--143 3570 V 33 w(LASSQ)466 b(Compute)30 b(a)g(scaled)h(sum)f(of)g
-(squares)g(of)h(the)f(elemen)m(ts)i(of)f(a)g(v)m(ector)-210
-3683 y(P)p -143 3683 V 33 w(LASWP)433 b(P)m(erform)30
-b(a)h(series)f(of)h(ro)m(w)f(in)m(terc)m(hanges)-210
-3796 y(P)p -143 3796 V 33 w(LA)-8 b(TRA)446 b(computes)30
-b(the)h(trace)g(of)g(a)g(distributed)e(matrix)-210 3909
-y(P)p -143 3909 V 33 w(LA)-8 b(TRD)445 b(reduce)30 b(NB)h(ro)m(ws)f
-(and)g(columns)g(of)g(a)h(real)g(symmetric)g(or)f(complex)h(Hermitian)
-649 4022 y(matrix)f(to)h(tridiagonal)h(form)-210 4135
-y(P)p -143 4135 V 33 w(LA)-8 b(TRS)463 b(solv)m(e)31
-b(a)g(triangular)g(system)f(with)g(scaling)i(to)f(prev)m(en)m(t)g(o)m
-(v)m(er\015o)m(w)-210 4248 y(P)p -143 4248 V 33 w(LA)-8
-b(TRZ)458 b(reduces)30 b(an)g(upp)s(er)e(trap)s(ezoidal)k(matrix)e(to)h
-(upp)s(er)e(triangular)i(form)-210 4361 y(P)p -143 4361
-V 33 w(LA)m(UU2)461 b(Un)m(blo)s(c)m(k)m(ed)31 b(v)m(ersion)g(of)f(P)p
-1572 4361 V 33 w(LA)m(UUM)-210 4474 y(P)p -143 4474 V
-33 w(LA)m(UUM)423 b(Compute)30 b(the)g(pro)s(duct)f(U*U')j(or)e(L'*L)h
-(\(blo)s(c)m(k)m(ed)g(v)m(ersion\))-210 4586 y(P)p -143
-4586 V 33 w(LA)-10 b(WIL)466 b(forms)29 b(the)i(Wilkinson)g(transform)
-1545 4989 y(34)p eop end
-%%Page: 35 35
-TeXDict begin 35 34 bop -210 395 a Fs(Bibliograph)-6
-b(y)-165 840 y Fw([1])47 b Fa(L.)31 b(S.)g(Bla)n(ckf)n(ord,)f(J.)g
-(Choi,)j(A.)e(Clear)-6 b(y,)31 b(E.)g(D'Azevedo,)g(J.)f(Demmel,)h(I.)g
-(Dhillon,)-23 953 y(J.)77 b(Dongarra,)88 b(S.)78 b(Hammarling,)88
-b(G.)78 b(Henr)-6 b(y,)88 b(A.)78 b(Petitet,)88 b(K.)78
-b(St)-6 b(anley,)-23 1066 y(D.)35 b(W)-11 b(alker,)32
-b(and)i(R.)g(C.)h(Whaley)p Fw(,)28 b Fn(Sc)-5 b(aLAP)e(A)n(CK)32
-b(Users')g(Guide)p Fw(,)f(So)s(ciet)m(y)h(for)e(Industrial)-23
-1179 y(and)g(Applied)g(Mathematics,)i(Philadelphia,)f(P)-8
-b(A,)31 b(1997.)-165 1362 y([2])47 b Fa(J.)40 b(Choi,)i(J.)e(Dongarra,)
-h(S.)f(Ostr)n(oucho)n(v,)f(A.)h(Petitet,)i(D.)e(W)-11
-b(alker,)41 b(and)e(R.)h(C.)-23 1475 y(Whaley)p Fw(,)31
-b Fn(A)j(pr)-5 b(op)g(osal)38 b(for)d(a)g(set)f(of)h(p)-5
-b(ar)g(al)5 b(lel)37 b(b)-5 b(asic)34 b(line)-5 b(ar)36
-b(algebr)-5 b(a)36 b(subpr)-5 b(o)g(gr)g(ams)p Fw(,)36
-b(Computer)-23 1587 y(Science)k(Dept.)g(Tec)m(hnical)g(Rep)s(ort)f
-(CS-95-292,)44 b(Univ)m(ersit)m(y)c(of)f(T)-8 b(ennessee,)42
-b(Kno)m(xville,)h(TN,)-23 1700 y(Ma)m(y)31 b(1995.)43
-b(\(Also)31 b(LAP)-8 b(A)m(CK)31 b(W)-8 b(orking)31 b(Note)h(#100\).)
--165 1883 y([3])p -23 1870 191 4 v 238 w(,)e Fn(The)i(design)f(and)i
-(implementation)h(of)e(the)g(Sc)-5 b(aLAP)e(A)n(CK)31
-b(LU,)g(QR,)h(and)h(Cholesky)f(fac-)-23 1996 y(torization)42
-b(r)-5 b(outines)p Fw(,)42 b(Scien)m(ti\014c)e(Programming,)h(5)e
-(\(1996\),)k(pp.)38 b(173{184.)68 b(\(Also)40 b(LAP)-8
-b(A)m(CK)-23 2109 y(W)g(orking)31 b(Note)h(#80\).)-165
-2291 y([4])47 b Fa(J.)41 b(Dongarra)f(and)g(R.)h(C.)h(Whaley)p
-Fw(,)37 b Fn(A)h(user's)g(guide)h(to)g(the)g(BLA)n(CS)e(v1.1)p
-Fw(,)j(Computer)-23 2404 y(Science)g(Dept.)g(Tec)m(hnical)g(Rep)s(ort)f
-(CS-95-281,)44 b(Univ)m(ersit)m(y)c(of)f(T)-8 b(ennessee,)42
-b(Kno)m(xville,)h(TN,)-23 2517 y(1995.)f(\(Also)32 b(LAP)-8
-b(A)m(CK)30 b(W)-8 b(orking)32 b(Note)f(#94\).)-165 2699
-y([5])47 b Fa(J.)33 b(J.)h(Dongarra,)f(J.)h(Du)g(Cr)n(oz,)g(I.)f(S.)h
-(Duff,)g(and)f(S.)g(Hammarling)p Fw(,)d Fn(A)i(set)g(of)h(Level)f(3)-23
-2812 y(Basic)h(Line)-5 b(ar)33 b(Algebr)-5 b(a)33 b(Subpr)-5
-b(o)g(gr)g(ams)p Fw(,)34 b(A)m(CM)d(T)-8 b(rans.)30 b(Math.)h(Soft.,)g
-(16)g(\(1990\),)i(pp.)d(1{17.)-165 2994 y([6])47 b Fa(J.)34
-b(J.)f(Dongarra,)h(J.)f(Du)i(Cr)n(oz,)f(S.)f(Hammarling,)h(and)f(R.)h
-(J.)g(Hanson)p Fw(,)29 b Fn(A)n(n)j(extende)-5 b(d)-23
-3107 y(set)29 b(of)g(F)n(OR)-7 b(TRAN)29 b(b)-5 b(asic)29
-b(line)-5 b(ar)30 b(algebr)-5 b(a)30 b(subr)-5 b(outines)p
-Fw(,)29 b(A)m(CM)e(T)-8 b(rans.)26 b(Math.)h(Soft.,)h(14)f(\(1988\),)
--23 3220 y(pp.)i(1{17.)-165 3403 y([7])47 b Fa(M.)h(P.)g(I.)g(F)m(or)n
-(um)p Fw(,)e Fn(MPI:)e(A)g(message)h(p)-5 b(assing)46
-b(interfac)-5 b(e)45 b(standar)-5 b(d)p Fw(,)50 b(In)m(ternational)44
-b(Jour-)-23 3515 y(nal)54 b(of)g(Sup)s(ercomputer)e(Applications)j(and)
-e(High)i(P)m(erformance)f(Computing,)60 b(8)54 b(\(1994\),)-23
-3628 y(pp.)73 b(3{4.)172 b(Sp)s(ecial)74 b(issue)g(on)g(MPI.)g(Also)g
-(a)m(v)-5 b(ailable)77 b(electronically)-8 b(,)88 b(the)74
-b(URL)g(is)-23 3741 y Fr(ftp://www.netlib.org/mpi)o(/mp)o(i-re)o(port)o
-(.ps)41 b Fw(.)-165 3924 y([8])47 b Fa(A.)39 b(Geist,)h(A.)f(Beguelin,)
-h(J.)f(Dongarra,)g(W.)g(Jiang,)h(R.)e(Manchek,)h(and)g(V.)g(Sun-)-23
-4037 y(deram)p Fw(,)31 b Fn(PVM:)i(Par)-5 b(al)5 b(lel)35
-b(Virtual)g(Machine.)f(A)f(Users')h(Guide)h(and)g(T)-7
-b(utorial)35 b(for)g(Networke)-5 b(d)-23 4149 y(Par)g(al)5
-b(lel)34 b(Computing)p Fw(,)e(MIT)e(Press,)g(Cam)m(bridge,)g(MA,)h
-(1994.)-165 4332 y([9])47 b Fa(C.)30 b(L.)f(La)-8 b(wson,)29
-b(R.)g(J.)g(Hanson,)g(D.)g(Kincaid,)h(and)f(F.)g(T.)g(Kr)n(ogh)p
-Fw(,)d Fn(Basic)i(line)-5 b(ar)30 b(algebr)-5 b(a)-23
-4445 y(subpr)g(o)g(gr)g(ams)36 b(for)d(Fortr)-5 b(an)35
-b(usage)p Fw(,)c(A)m(CM)g(T)-8 b(rans.)30 b(Math.)h(Soft.,)g(5)f
-(\(1979\),)k(pp.)29 b(308{323.)-210 4627 y([10])47 b
-Fa(R.)38 b(C.)i(Whaley)p Fw(,)34 b Fn(Basic)j(line)-5
-b(ar)37 b(algebr)-5 b(a)38 b(c)-5 b(ommunic)g(ation)39
-b(subpr)-5 b(o)g(gr)g(ams:)53 b(A)n(nalysis)37 b(and)g(im-)-23
-4740 y(plementation)e(acr)-5 b(oss)35 b(multiple)e(p)-5
-b(ar)g(al)5 b(lel)36 b(ar)-5 b(chite)g(ctur)g(es)p Fw(,)33
-b(Computer)d(Science)i(Dept.)f(T)-8 b(ec)m(hnical)1545
-4989 y(35)p eop end
-%%Page: 36 36
-TeXDict begin 36 35 bop -23 -269 a Fw(Rep)s(ort)26 b(CS-94-234,)k(Univ)
-m(ersit)m(y)e(of)e(T)-8 b(ennessee,)28 b(Kno)m(xville,)h(TN,)e(Ma)m(y)h
-(1994.)36 b(\(Also)28 b(LAP)-8 b(A)m(CK)-23 -156 y(W)g(orking)31
-b(Note)h(73\).)-210 32 y([11])47 b Fa(S.)37 b(Bla)n(ckf)n(ord)e(and)h
-(J.)h(Dongarra)p Fw(,)c Fn(Quick)g(Instal)5 b(lation)38
-b(Guide)d(for)g(LAP)-7 b(A)n(CK)34 b(on)h(Unix)-23 145
-y(Systems)23 b Fw(Computer)f(Science)h(Dept.)h(Tec)m(hnical)f(Rep)s
-(ort)g(CS-94-249,)j(Univ)m(ersit)m(y)e(of)e(T)-8 b(ennessee,)-23
-258 y(Kno)m(xville,)32 b(TN,)e(Septem)m(b)s(er)g(1994.)42
-b(\(Also)32 b(LAP)-8 b(A)m(CK)30 b(W)-8 b(orking)32 b(Note)f(81\).)1545
-4989 y(36)p eop end
-%%Trailer
-
-userdict /end-hook known{end-hook}if
-%%EOF
diff --git a/LICENSE b/LICENSE
new file mode 100644
index 0000000..1b96ccc
--- /dev/null
+++ b/LICENSE
@@ -0,0 +1,48 @@
+Copyright (c) 1992-2011 The University of Tennessee and The University
+ of Tennessee Research Foundation. All rights
+ reserved.
+Copyright (c) 2000-2011 The University of California Berkeley. All
+ rights reserved.
+Copyright (c) 2006-2011 The University of Colorado Denver. All rights
+ reserved.
+
+$COPYRIGHT$
+
+Additional copyrights may follow
+
+$HEADER$
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are
+met:
+
+- Redistributions of source code must retain the above copyright
+ notice, this list of conditions and the following disclaimer.
+
+- Redistributions in binary form must reproduce the above copyright
+ notice, this list of conditions and the following disclaimer listed
+ in this license in the documentation and/or other materials
+ provided with the distribution.
+
+- Neither the name of the copyright holders nor the names of its
+ contributors may be used to endorse or promote products derived from
+ this software without specific prior written permission.
+
+The copyright holders provide no reassurances that the source code
+provided does not infringe any patent, copyright, or any other
+intellectual property rights of third parties. The copyright holders
+disclaim any liability to any recipient for claims brought against
+recipient by any third party for infringement of that parties
+intellectual property rights.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
diff --git a/LOG-SUMMARY b/LOG-SUMMARY
deleted file mode 100644
index 14d2e54..0000000
--- a/LOG-SUMMARY
+++ /dev/null
@@ -1,719 +0,0 @@
-logs from the modifications from scalapack-1.7.0 to scalapack-1.8.0
-
-********************************************************************************
-From Rev:1 to Rev:16
- A EXAMPLE
- A EXAMPLE/CSCAEXMAT.dat
- A EXAMPLE/CSCAEXRHS.dat
- A EXAMPLE/DSCAEXMAT.dat
- A EXAMPLE/DSCAEXRHS.dat
- A EXAMPLE/Makefile
- A EXAMPLE/SCAEX.dat
- A EXAMPLE/SSCAEXMAT.dat
- A EXAMPLE/SSCAEXRHS.dat
- A EXAMPLE/ZSCAEXMAT.dat
- A EXAMPLE/ZSCAEXRHS.dat
- A EXAMPLE/pcscaex.f
- A EXAMPLE/pdscaex.f
- A EXAMPLE/pdscaexinfo.f
- A EXAMPLE/psscaex.f
- A EXAMPLE/pzscaex.f
- M Makefile
- M README
- M PBLAS/SRC/PBtools.h
- M PBLAS/SRC/pblas.h
- M PBLAS/SRC/pcscal_.c
- M PBLAS/SRC/pdscal_.c
- M PBLAS/SRC/psscal_.c
- M PBLAS/SRC/pzscal_.c
- D SLmake.inc
- A SLmake.inc.example (from SLmake.inc:16)
- M SRC/Makefile
- M SRC/dlasorte.f
- M SRC/pslared1d.f
- M SRC/pdlared1d.f
- M SRC/pslared2d.f
- M SRC/pdlared2d.f
- M SRC/pcgesv.f
- M SRC/psgesv.f
- M SRC/pdgesv.f
- M SRC/pzgesv.f
- M SRC/pslahqr.f
- M SRC/pslahrd.f
- M SRC/pslasmsub.f
- M SRC/psstein.f
- M SRC/pclahqr.f
- M SRC/pdlahqr.f
- M SRC/pdlahrd.f
- M SRC/pdlasmsub.f
- M SRC/pdstein.f
- M SRC/pzlahqr.f
- M SRC/pzlahrd.f
- M SRC/pzlasmsub.f
- M SRC/pzrot.c
- M SRC/pzstein.f
- M SRC/pztrevc.f
- M SRC/slasorte.f
- M SRC/pclahrd.f
- M SRC/pclasmsub.f
- M SRC/pcrot.c
- M SRC/pcstein.f
- M SRC/pctrevc.f
- M SRC/pzgesvd.f
- M SRC/pcgesvd.f
- M SRC/psgesvd.f
- M SRC/pdgesvd.f
- M SRC/psdbtrf.f
- M SRC/pcheevd.f
- M SRC/pzheevd.f
- M SRC/pcheevx.f
- M SRC/pzheevx.f
- M SRC/pchegvx.f
- M SRC/pzhegvx.f
- M SRC/pdsygvx.f
- M SRC/pssyevx.f
- M SRC/pssygvx.f
- M SRC/pdsyevx.f
- M SRC/pcgetri.f
- M SRC/pdgetri.f
- M SRC/psgetri.f
- M SRC/pzgetri.f
- M TESTING/EIG/pcevcdriver.f
- M TESTING/EIG/pcgehdrv.f
- M TESTING/EIG/pcgsepreq.f
- M TESTING/EIG/pcseptst.f
- M TESTING/EIG/pdgehdrv.f
- M TESTING/EIG/pdgsepreq.f
- M TESTING/EIG/psgehdrv.f
- M TESTING/EIG/psgsepreq.f
- M TESTING/EIG/pzevcdriver.f
- M TESTING/EIG/pzgehdrv.f
- M TESTING/EIG/pzgsepreq.f
- M TESTING/EIG/pzseptst.f
- M TESTING/LIN/pcinvdriver.f
- M TESTING/LIN/pdinvdriver.f
- M TESTING/LIN/psinvdriver.f
- M TESTING/LIN/pzinvdriver.f
- M TOOLS/LAPACK/Makefile
- D TOOLS/LAPACK/cbdsqr.f
- D TOOLS/LAPACK/cgbtf2.f
- D TOOLS/LAPACK/cgbtrf.f
- D TOOLS/LAPACK/cgetf2.f
- D TOOLS/LAPACK/cgetrf.f
- D TOOLS/LAPACK/cgetrs.f
- D TOOLS/LAPACK/chetd2.f
- D TOOLS/LAPACK/chetrd.f
- D TOOLS/LAPACK/clacgv.f
- D TOOLS/LAPACK/clacpy.f
- D TOOLS/LAPACK/cladiv.f
- D TOOLS/LAPACK/claev2.f
- M TOOLS/LAPACK/clagge.f
- M TOOLS/LAPACK/claghe.f
- M TOOLS/LAPACK/clagsy.f
- D TOOLS/LAPACK/clanhs.f
- D TOOLS/LAPACK/clarf.f
- D TOOLS/LAPACK/clarfb.f
- D TOOLS/LAPACK/clarfg.f
- D TOOLS/LAPACK/clarft.f
- M TOOLS/LAPACK/clarnd.f
- M TOOLS/LAPACK/clarot.f
- D TOOLS/LAPACK/clartg.f
- D TOOLS/LAPACK/clascl.f
- D TOOLS/LAPACK/claset.f
- D TOOLS/LAPACK/clasr.f
- D TOOLS/LAPACK/classq.f
- D TOOLS/LAPACK/claswp.f
- M TOOLS/LAPACK/clatm1.f
- M TOOLS/LAPACK/clatms.f
- D TOOLS/LAPACK/clatrd.f
- D TOOLS/LAPACK/cpbtf2.f
- D TOOLS/LAPACK/cpbtrf.f
- D TOOLS/LAPACK/cpotf2.f
- D TOOLS/LAPACK/cpotrf.f
- D TOOLS/LAPACK/cpttrf.f
- D TOOLS/LAPACK/crot.f
- D TOOLS/LAPACK/cstedc.f
- D TOOLS/LAPACK/cstein.f
- D TOOLS/LAPACK/csymv.f
- D TOOLS/LAPACK/ctbtrs.f
- D TOOLS/LAPACK/ctrtrs.f
- D TOOLS/LAPACK/cunm2l.f
- D TOOLS/LAPACK/cunm2r.f
- D TOOLS/LAPACK/cunmql.f
- D TOOLS/LAPACK/cunmqr.f
- D TOOLS/LAPACK/cunmtr.f
- D TOOLS/LAPACK/dbdsqr.f
- D TOOLS/LAPACK/dgbtf2.f
- D TOOLS/LAPACK/dgbtrf.f
- D TOOLS/LAPACK/dgetf2.f
- D TOOLS/LAPACK/dgetrf.f
- D TOOLS/LAPACK/dgetrs.f
- D TOOLS/LAPACK/dlabad.f
- D TOOLS/LAPACK/dlacpy.f
- D TOOLS/LAPACK/dladiv.f
- D TOOLS/LAPACK/dlae2.f
- D TOOLS/LAPACK/dlaed0.f
- D TOOLS/LAPACK/dlaed1.f
- D TOOLS/LAPACK/dlaed2.f
- D TOOLS/LAPACK/dlaed3.f
- D TOOLS/LAPACK/dlaed4.f
- D TOOLS/LAPACK/dlaed5.f
- D TOOLS/LAPACK/dlaed6.f
- D TOOLS/LAPACK/dlaed7.f
- D TOOLS/LAPACK/dlaed8.f
- D TOOLS/LAPACK/dlaed9.f
- D TOOLS/LAPACK/dlaeda.f
- D TOOLS/LAPACK/dlaev2.f
- M TOOLS/LAPACK/dlagge.f
- M TOOLS/LAPACK/dlagsy.f
- D TOOLS/LAPACK/dlagtf.f
- D TOOLS/LAPACK/dlagts.f
- D TOOLS/LAPACK/dlahqr.f
- D TOOLS/LAPACK/dlamch.f
- D TOOLS/LAPACK/dlamrg.f
- D TOOLS/LAPACK/dlange.f
- D TOOLS/LAPACK/dlanhs.f
- D TOOLS/LAPACK/dlanst.f
- D TOOLS/LAPACK/dlanv2.f
- D TOOLS/LAPACK/dlapy2.f
- D TOOLS/LAPACK/dlapy3.f
- M TOOLS/LAPACK/dlaran.f
- D TOOLS/LAPACK/dlarf.f
- D TOOLS/LAPACK/dlarfb.f
- D TOOLS/LAPACK/dlarfg.f
- D TOOLS/LAPACK/dlarft.f
- M TOOLS/LAPACK/dlarnd.f
- D TOOLS/LAPACK/dlarnv.f
- M TOOLS/LAPACK/dlarot.f
- D TOOLS/LAPACK/dlartg.f
- D TOOLS/LAPACK/dlaruv.f
- D TOOLS/LAPACK/dlas2.f
- D TOOLS/LAPACK/dlascl.f
- D TOOLS/LAPACK/dlaset.f
- D TOOLS/LAPACK/dlasq1.f
- D TOOLS/LAPACK/dlasq2.f
- D TOOLS/LAPACK/dlasq3.f
- D TOOLS/LAPACK/dlasq4.f
- D TOOLS/LAPACK/dlasq5.f
- D TOOLS/LAPACK/dlasq6.f
- D TOOLS/LAPACK/dlasr.f
- D TOOLS/LAPACK/dlasrt.f
- D TOOLS/LAPACK/dlassq.f
- D TOOLS/LAPACK/dlasv2.f
- D TOOLS/LAPACK/dlaswp.f
- M TOOLS/LAPACK/dlatm1.f
- M TOOLS/LAPACK/dlatms.f
- D TOOLS/LAPACK/dlatrd.f
- D TOOLS/LAPACK/dorm2l.f
- D TOOLS/LAPACK/dorm2r.f
- D TOOLS/LAPACK/dormql.f
- D TOOLS/LAPACK/dormqr.f
- D TOOLS/LAPACK/dormtr.f
- D TOOLS/LAPACK/dpbtf2.f
- D TOOLS/LAPACK/dpbtrf.f
- D TOOLS/LAPACK/dpotf2.f
- D TOOLS/LAPACK/dpotrf.f
- D TOOLS/LAPACK/dpttrf.f
- D TOOLS/LAPACK/dstedc.f
- D TOOLS/LAPACK/dstein.f
- D TOOLS/LAPACK/dsteqr.f
- D TOOLS/LAPACK/dsterf.f
- D TOOLS/LAPACK/dsytd2.f
- D TOOLS/LAPACK/dsytrd.f
- D TOOLS/LAPACK/dtbtrs.f
- D TOOLS/LAPACK/dtrtrs.f
- D TOOLS/LAPACK/dzsum1.f
- D TOOLS/LAPACK/ilaenv.f
- D TOOLS/LAPACK/lsame.f
- D TOOLS/LAPACK/lsamen.f
- D TOOLS/LAPACK/sbdsqr.f
- D TOOLS/LAPACK/scsum1.f
- D TOOLS/LAPACK/sgbtf2.f
- D TOOLS/LAPACK/sgbtrf.f
- D TOOLS/LAPACK/sgetf2.f
- D TOOLS/LAPACK/sgetrf.f
- D TOOLS/LAPACK/sgetrs.f
- D TOOLS/LAPACK/slabad.f
- D TOOLS/LAPACK/slacpy.f
- D TOOLS/LAPACK/sladiv.f
- D TOOLS/LAPACK/slae2.f
- D TOOLS/LAPACK/slaed0.f
- D TOOLS/LAPACK/slaed1.f
- D TOOLS/LAPACK/slaed2.f
- D TOOLS/LAPACK/slaed3.f
- D TOOLS/LAPACK/slaed4.f
- D TOOLS/LAPACK/slaed5.f
- D TOOLS/LAPACK/slaed6.f
- D TOOLS/LAPACK/slaed7.f
- D TOOLS/LAPACK/slaed8.f
- D TOOLS/LAPACK/slaed9.f
- D TOOLS/LAPACK/slaeda.f
- D TOOLS/LAPACK/slaev2.f
- M TOOLS/LAPACK/slagge.f
- M TOOLS/LAPACK/slagsy.f
- D TOOLS/LAPACK/slagtf.f
- D TOOLS/LAPACK/slagts.f
- D TOOLS/LAPACK/slahqr.f
- D TOOLS/LAPACK/slamch.f
- D TOOLS/LAPACK/slamrg.f
- D TOOLS/LAPACK/slange.f
- D TOOLS/LAPACK/slanhs.f
- D TOOLS/LAPACK/slanst.f
- D TOOLS/LAPACK/slanv2.f
- D TOOLS/LAPACK/slapy2.f
- D TOOLS/LAPACK/slapy3.f
- M TOOLS/LAPACK/slaran.f
- D TOOLS/LAPACK/slarf.f
- D TOOLS/LAPACK/slarfb.f
- D TOOLS/LAPACK/slarfg.f
- D TOOLS/LAPACK/slarft.f
- M TOOLS/LAPACK/slarnd.f
- D TOOLS/LAPACK/slarnv.f
- M TOOLS/LAPACK/slarot.f
- D TOOLS/LAPACK/slartg.f
- D TOOLS/LAPACK/slaruv.f
- D TOOLS/LAPACK/slas2.f
- D TOOLS/LAPACK/slascl.f
- D TOOLS/LAPACK/slaset.f
- D TOOLS/LAPACK/slasq1.f
- D TOOLS/LAPACK/slasq2.f
- D TOOLS/LAPACK/slasq3.f
- D TOOLS/LAPACK/slasq4.f
- D TOOLS/LAPACK/slasq5.f
- D TOOLS/LAPACK/slasq6.f
- D TOOLS/LAPACK/slasr.f
- D TOOLS/LAPACK/slasrt.f
- D TOOLS/LAPACK/slassq.f
- D TOOLS/LAPACK/slasv2.f
- D TOOLS/LAPACK/slaswp.f
- M TOOLS/LAPACK/slatm1.f
- M TOOLS/LAPACK/slatms.f
- D TOOLS/LAPACK/slatrd.f
- D TOOLS/LAPACK/sorm2l.f
- D TOOLS/LAPACK/sorm2r.f
- D TOOLS/LAPACK/sormql.f
- D TOOLS/LAPACK/sormqr.f
- D TOOLS/LAPACK/sormtr.f
- D TOOLS/LAPACK/spbtf2.f
- D TOOLS/LAPACK/spbtrf.f
- D TOOLS/LAPACK/spotf2.f
- D TOOLS/LAPACK/spotrf.f
- D TOOLS/LAPACK/spttrf.f
- D TOOLS/LAPACK/sstedc.f
- D TOOLS/LAPACK/sstein.f
- D TOOLS/LAPACK/ssteqr.f
- D TOOLS/LAPACK/ssterf.f
- D TOOLS/LAPACK/ssytd2.f
- D TOOLS/LAPACK/ssytrd.f
- D TOOLS/LAPACK/stbtrs.f
- D TOOLS/LAPACK/strtrs.f
- D TOOLS/LAPACK/xerbla.f
- D TOOLS/LAPACK/zbdsqr.f
- D TOOLS/LAPACK/zgbtf2.f
- D TOOLS/LAPACK/zgbtrf.f
- D TOOLS/LAPACK/zgetf2.f
- D TOOLS/LAPACK/zgetrf.f
- D TOOLS/LAPACK/zgetrs.f
- D TOOLS/LAPACK/zhetd2.f
- D TOOLS/LAPACK/zhetrd.f
- D TOOLS/LAPACK/zlacgv.f
- D TOOLS/LAPACK/zlacpy.f
- D TOOLS/LAPACK/zladiv.f
- D TOOLS/LAPACK/zlaev2.f
- M TOOLS/LAPACK/zlagge.f
- M TOOLS/LAPACK/zlaghe.f
- M TOOLS/LAPACK/zlagsy.f
- D TOOLS/LAPACK/zlanhs.f
- D TOOLS/LAPACK/zlarf.f
- D TOOLS/LAPACK/zlarfb.f
- D TOOLS/LAPACK/zlarfg.f
- D TOOLS/LAPACK/zlarft.f
- M TOOLS/LAPACK/zlarnd.f
- M TOOLS/LAPACK/zlarot.f
- D TOOLS/LAPACK/zlartg.f
- D TOOLS/LAPACK/zlascl.f
- D TOOLS/LAPACK/zlaset.f
- D TOOLS/LAPACK/zlasr.f
- D TOOLS/LAPACK/zlassq.f
- D TOOLS/LAPACK/zlaswp.f
- M TOOLS/LAPACK/zlatm1.f
- M TOOLS/LAPACK/zlatms.f
- D TOOLS/LAPACK/zlatrd.f
- D TOOLS/LAPACK/zpbtf2.f
- D TOOLS/LAPACK/zpbtrf.f
- D TOOLS/LAPACK/zpotf2.f
- D TOOLS/LAPACK/zpotrf.f
- D TOOLS/LAPACK/zpttrf.f
- D TOOLS/LAPACK/zrot.f
- D TOOLS/LAPACK/zstedc.f
- D TOOLS/LAPACK/zstein.f
- D TOOLS/LAPACK/zsymv.f
- D TOOLS/LAPACK/ztbtrs.f
- D TOOLS/LAPACK/ztrtrs.f
- D TOOLS/LAPACK/zunm2l.f
- D TOOLS/LAPACK/zunm2r.f
- D TOOLS/LAPACK/zunmql.f
- D TOOLS/LAPACK/zunmqr.f
- D TOOLS/LAPACK/zunmtr.f
- M TOOLS/Makefile
- A TOOLS/pclaread.f
- A TOOLS/pclawrite.f
- A TOOLS/pdlaread.f
- A TOOLS/pdlawrite.f
- A TOOLS/pslaread.f
- A TOOLS/pslawrite.f
- A TOOLS/pzlaread.f
- A TOOLS/pzlawrite.f
-
-********************************************************************************
-
-********************************************************************************
-r17
-- Add p[sdcz]read and p[sdcz]write routines in TOOLS.
-The pdlaread and pdlawrite routine were contained in the scalapack example. I generates the 3 other precisions.
-
-- Add the example in the four precisions in the EXAMPLE directory.
-
-- Modify the Makefile to add a "make example" and a "make cleanexample"
-
-- Change the SLmake.inc to SLmake.inc.example
-
-- Update the README file
-
-********************************************************************************
-r16
-Remove LAPACK from ScaLAPACK.
-=============================
-Some LAPACK routines from TESTING/MATGEN still remains inside.
-I updated them to the latest LAPACK release.(ie 3.1.1)
-Add the LAPACKLIB variable in the SLmake.inc
-Modify the Makefile in TOOLS/LAPACK.
-
-********************************************************************************
-r15
- Add crot and zrot in SRC/pblas.h
-
-********************************************************************************
-r14
-Patches provided by Ake Sandgren and Robert Granat
----------------------------------------------------
-The set of patches for scalapack 1.7.4 does two things.
-1 - reduce the usage of uninitialized variables
-2 - fix a couple of incorrect calls to blacs (bad LDA)
-
-The gehdrv patch is just the complete patch related to
-https://icl.cs.utk.edu/lapack-forum/viewtopic.php?p=1153#1153
-
-pxsepinfo doesnt initialize THRESH when INFO != 0.
-
-I'm not sure if the pxlahrd patch is the best. Maybe something should be
-done in pxlarfg instead since alpha isn't set in all cases there, like
-myrow != ixrow for row distribution and likewise for column
-distribution.
-
-pxlasmsub destroys irow1/icol1 in the "find some norm of the local H"
-part.
-
-pxrot used incorrect LDA values for buff in several places, not sure if
-the intention was to have buff Mx1 or 1xM but it shouldn't really matter
-should it?
-
-PBLAS/pxscal must not test ALPHA unless it is really going to be used
-since scalapack routines sometimes call pxscal with ALPHA uninitialized
-when myrow != Xrow/mycol != Xcol.
-
-pxstein must initialize ONENRM since it isn't always initialized in the
-"IF( NBLK.EQ.IBLOCK( NEXT-1 ) .AND. NBLK.NE.OLNBLK ) THEN" case before
-being used in the "IF( TMPFAC.GT.ODM18 ) THEN" case. Maybe setting to
-ZERO is wrong but its not worse then the original code.
-
-pxtrevc and pxevcdriver are just incorrect LDA param to blacs routines.
-
-All these was found with pathscale compiler with -trapuv -O0 -g which
-initialized everything to NaN and turns FPE traps on.
-
---------------------------------------------------------------------------
-
-The lahqr patch and a fix to lasorte needed by lahqr which
-used to get IERR != 0 back from lasorte.
-
-The T2 = T1*V2 and T3 = T1*V3 moves are needed due to uninitialized
-data.
-The 2 changed IF-statements where brought about to make getting and
-sending SMALLA consistent.
-The ISTOP change at the bottom is a copy of the corresponding statement
-at the top of the loop.
-
-The init of VCOPY and SMALLA are neccesary.
-
-lasorte couldn't handle a situation where the top S(1,1) eigenvalue was
-real.
-
-This set of patches have been tested as can be seen on
-https://icl.cs.utk.edu/lapack-forum/viewtopic.php?p=1196#1196
-so i'm fairly certain that they work correctly.
-
-********************************************************************************
-r13
-Last Modification: julie - Tue, 16 Jan 2007
-
-Add 2 missing routines in TOOLS/LAPACK : cbdsqr.f and zbdsqr.f needed by the complex version of the SVD driver
-
-********************************************************************************
-
-r12
-Last Modification: langou - Wed, 10 May 2006
-
-
-Following up on r11. In r11, we have increased the size of the integer
-workspace in the rectangular case. We now report the new integer block size
-calculation in the tester. So that the LIWORK given by the tester to the
-PxGETRI is big enough ...
-
-********************************************************************************
-
-r11
-Last Modification: langou - Wed, 10 May 2006
-
--------------------------------------------------------------
-Correct the integer workspace (IWORK) calculation in PxGETRI.
--------------------------------------------------------------
-
-Bug report send by Desheng Wang from Caltech on scalapack at cs.utk.edu, Mon, 1
-May 2006.
-
-Fix:
-Replace the line 221-222:
-
- LIWMIN = NQ + MAX( ICEIL( ICEIL( MP, DESCA( MB_ ) ),
- $ LCM / NPROW ), DESCA( NB_ ) )
-
-By:
- LIWMIN = NUMROC( DESCA( M_ ) + DESCA( MB_ ) * NPROW
- $ + MOD ( IA - 1, DESCA( MB_ ) ), DESCA ( NB_ ),
- $ MYCOL, DESCA( CSRC_ ), NPCOL ) +
- $ MAX ( DESCA( MB_ ) * ICEIL ( ICEIL(
- $ NUMROC( DESCA( M_ ) + DESCA( MB_ ) * NPROW,
- $ DESCA( MB_ ), MYROW, DESCA( RSRC_ ), NPROW ),
- $ DESCA( MB_ ) ), LCM / NPROW ), DESCA( NB_ ) )
-
-Yep, slightly more complex...
-
-The error in the first computation is that it misinterpret the statement in
-PxLAPIV: The formula for the integer worskpace calculation in PxLAPIV is
-
- LDW = LOCc( M_P + MOD(IP-1, MB_P) ) +
- MB_P * CEIL( CEIL(LOCr(M_P)/MB_P) / (LCM/NPROW) )
-
-where M_P is the local size of the IPIV. But the IPIV is slighlty bigger than A,
-the global size of IPIV is:
- MP = DESCA( M_ ) + DESCA( MB_ ) * NPROW
-(and not DESCA(M_)).
-
-The other quantities are given by
-
- M_P is the global length of the pivot vector
- MP = DESCA( M_ ) + DESCA( MB_ ) * NPROW
- I_P is IA
- I_P = IA
- MB_P is the block size use for the block cyclic distribution of the
- pivot vector
- MB_P = DESCA (MB_ )
- LOCc ( . )
- NUMROC ( . , DESCA ( NB_ ), MYCOL, DESCA ( CSRC_ ), NPCOL )
- LOCr ( . )
- NUMROC ( . , DESCA ( MB_ ), MYROW, DESCA ( RSRC_ ), NPROW )
- CEIL ( X / Y )
- ICEIL( X, Y )
- LCM
- LCM = ILCM( NPROW, NPCOL )
-
-and this gives the new formula to compute the integer workspace.
-
-********************************************************************************
-
-Rev: 10
-Last modification: langou - Wed, 22 Mar 2006
-
-Bug report from Yasuhiro Nakahara (Canon inc.) on 03/13/2006:
-
- Description: pzlahqr routine was aborted due to a segmentation fault.
- I found an invalid memory access at the line 525 in pzlahqr.f.
- In the DO-loop, with II=1, S1(1, 0) was accessed.
-
-Patch from Greg Henry (Intel) and Mark Fahey (ORNL)
-
-Greg said:
-> There is an easy fix for this- the idea of exceptional shifts is
-> to just try something outside the norm based on the size of the diagonal
-> elements. The offending part can be removed from the code without a
-> loss of generality. I think I may be able to come with an alternate
-> solution.
-
-
-move from
----------------------------------------------------------------
-*
-* Exceptional shift.
-*
- DO 20 II = 2*JBLK, 1, -1
- S1( II, II ) = CONST*( CABS1( S1( II, II ) )+
- $ CABS1( S1( II, II-1 ) ) )
- S1( II, II-1 ) = ZERO
- S1( II-1, II ) = ZERO
- 20 CONTINUE
----------------------------------------------------------------
- (with problem when II=1 ...)
-to
----------------------------------------------------------------
-*
-* Exceptional shift.
-*
- DO 20 II = 2*JBLK, 2, -1
- S1( II, II ) = CONST*( CABS1( S1( II, II ) )+
- $ CABS1( S1( II, II-1 ) ) )
- S1( II, II-1 ) = ZERO
- S1( II-1, II ) = ZERO
- 20 CONTINUE
- S1( 1, 1 ) = CONST*CABS1( S1( 1, 1 ) )
----------------------------------------------------------------
-
-Note that this part of the code is not exercized by the testing.
-(So the bug was hard to find.)
-
-
-
-********************************************************************************
-
-Rev: 9
-Last modification: julie - Thu, 23 Feb 2006
-
-Correct typo in the [S,D,C,Z]gesvd files for the delaclaration of WP[S,D,C,Z]ORMBRQLN
-
-********************************************************************************
-
-Rev: 8
-Last modification: julie - Wed, 22 Feb 2006
-
-Modify typo in comment + description of workspace.
-When RANGE='V', work need to be of dimension 3
-
-
-********************************************************************************
-
-Rev: 7
-Last modification: julie - Mon, 20 Feb 2006
-
-Correction of a Typo mistake in the work comment.
-
-********************************************************************************
-
-Rev: 6
-Last modification: julie - Wed, 01 Feb 2006
-
-Modify the makefile to add the two new driver: pcgesvd.f and pzgesvd.f
-
-********************************************************************************
-
-Rev: 5
-Last modification: Rev 5 - langou - 2006-01-31 05:13:22
-Log message:
-M SRC/psgesvd.f
-M SRC/pcgesvd.f
-M SRC/pzgesvd.f
-M SRC/pdgesvd.f
-
-modify the workspace size of xBDSQR to follow the revision 184 of LAPACK the
-workspace size of xBDSQR has moved from
-* WDBDSQR = MAX(1, 4*SIZE )
-to
-* WDBDSQR = MAX(1, 2*SIZE + (2*SIZE - 4)*MAX(WANTU, WANTVT))
-and is now back to
-* WDBDSQR = MAX(1, 4*SIZE )
-so SVD of ScaLAPACK is following (at least let us take the max of both until
-LAPACK is fixed on its workspace size)
-
-********************************************************************************
-
-Rev: 4
-Last modification: Rev 4 - langou - 2006-01-31 04:52:48
-Log message:
-M SRC/pslahrd.f
-M SRC/pdlahqr.f
-(forgot to change the date in the header in the last revision, corrected)
-
-M SRC/psgesvd.f
-M SRC/pdgesvd.f
-[Julien/Osni]
-correct a bug in the workspace utilisation of p_gesvd. In the case jobU='V' and
-jobVT='V', the routine has good pointers, otherwise the pointers in the
-workspace where shifted as if matrices U and VT existed which implied out of
-bound reference for the value stored at the end of the workspace. There was
-also a few problems at the end of the code with some sizes in the case of
-rectangular matrices.
-
-A SRC/pcgesvd.f
-A SRC/pzgesvd.f
-add the complex version of the SVD driver contributed code by Peng Du (Graduate
-Research Assistant at UTK, Fall 2005) supervised by Julien
-
-********************************************************************************
-
-Rev: 3
-Last modification: Rev 3 - langou - 2006-01-30 17:35:23
-Log message:
-SRC/p[s,d,c,z]gesv.f
-
-[Documentation correction]
-correction in the description of the parameter NRHS (it's the number of columns
-of B not A)
-
-SRC/p[s,d]lared1d.f
-SRC/p[s,d]lared2d.f
-
-[Documentation correction]
-[Julien]
-
-The comments in the routines p[s,d]lared2d (where the initial vectors are
-stored by row) were wrong (basically replace BYCOL by BYROW)
-
-Some homogeneization among the 4 routines as well
-
-SRC/p[s/d]lahrd.f
-
-Although the Schur form returned by p[s/d]lahqr was correct (as tested by the
-testing routine), the returned eigenvalues were not computed correctely. This
-bug was reported by Interactive Supercompting (Thanks!). The bug was already
-found by Greg Henry in March 2002 but the patch has never been released. Here
-we go.
-
-********************************************************************************
-
-Rev: 2
-
-********************************************************************************
-
-Rev: 1
-
-SCALAPACK/PBLAS/SRC/PBtools.h 3/12/2002
- Comment out CSYMM reference (line 57)
-
-SCALAPACK/PBLAS/SRC/pblas.h 3/15/2002
- Added missing crot define
-
-SCALAPACK/SRC/psdbtrf.f 3/12/2002
- Typo (DLACPY->SLACPY) in EXTERNAL declaration (line 374)
-
-SCALAPACK/SRC/pcheevd.f 3/25/2002
-SCALAPACK/SRC/pzheevd.f
- Correction to LRWORK (lines 117, 248) and INFO=0 return
-
-SCALAPACK/TESTING/EIG/pcseptst.f 3/15/2002
-SCALAPACK/TESTING/EIG/pzseptst.f
- Correction to LHEEVDSIZE calculation (line 1064)
-
-
-for more information, please visit: http://www.netlib.org/scalapack/errata.html#sourcecode
-
-
-********************************************************************************
diff --git a/Makefile b/Makefile
index cbcb045..3de23ba 100644
--- a/Makefile
+++ b/Makefile
@@ -16,7 +16,6 @@
include SLmake.inc
-#PRECISIONS = single double complex complex16 FRC=FRC
PRECISIONS = single double complex complex16
############################################################################
@@ -48,53 +47,62 @@ PRECISIONS = single double complex complex16
#
############################################################################
-all: lib
-#all: lib exe example
+all: lib exe example
-lib: toolslib pblaslib redistlib scalapacklib
+lib: blacslib toolslib pblaslib redistlib scalapacklib
-exe: pblasexe redistexe scalapackexe
+exe: blacsexe pblasexe redistexe scalapackexe
clean: cleanlib cleanexe cleanexample
+blacslib:
+ ( cd BLACS; $(MAKE) lib )
+
pblaslib:
- ( cd $(PBLASdir)/SRC; $(MAKE) $(PRECISIONS) )
+ ( cd PBLAS/SRC; $(MAKE) $(PRECISIONS) )
redistlib:
- ( cd $(REDISTdir)/SRC; $(MAKE) integer $(PRECISIONS) )
+ ( cd REDIST/SRC; $(MAKE) integer $(PRECISIONS) )
scalapacklib:
- ( cd $(SRCdir); $(MAKE) $(PRECISIONS) )
+ ( cd SRC; $(MAKE) $(PRECISIONS) )
toolslib:
- ( cd $(TOOLSdir); $(MAKE) $(PRECISIONS) )
+ ( cd TOOLS; $(MAKE) $(PRECISIONS) )
+
+blacsexe:
+ ( cd BLACS; $(MAKE) tester )
pblasexe:
- ( cd $(PBLASdir)/TESTING; $(MAKE) $(PRECISIONS) )
- ( cd $(PBLASdir)/TIMING; $(MAKE) $(PRECISIONS) )
+ ( cd PBLAS/TESTING; $(MAKE) $(PRECISIONS) )
+ ( cd PBLAS/TIMING; $(MAKE) $(PRECISIONS) )
scalapackexe:
- ( cd $(TESTdir)/LIN; $(MAKE) $(PRECISIONS) )
- ( cd $(TESTdir)/EIG; $(MAKE) $(PRECISIONS) )
+ ( cd TESTING/LIN; $(MAKE) $(PRECISIONS) )
+ ( cd TESTING/EIG; $(MAKE) $(PRECISIONS) )
redistexe:
- ( cd $(REDISTdir)/TESTING; $(MAKE) integer $(PRECISIONS) )
+ ( cd REDIST/TESTING; $(MAKE) integer $(PRECISIONS) )
example:
( cd EXAMPLE; $(MAKE) $(PRECISIONS) )
cleanexe:
- ( cd $(PBLASdir)/TESTING; $(MAKE) clean )
- ( cd $(PBLASdir)/TIMING; $(MAKE) clean )
- ( cd $(TESTdir)/LIN; $(MAKE) clean )
- ( cd $(TESTdir)/EIG; $(MAKE) clean )
- ( cd $(REDISTdir)/TESTING; $(MAKE) clean )
+ ( cd PBLAS/TESTING; $(MAKE) clean )
+ ( cd PBLAS/TIMING; $(MAKE) clean )
+ ( cd TESTING/LIN; $(MAKE) clean )
+ ( cd TESTING/EIG; $(MAKE) clean )
+ ( cd REDIST/TESTING; $(MAKE) clean )
+ ( cd BLACS/TESTING; $(MAKE) clean )
+ ( cd TESTING; rm -f x* )
cleanlib:
- ( cd $(PBLASdir)/SRC; $(MAKE) clean )
- ( cd $(SRCdir); $(MAKE) clean )
- ( cd $(TOOLSdir); $(MAKE) clean )
- ( cd $(REDISTdir)/SRC; $(MAKE) clean )
+ ( cd BLACS; $(MAKE) clean )
+ ( cd PBLAS/SRC; $(MAKE) clean )
+ ( cd SRC; $(MAKE) clean )
+ ( cd TOOLS; $(MAKE) clean )
+ ( cd REDIST/SRC; $(MAKE) clean )
+ ( rm -f $(SCALAPACKLIB) )
cleanexample:
( cd EXAMPLE; $(MAKE) clean )
diff --git a/PBLAS/CMakeLists.txt b/PBLAS/CMakeLists.txt
new file mode 100644
index 0000000..10b8b00
--- /dev/null
+++ b/PBLAS/CMakeLists.txt
@@ -0,0 +1,3 @@
+add_subdirectory(SRC)
+add_subdirectory(TESTING)
+add_subdirectory(TIMING)
diff --git a/PBLAS/SRC/CMakeLists.txt b/PBLAS/SRC/CMakeLists.txt
new file mode 100644
index 0000000..e213eca
--- /dev/null
+++ b/PBLAS/SRC/CMakeLists.txt
@@ -0,0 +1,67 @@
+add_subdirectory(PBBLAS)
+add_subdirectory(PTZBLAS)
+add_subdirectory(PTOOLS)
+
+set (APPBLAS pilaenv.f)
+
+#---------------------------------------------------------------------------
+# Level 1 PBLAS.
+#---------------------------------------------------------------------------
+
+set (PIBLAS1 picopy_.c)
+
+set (PSBLAS1 psswap_.c psscal_.c pscopy_.c psaxpy_.c psdot_.c psnrm2_.c
+ psasum_.c psamax_.c)
+
+set (PCBLAS1 pcswap_.c pcscal_.c pcsscal_.c pccopy_.c pcaxpy_.c pcdotu_.c
+ pcdotc_.c pscnrm2_.c pscasum_.c pcamax_.c)
+
+set (PDBLAS1 pdswap_.c pdscal_.c pdcopy_.c pdaxpy_.c pddot_.c pdnrm2_.c
+ pdasum_.c pdamax_.c)
+
+set (PZBLAS1 pzswap_.c pzscal_.c pzdscal_.c pzcopy_.c pzaxpy_.c pzdotu_.c
+ pzdotc_.c pdznrm2_.c pdzasum_.c pzamax_.c)
+
+#---------------------------------------------------------------------------
+# Level 2 PBLAS.
+#---------------------------------------------------------------------------
+
+set (PSBLAS2 psgemv_.c psger_.c pssymv_.c pssyr_.c pssyr2_.c pstrmv_.c
+ pstrsv_.c psagemv_.c psasymv_.c psatrmv_.c)
+
+set (PCBLAS2 pcgemv_.c pcgerc_.c pcgeru_.c pchemv_.c pcher_.c pcher2_.c
+ pctrmv_.c pctrsv_.c pcagemv_.c pcahemv_.c pcatrmv_.c)
+
+set (PDBLAS2 pdgemv_.c pdger_.c pdsymv_.c pdsyr_.c pdsyr2_.c pdtrmv_.c
+ pdtrsv_.c pdagemv_.c pdasymv_.c pdatrmv_.c)
+
+set (PZBLAS2 pzgemv_.c pzgerc_.c pzgeru_.c pzhemv_.c pzher_.c pzher2_.c
+ pztrmv_.c pztrsv_.c pzagemv_.c pzahemv_.c pzatrmv_.c)
+
+#---------------------------------------------------------------------------
+# Level 3 PBLAS.
+#---------------------------------------------------------------------------
+
+set (PSBLAS3 psgeadd_.c psgemm_.c pssymm_.c pssyr2k_.c pssyrk_.c pstradd_.c
+ pstran_.c pstrmm_.c pstrsm_.c)
+
+set (PCBLAS3 pcgeadd_.c pcgemm_.c pchemm_.c pcher2k_.c pcherk_.c pcsymm_.c
+ pcsyr2k_.c pcsyrk_.c pctradd_.c pctranc_.c pctranu_.c pctrmm_.c
+ pctrsm_.c)
+
+set (PDBLAS3 pdgeadd_.c pdgemm_.c pdsymm_.c pdsyr2k_.c pdsyrk_.c pdtradd_.c
+ pdtran_.c pdtrmm_.c pdtrsm_.c)
+
+set (PZBLAS3 pzgeadd_.c pzgemm_.c pzhemm_.c pzher2k_.c pzherk_.c pzsymm_.c
+ pzsyr2k_.c pzsyrk_.c pztradd_.c pztranc_.c pztranu_.c pztrmm_.c
+ pztrsm_.c)
+
+#---------------------------------------------------------------------------
+
+set (pblas
+ ${PIBLAS1}
+ ${PSBLAS1} ${PCBLAS1} ${PDBLAS1} ${PZBLAS1}
+ ${PSBLAS2} ${PCBLAS2} ${PDBLAS2} ${PZBLAS2}
+ ${PSBLAS3} ${PCBLAS3} ${PDBLAS3} ${PZBLAS3})
+
+set (pblas-F ${APPBLAS} )
\ No newline at end of file
diff --git a/PBLAS/SRC/Makefile b/PBLAS/SRC/Makefile
index 0dcb998..30c8c3a 100644
--- a/PBLAS/SRC/Makefile
+++ b/PBLAS/SRC/Makefile
@@ -50,8 +50,6 @@ include ../../SLmake.inc
#
# To remove the object files after the library is created, enter
# make clean
-# To force the source files to be recompiled, enter, for example,
-# make single FRC=FRC
#
############################################################################
@@ -113,25 +111,6 @@ PZBLAS3 = pzgeadd_.o pzgemm_.o pzhemm_.o pzher2k_.o pzherk_.o pzsymm_.o \
#---------------------------------------------------------------------------
-$(APPBLAS): $(FRC)
-
-$(PIBLAS1): $(FRC)
-
-$(PSBLAS1): $(FRC)
-$(PCBLAS1): $(FRC)
-$(PDBLAS1): $(FRC)
-$(PZBLAS1): $(FRC)
-
-$(PSBLAS2): $(FRC)
-$(PCBLAS2): $(FRC)
-$(PDBLAS2): $(FRC)
-$(PZBLAS2): $(FRC)
-
-$(PSBLAS3): $(FRC)
-$(PCBLAS3): $(FRC)
-$(PDBLAS3): $(FRC)
-$(PZBLAS3): $(FRC)
-
PIBLAS = $(PIBLAS1) $(APPBLAS)
PSBLAS = $(PSBLAS1) $(PSBLAS2) $(PSBLAS3) $(APPBLAS)
PCBLAS = $(PCBLAS1) $(PCBLAS2) $(PCBLAS3) $(APPBLAS)
@@ -139,39 +118,36 @@ PDBLAS = $(PDBLAS1) $(PDBLAS2) $(PDBLAS3) $(APPBLAS)
PZBLAS = $(PZBLAS1) $(PZBLAS2) $(PZBLAS3) $(APPBLAS)
integer: $(PIBLAS)
- $(ARCH) $(ARCHFLAGS) $(SCALAPACKLIB) $(PIBLAS)
- $(RANLIB) $(SCALAPACKLIB)
+ $(ARCH) $(ARCHFLAGS) ../../$(SCALAPACKLIB) $(PIBLAS)
+ $(RANLIB) ../../$(SCALAPACKLIB)
single: integer $(PSBLAS)
( cd PBBLAS; $(MAKE) single )
( cd PTZBLAS; $(MAKE) single )
( cd PTOOLS; $(MAKE) single )
- $(ARCH) $(ARCHFLAGS) $(SCALAPACKLIB) $(PSBLAS)
- $(RANLIB) $(SCALAPACKLIB)
+ $(ARCH) $(ARCHFLAGS) ../../$(SCALAPACKLIB) $(PSBLAS)
+ $(RANLIB) ../../$(SCALAPACKLIB)
double: integer $(PDBLAS)
( cd PBBLAS; $(MAKE) double )
( cd PTZBLAS; $(MAKE) double )
( cd PTOOLS; $(MAKE) double )
- $(ARCH) $(ARCHFLAGS) $(SCALAPACKLIB) $(PDBLAS)
- $(RANLIB) $(SCALAPACKLIB)
+ $(ARCH) $(ARCHFLAGS) ../../$(SCALAPACKLIB) $(PDBLAS)
+ $(RANLIB) ../../$(SCALAPACKLIB)
complex: integer $(PCBLAS)
( cd PBBLAS; $(MAKE) complex )
( cd PTZBLAS; $(MAKE) complex )
( cd PTOOLS; $(MAKE) complex )
- $(ARCH) $(ARCHFLAGS) $(SCALAPACKLIB) $(PCBLAS)
- $(RANLIB) $(SCALAPACKLIB)
+ $(ARCH) $(ARCHFLAGS) ../../$(SCALAPACKLIB) $(PCBLAS)
+ $(RANLIB) ../../$(SCALAPACKLIB)
complex16: integer $(PZBLAS)
( cd PBBLAS; $(MAKE) complex16 )
( cd PTZBLAS; $(MAKE) complex16 )
( cd PTOOLS; $(MAKE) complex16 )
- $(ARCH) $(ARCHFLAGS) $(SCALAPACKLIB) $(PZBLAS)
- $(RANLIB) $(SCALAPACKLIB)
-
-FRC:
- @FRC=$(FRC)
+ $(ARCH) $(ARCHFLAGS) ../../$(SCALAPACKLIB) $(PZBLAS)
+ $(RANLIB) ../../$(SCALAPACKLIB)
clean :
rm -f *.o
@@ -179,12 +155,12 @@ clean :
( cd PTZBLAS; $(MAKE) clean )
( cd PTOOLS; $(MAKE) clean )
-.f.o : ; $(F77) -c $(F77FLAGS) $*.f
+.f.o : ; $(FC) -c $(FCFLAGS) $*.f
-.c.o : ; $(CC) -c $(CCFLAGS) $(CDEFS) $*.c
+.c.o : ; $(CC) -c $(CDEFS) $(CCFLAGS) $*.c
#
# To compile without input argument checking replace previous line by
-# .c.o : ; $(CC) -c $(CCFLAGS) $(CDEFS) -DNO_ARGCHK $*.c
+# .c.o : ; $(CC) -c $(CCFLAGS) -DNO_ARGCHK $*.c
#
# Note that when the PBLAS routines have been compiled without input ar-
# gument checking, it is impossible to test PBLAS error exits. Trying to
diff --git a/PBLAS/SRC/PBBLAS/CMakeLists.txt b/PBLAS/SRC/PBBLAS/CMakeLists.txt
new file mode 100644
index 0000000..eb48f95
--- /dev/null
+++ b/PBLAS/SRC/PBBLAS/CMakeLists.txt
@@ -0,0 +1,14 @@
+set (PBSBLASAUX pbstran.f pbsmatadd.f pbstrsrt.f pbstrget.f
+ pbstrnv.f pbsvecadd.f pbstrst1.f)
+
+set (PBCBLASAUX pbctran.f pbcmatadd.f pbctrsrt.f pbctrget.f
+ pbctrnv.f pbcvecadd.f pbctrst1.f)
+
+set (PBDBLASAUX pbdtran.f pbdmatadd.f pbdtrsrt.f pbdtrget.f
+ pbdtrnv.f pbdvecadd.f pbdtrst1.f)
+
+set (PBZBLASAUX pbztran.f pbzmatadd.f pbztrsrt.f pbztrget.f
+ pbztrnv.f pbzvecadd.f pbztrst1.f)
+
+set(pbblas
+ ${PBSBLASAUX} ${PBCBLASAUX} ${PBDBLASAUX} ${PBZBLASAUX})
diff --git a/PBLAS/SRC/PBBLAS/Makefile b/PBLAS/SRC/PBBLAS/Makefile
index 9d298bb..60ca4f7 100644
--- a/PBLAS/SRC/PBBLAS/Makefile
+++ b/PBLAS/SRC/PBBLAS/Makefile
@@ -32,8 +32,6 @@ include ../../../SLmake.inc
#
# To remove the object files after the library is created, enter
# make clean
-# To force the source files to be recompiled, enter, for example,
-# make single FRC=FRC
#
############################################################################
@@ -53,35 +51,25 @@ PBZBLASAUX = pbztran.o pbzmatadd.o pbztrsrt.o pbztrget.o \
#---------------------------------------------------------------------------
-$(PBSBLASAUX) : $(FRC)
-$(PBCBLASAUX) : $(FRC)
-$(PBDBLASAUX) : $(FRC)
-$(PBZBLASAUX) : $(FRC)
-
-#---------------------------------------------------------------------------
-
single: $(PBSBLASAUX)
- $(ARCH) $(ARCHFLAGS) $(SCALAPACKLIB) $(PBSBLASAUX)
- $(RANLIB) $(SCALAPACKLIB)
+ $(ARCH) $(ARCHFLAGS) ../../../$(SCALAPACKLIB) $(PBSBLASAUX)
+ $(RANLIB) ../../../$(SCALAPACKLIB)
double: $(PBDBLASAUX)
- $(ARCH) $(ARCHFLAGS) $(SCALAPACKLIB) $(PBDBLASAUX)
- $(RANLIB) $(SCALAPACKLIB)
+ $(ARCH) $(ARCHFLAGS) ../../../$(SCALAPACKLIB) $(PBDBLASAUX)
+ $(RANLIB) ../../../$(SCALAPACKLIB)
complex: $(PBCBLASAUX)
- $(ARCH) $(ARCHFLAGS) $(SCALAPACKLIB) $(PBCBLASAUX)
- $(RANLIB) $(SCALAPACKLIB)
+ $(ARCH) $(ARCHFLAGS) ../../../$(SCALAPACKLIB) $(PBCBLASAUX)
+ $(RANLIB) ../../../$(SCALAPACKLIB)
complex16: $(PBZBLASAUX)
- $(ARCH) $(ARCHFLAGS) $(SCALAPACKLIB) $(PBZBLASAUX)
- $(RANLIB) $(SCALAPACKLIB)
+ $(ARCH) $(ARCHFLAGS) ../../../$(SCALAPACKLIB) $(PBZBLASAUX)
+ $(RANLIB) ../../../$(SCALAPACKLIB)
#---------------------------------------------------------------------------
-FRC:
- @FRC=$(FRC)
-
clean :
rm -f *.o
-.f.o : ; $(F77) -c $(F77FLAGS) $*.f
+.f.o : ; $(FC) -c $(FCFLAGS) $*.f
diff --git a/PBLAS/SRC/PBtools.h b/PBLAS/SRC/PBtools.h
index 75ff1b0..174b810 100644
--- a/PBLAS/SRC/PBtools.h
+++ b/PBLAS/SRC/PBtools.h
@@ -107,15 +107,31 @@
* DNROC computes maximum number of local rows or columns. This macro is
* only used to compute the time estimates in the Level 3 PBLAS routines.
*/
+
#define DNROC( n_, nb_, p_ ) \
((double)(((((n_)+(nb_)-1)/(nb_))+(p_)-1)/(p_))*(double)((nb_)))
-
/*
* Mptr returns a pointer to a_( i_, j_ ) for readability reasons and
* also less silly errors ...
+*
+* There was some problems with the previous code which read:
+*
+* #define Mptr( a_, i_, j_, lda_, siz_ ) \
+* ( (a_) + ( ( (i_)+(j_)*(lda_) )*(siz_) ) )
+*
+* since it can overflow the 32-bit integer "easily".
+* The following code should fix the problem.
+* It uses the "off_t" command.
+*
+* Change made by Julien Langou on Sat. September 12, 2009.
+* Fix provided by John Moyard from CNES.
+*
+* JL :April 2011: Change off_t by long long
+* off_t is not supported under Windows
*/
#define Mptr( a_, i_, j_, lda_, siz_ ) \
- ( (a_) + ( ( (i_)+(j_)*(lda_) )*(siz_) ) )
+ ( (a_) + ( (long long) ( (long long)(i_)+ \
+ (long long)(j_)*(long long)(lda_))*(long long)(siz_) ) )
/*
* Mfirstnb and Mlastnb compute the global size of the first and last
* block corresponding to the interval i_:i_+n_-1 of global indexes.
diff --git a/PBLAS/SRC/PTOOLS/CMakeLists.txt b/PBLAS/SRC/PTOOLS/CMakeLists.txt
new file mode 100644
index 0000000..a66ee45
--- /dev/null
+++ b/PBLAS/SRC/PTOOLS/CMakeLists.txt
@@ -0,0 +1,36 @@
+set( ALLCTOOLS
+ PB_CGatherV.c PB_CInV.c PB_CInV2.c PB_CInOutV.c
+ PB_CInOutV2.c PB_COutV.c PB_CScatterV.c PB_CVMinit.c
+ PB_CVMloc.c PB_CVMnpq.c PB_CVMpack.c PB_CVMswp.c
+ PB_CVMupdate.c PB_CVMcontig.c PB_Cabort.c PB_Cainfog2l.c
+ PB_Cbinfo.c PB_Cchkmat.c PB_Cchkvec.c PB_Cconjg.c
+ PB_Cgetbuf.c PB_Cinfog2l.c PB_Citypeset.c PB_Cgcd.c
+ PB_Clcm.c PB_Cmalloc.c PB_Cnumroc.c PB_Cg2lrem.c
+ PB_Cindxg2p.c PB_Cnnxtroc.c PB_Cnpreroc.c PB_CpswapNN.c
+ PB_CpswapND.c PB_Cpdot11.c PB_CpdotNN.c PB_CpdotND.c
+ PB_CpaxpbyNN.c PB_CpaxpbyND.c PB_CpaxpbyDN.c PB_Cpaxpby.c
+ PB_CpgemmBC.c PB_CpgemmAC.c PB_CpgemmAB.c PB_Cplaprnt.c
+ PB_Cplapad.c PB_Cplapd2.c PB_Cplascal.c PB_Cplasca2.c
+ PB_Cplacnjg.c PB_Cpsym.c PB_CpsymmAB.c PB_CpsymmBC.c
+ PB_Cpsyr.c PB_CpsyrkA.c PB_CpsyrkAC.c PB_Cpsyr2.c
+ PB_Cpsyr2kA.c PB_Cpsyr2kAC.c PB_Cptrm.c PB_Cpgeadd.c
+ PB_Cptradd.c PB_Cptran.c PB_CptrmmAB.c PB_CptrmmB.c
+ PB_Cptrsm.c PB_CptrsmAB.c PB_CptrsmAB0.c PB_CptrsmAB1.c
+ PB_CptrsmB.c PB_Cptrsv.c PB_Ctop.c PB_Ctzahemv.c
+ PB_Ctzasymv.c PB_Ctzatrmv.c PB_Ctzhemm.c PB_Ctzhemv.c
+ PB_Ctzher.c PB_Ctzherk.c PB_Ctzher2.c PB_Ctzher2k.c
+ PB_Ctzsymm.c PB_Ctzsymv.c PB_Ctzsyr.c PB_Ctzsyrk.c
+ PB_Ctzsyr2.c PB_Ctzsyr2k.c PB_Ctztrmm.c PB_Ctztrmv.c
+ PB_Cwarn.c PB_freebuf_.c PB_topget_.c PB_topset_.c
+ PB_Cdescset.c PB_Cdescribe.c PB_CargFtoC.c PB_Cfirstnb.c
+ PB_Clastnb.c PB_Cspan.c)
+
+set( SCTOOLS PB_Cstypeset.c)
+
+set( DCTOOLS PB_Cdtypeset.c)
+
+set( CCTOOLS PB_Cctypeset.c)
+
+set( ZCTOOLS PB_Cztypeset.c)
+
+set(ptools ${ALLCTOOLS} ${SCTOOLS} ${DCTOOLS} ${CCTOOLS} ${ZCTOOLS})
diff --git a/PBLAS/SRC/PTOOLS/Makefile b/PBLAS/SRC/PTOOLS/Makefile
index 16dc4ef..8ebaa52 100644
--- a/PBLAS/SRC/PTOOLS/Makefile
+++ b/PBLAS/SRC/PTOOLS/Makefile
@@ -42,8 +42,6 @@ include ../../../SLmake.inc
#
# To remove the object files after the library is created, enter
# make clean
-# To force the source files to be recompiled, enter, for example,
-# make single FRC=FRC
#
############################################################################
@@ -84,23 +82,17 @@ ALLCTOOLS = \
ALLTOOLS = $(ALLCTOOLS)
-$(ALLTOOLS): $(FRC)
-
#---------------------------------------------------------------------------
# The C PBLAS tools
#---------------------------------------------------------------------------
-SCTOOLS = \
- PB_Cstypeset.o
+SCTOOLS = PB_Cstypeset.o
-DCTOOLS = \
- PB_Cdtypeset.o
+DCTOOLS = PB_Cdtypeset.o
-CCTOOLS = \
- PB_Cctypeset.o
+CCTOOLS = PB_Cctypeset.o
-ZCTOOLS = \
- PB_Cztypeset.o
+ZCTOOLS = PB_Cztypeset.o
#---------------------------------------------------------------------------
@@ -109,11 +101,6 @@ CTOOLS = $(CCTOOLS) $(SCTOOLS)
DTOOLS = $(DCTOOLS)
ZTOOLS = $(ZCTOOLS) $(DCTOOLS)
-$(STOOLS): $(FRC)
-$(CTOOLS): $(FRC)
-$(DTOOLS): $(FRC)
-$(ZTOOLS): $(FRC)
-
#---------------------------------------------------------------------------
SPTOOLS = $(ALLTOOLS) $(STOOLS)
@@ -122,26 +109,23 @@ DPTOOLS = $(ALLTOOLS) $(DTOOLS)
ZPTOOLS = $(ALLTOOLS) $(ZTOOLS)
single: $(SPTOOLS)
- $(ARCH) $(ARCHFLAGS) $(SCALAPACKLIB) $(SPTOOLS)
- $(RANLIB) $(SCALAPACKLIB)
+ $(ARCH) $(ARCHFLAGS) ../../../$(SCALAPACKLIB) $(SPTOOLS)
+ $(RANLIB) ../../../$(SCALAPACKLIB)
complex: $(CPTOOLS)
- $(ARCH) $(ARCHFLAGS) $(SCALAPACKLIB) $(CPTOOLS)
- $(RANLIB) $(SCALAPACKLIB)
+ $(ARCH) $(ARCHFLAGS) ../../../$(SCALAPACKLIB) $(CPTOOLS)
+ $(RANLIB) ../../../$(SCALAPACKLIB)
double: $(DPTOOLS)
- $(ARCH) $(ARCHFLAGS) $(SCALAPACKLIB) $(DPTOOLS)
- $(RANLIB) $(SCALAPACKLIB)
+ $(ARCH) $(ARCHFLAGS) ../../../$(SCALAPACKLIB) $(DPTOOLS)
+ $(RANLIB) ../../../$(SCALAPACKLIB)
complex16: $(ZPTOOLS)
- $(ARCH) $(ARCHFLAGS) $(SCALAPACKLIB) $(ZPTOOLS)
- $(RANLIB) $(SCALAPACKLIB)
-
-FRC:
- @FRC=$(FRC)
+ $(ARCH) $(ARCHFLAGS) ../../../$(SCALAPACKLIB) $(ZPTOOLS)
+ $(RANLIB) ../../../$(SCALAPACKLIB)
clean:
rm -f *.o
-.f.o : ; $(F77) -c $(F77FLAGS) $*.f
-.c.o : ; $(CC) -c $(CCFLAGS) $(CDEFS) $*.c
+.f.o : ; $(FC) -c $(FCFLAGS) $*.f
+.c.o : ; $(CC) -c $(CDEFS) $(CCFLAGS) $*.c
diff --git a/PBLAS/SRC/PTZBLAS/CMakeLists.txt b/PBLAS/SRC/PTZBLAS/CMakeLists.txt
new file mode 100644
index 0000000..a35a557
--- /dev/null
+++ b/PBLAS/SRC/PTZBLAS/CMakeLists.txt
@@ -0,0 +1,48 @@
+set (APBTZ
+ pxerbla.f)
+
+set (IPBTZ
+ immadd.f immdda.f immtadd.f immddat.f)
+
+set (SPBTZ
+ svasum.f sset.f scshft.f srshft.f
+ svvdot.f smmadd.f smmcadd.f smmtadd.f
+ smmtcadd.f smmdda.f smmddac.f smmddat.f
+ smmddact.f stzpad.f stzpadcpy.f stzscal.f
+ sagemv.f sasymv.f satrmv.f)
+
+set (SCPBTZ
+ sasqrtb.f sascal.f)
+
+set (CPBTZ
+ scvasum.f cset.f ccshft.f crshft.f
+ cvvdotu.f cvvdotc.f cmmadd.f cmmcadd.f
+ cmmtadd.f cmmtcadd.f cmmdda.f cmmddac.f
+ cmmddat.f cmmddact.f ctzpad.f ctzpadcpy.f
+ chescal.f ctzscal.f ctzcnjg.f cagemv.f
+ cahemv.f catrmv.f casymv.f csymv.f
+ csyr.f csyr2.f)
+
+set (DPBTZ
+ dvasum.f dset.f dcshft.f drshft.f
+ dvvdot.f dmmadd.f dmmcadd.f dmmtadd.f
+ dmmtcadd.f dmmdda.f dmmddac.f dmmddat.f
+ dmmddact.f dtzpad.f dtzpadcpy.f dtzscal.f
+ dagemv.f dasymv.f datrmv.f)
+
+set (DZPBTZ
+ dasqrtb.f dascal.f)
+
+set (ZPBTZ
+ dzvasum.f zset.f zcshft.f zrshft.f
+ zvvdotu.f zvvdotc.f zmmadd.f zmmcadd.f
+ zmmtadd.f zmmtcadd.f zmmdda.f zmmddac.f
+ zmmddat.f zmmddact.f ztzpad.f ztzpadcpy.f
+ zhescal.f ztzscal.f ztzcnjg.f zagemv.f
+ zahemv.f zatrmv.f zasymv.f zsymv.f
+ zsyr.f zsyr2.f)
+
+
+set(ptzblas
+ ${APBTZ} ${IPBTZ} ${SPBTZ} ${SCPBTZ}
+ ${CPBTZ} ${DPBTZ} ${DZPBTZ} ${ZPBTZ} )
diff --git a/PBLAS/SRC/PTZBLAS/Makefile b/PBLAS/SRC/PTZBLAS/Makefile
index f0bfd92..c512d1f 100644
--- a/PBLAS/SRC/PTZBLAS/Makefile
+++ b/PBLAS/SRC/PTZBLAS/Makefile
@@ -45,8 +45,6 @@ include ../../../SLmake.inc
#
# To remove the object files after the library is created, enter
# make clean
-# To force the source files to be recompiled, enter, for example,
-# make single FRC=FRC
#
############################################################################
@@ -98,44 +96,26 @@ ZPBTZ = \
#---------------------------------------------------------------------------
-$(APBTZ): $(FRC)
-$(IPBTZ): $(FRC)
-$(SPBTZ): $(FRC)
-$(SCPBTZ): $(FRC)
-$(CPBTZ): $(FRC)
-$(DPBTZ): $(FRC)
-$(DZPBTZ): $(FRC)
-$(ZPBTZ): $(FRC)
-
-#---------------------------------------------------------------------------
-
single: $(APBTZ) $(IPBTZ) $(SPBTZ) $(SCPBTZ)
- $(ARCH) $(ARCHFLAGS) $(SCALAPACKLIB) $(APBTZ) $(IPBTZ) $(SPBTZ) \
- $(SCPBTZ)
- $(RANLIB) $(SCALAPACKLIB)
+ $(ARCH) $(ARCHFLAGS) ../../../$(SCALAPACKLIB) $(APBTZ) $(IPBTZ) $(SPBTZ) $(SCPBTZ)
+ $(RANLIB) ../../../$(SCALAPACKLIB)
complex: $(APBTZ) $(IPBTZ) $(CPBTZ) $(SCPBTZ)
- $(ARCH) $(ARCHFLAGS) $(SCALAPACKLIB) $(APBTZ) $(IPBTZ) $(CPBTZ) \
- $(SCPBTZ)
- $(RANLIB) $(SCALAPACKLIB)
+ $(ARCH) $(ARCHFLAGS) ../../../$(SCALAPACKLIB) $(APBTZ) $(IPBTZ) $(CPBTZ) $(SCPBTZ)
+ $(RANLIB) ../../../$(SCALAPACKLIB)
double: $(APBTZ) $(IPBTZ) $(DPBTZ) $(DZPBTZ)
- $(ARCH) $(ARCHFLAGS) $(SCALAPACKLIB) $(APBTZ) $(IPBTZ) $(DPBTZ) \
- $(DZPBTZ)
- $(RANLIB) $(SCALAPACKLIB)
+ $(ARCH) $(ARCHFLAGS) ../../../$(SCALAPACKLIB) $(APBTZ) $(IPBTZ) $(DPBTZ) $(DZPBTZ)
+ $(RANLIB) ../../../$(SCALAPACKLIB)
complex16: $(APBTZ) $(IPBTZ) $(ZPBTZ) $(DZPBTZ)
- $(ARCH) $(ARCHFLAGS) $(SCALAPACKLIB) $(APBTZ) $(IPBTZ) $(ZPBTZ) \
- $(DZPBTZ)
- $(RANLIB) $(SCALAPACKLIB)
+ $(ARCH) $(ARCHFLAGS) ../../../$(SCALAPACKLIB) $(APBTZ) $(IPBTZ) $(ZPBTZ) $(DZPBTZ)
+ $(RANLIB) ../../../$(SCALAPACKLIB)
#---------------------------------------------------------------------------
-FRC:
- @FRC=$(FRC)
-
clean:
rm -f *.o
-.f.o : ; $(F77) -c $(F77FLAGS) $*.f
-.c.o : ; $(CC) -c $(CCFLAGS) $(CDEFS) $*.c
+.f.o : ; $(FC) -c $(FCFLAGS) $*.f
+.c.o : ; $(CC) -c $(CDEFS) $(CCFLAGS) $*.c
diff --git a/PBLAS/SRC/PTZBLAS/csyr.f b/PBLAS/SRC/PTZBLAS/csyr.f
index b777424..1e19713 100644
--- a/PBLAS/SRC/PTZBLAS/csyr.f
+++ b/PBLAS/SRC/PTZBLAS/csyr.f
@@ -116,6 +116,7 @@
*
* Set the start point in X if the increment is not unity.
*
+ KX = 1
IF( INCX.LE.0 ) THEN
KX = 1 - ( N-1 )*INCX
ELSE IF( INCX.NE.1 ) THEN
diff --git a/PBLAS/SRC/PTZBLAS/csyr2.f b/PBLAS/SRC/PTZBLAS/csyr2.f
index d5343b2..d8cc332 100644
--- a/PBLAS/SRC/PTZBLAS/csyr2.f
+++ b/PBLAS/SRC/PTZBLAS/csyr2.f
@@ -131,6 +131,10 @@
* Set up the start points in X and Y if the increments are not both
* unity.
*
+ KX = 1
+ KY = 1
+ JX = 1
+ JY = 1
IF( ( INCX.NE.1 ).OR.( INCY.NE.1 ) )THEN
IF( INCX.GT.0 )THEN
KX = 1
diff --git a/PBLAS/SRC/PTZBLAS/zsyr.f b/PBLAS/SRC/PTZBLAS/zsyr.f
index 942dd2d..c0429e5 100644
--- a/PBLAS/SRC/PTZBLAS/zsyr.f
+++ b/PBLAS/SRC/PTZBLAS/zsyr.f
@@ -116,6 +116,7 @@
*
* Set the start point in X if the increment is not unity.
*
+ KX = 1
IF( INCX.LE.0 ) THEN
KX = 1 - ( N-1 )*INCX
ELSE IF( INCX.NE.1 ) THEN
diff --git a/PBLAS/SRC/PTZBLAS/zsyr2.f b/PBLAS/SRC/PTZBLAS/zsyr2.f
index 18a9284..7af6c20 100644
--- a/PBLAS/SRC/PTZBLAS/zsyr2.f
+++ b/PBLAS/SRC/PTZBLAS/zsyr2.f
@@ -131,6 +131,10 @@
* Set up the start points in X and Y if the increments are not both
* unity.
*
+ KX = 1
+ KY = 1
+ JX = 1
+ JY = 1
IF( ( INCX.NE.1 ).OR.( INCY.NE.1 ) )THEN
IF( INCX.GT.0 )THEN
KX = 1
diff --git a/PBLAS/SRC/pctrsm_.c b/PBLAS/SRC/pctrsm_.c
index a5b49fb..f31b04c 100644
--- a/PBLAS/SRC/pctrsm_.c
+++ b/PBLAS/SRC/pctrsm_.c
@@ -408,6 +408,15 @@ void pctrsm_( SIDE, UPLO, TRANS, DIAG, M, N, ALPHA,
}
}
+/*
+* Var can remain uninitialized but is nevertheless used in PB_CptrsmAB.c
+* provide a default here. TODO: does this make sense ?
+*==19891== at 0x44F81B: PB_CptrsmAB (PB_CptrsmAB.c:538)
+*==19891== by 0x427BE7: pdtrsm_ (pdtrsm_.c:488)
+*==19891== by 0x405E46: MAIN_ (pdblas3tim.f:727)
+*/
+ Var = CRIGHT;
+
if( ChooseAB )
{
/*
diff --git a/PBLAS/SRC/pdtrsm_.c b/PBLAS/SRC/pdtrsm_.c
index 180d0d5..fbd7a44 100644
--- a/PBLAS/SRC/pdtrsm_.c
+++ b/PBLAS/SRC/pdtrsm_.c
@@ -408,6 +408,15 @@ void pdtrsm_( SIDE, UPLO, TRANS, DIAG, M, N, ALPHA,
}
}
+/*
+* Var can remain uninitialized but is nevertheless used in PB_CptrsmAB.c
+* provide a default here. TODO: does this make sense ?
+*==19891== at 0x44F81B: PB_CptrsmAB (PB_CptrsmAB.c:538)
+*==19891== by 0x427BE7: pdtrsm_ (pdtrsm_.c:488)
+*==19891== by 0x405E46: MAIN_ (pdblas3tim.f:727)
+*/
+ Var = CRIGHT;
+
if( ChooseAB )
{
/*
diff --git a/PBLAS/SRC/pstrsm_.c b/PBLAS/SRC/pstrsm_.c
index b5f991b..70ad9b9 100644
--- a/PBLAS/SRC/pstrsm_.c
+++ b/PBLAS/SRC/pstrsm_.c
@@ -408,6 +408,16 @@ void pstrsm_( SIDE, UPLO, TRANS, DIAG, M, N, ALPHA,
}
}
+/*
+* Var can remain uninitialized but is nevertheless used in PB_CptrsmAB.c
+* provide a default here. TODO: does this make sense ?
+*==19891== at 0x44F81B: PB_CptrsmAB (PB_CptrsmAB.c:538)
+*==19891== by 0x427BE7: pdtrsm_ (pdtrsm_.c:488)
+*==19891== by 0x405E46: MAIN_ (pdblas3tim.f:727)
+*/
+ Var = CRIGHT;
+
+
if( ChooseAB )
{
/*
diff --git a/PBLAS/SRC/pztrsm_.c b/PBLAS/SRC/pztrsm_.c
index 424f7f2..03b1153 100644
--- a/PBLAS/SRC/pztrsm_.c
+++ b/PBLAS/SRC/pztrsm_.c
@@ -408,6 +408,16 @@ void pztrsm_( SIDE, UPLO, TRANS, DIAG, M, N, ALPHA,
}
}
+/*
+* Var can remain uninitialized but is nevertheless used in PB_CptrsmAB.c
+* provide a default here. TODO: does this make sense ?
+*==19891== at 0x44F81B: PB_CptrsmAB (PB_CptrsmAB.c:538)
+*==19891== by 0x427BE7: pdtrsm_ (pdtrsm_.c:488)
+*==19891== by 0x405E46: MAIN_ (pdblas3tim.f:727)
+*/
+ Var = CRIGHT;
+
+
if( ChooseAB )
{
/*
diff --git a/PBLAS/TESTING/CMakeLists.txt b/PBLAS/TESTING/CMakeLists.txt
new file mode 100644
index 0000000..e60f5e4
--- /dev/null
+++ b/PBLAS/TESTING/CMakeLists.txt
@@ -0,0 +1,78 @@
+file(COPY ../SRC/PTOOLS/PB_Cwarn.c DESTINATION ${CMAKE_CURRENT_SOURCE_DIR})
+file(COPY ../SRC/PTOOLS/PB_Cabort.c DESTINATION ${CMAKE_CURRENT_SOURCE_DIR})
+
+set (PblasErrorHandler PB_Cwarn.c PB_Cabort.c)
+set (pbtcom pblastst.f ${PblasErrorHandler})
+set (spbtcom psblastst.f slamch.f ${pbtcom})
+set (dpbtcom pdblastst.f dlamch.f ${pbtcom})
+set (cpbtcom pcblastst.f slamch.f ${pbtcom})
+set (zpbtcom pzblastst.f dlamch.f ${pbtcom})
+
+set_property(
+ SOURCE ${PblasErrorHandler}
+ APPEND PROPERTY COMPILE_DEFINITIONS TestingPblas
+ )
+
+set(CMAKE_RUNTIME_OUTPUT_DIRECTORY ${SCALAPACK_BINARY_DIR}/PBLAS/TESTING)
+
+file(COPY PCBLAS1TST.dat DESTINATION ${CMAKE_RUNTIME_OUTPUT_DIRECTORY})
+file(COPY PCBLAS2TST.dat DESTINATION ${CMAKE_RUNTIME_OUTPUT_DIRECTORY})
+file(COPY PCBLAS3TST.dat DESTINATION ${CMAKE_RUNTIME_OUTPUT_DIRECTORY})
+file(COPY PDBLAS1TST.dat DESTINATION ${CMAKE_RUNTIME_OUTPUT_DIRECTORY})
+file(COPY PDBLAS2TST.dat DESTINATION ${CMAKE_RUNTIME_OUTPUT_DIRECTORY})
+file(COPY PDBLAS3TST.dat DESTINATION ${CMAKE_RUNTIME_OUTPUT_DIRECTORY})
+file(COPY PSBLAS1TST.dat DESTINATION ${CMAKE_RUNTIME_OUTPUT_DIRECTORY})
+file(COPY PSBLAS2TST.dat DESTINATION ${CMAKE_RUNTIME_OUTPUT_DIRECTORY})
+file(COPY PSBLAS3TST.dat DESTINATION ${CMAKE_RUNTIME_OUTPUT_DIRECTORY})
+file(COPY PZBLAS1TST.dat DESTINATION ${CMAKE_RUNTIME_OUTPUT_DIRECTORY})
+file(COPY PZBLAS2TST.dat DESTINATION ${CMAKE_RUNTIME_OUTPUT_DIRECTORY})
+file(COPY PZBLAS3TST.dat DESTINATION ${CMAKE_RUNTIME_OUTPUT_DIRECTORY})
+
+
+add_executable(spb1tst psblas1tst.f ${spbtcom})
+add_executable(dpb1tst pdblas1tst.f ${dpbtcom})
+add_executable(cpb1tst pcblas1tst.f ${cpbtcom})
+add_executable(zpb1tst pzblas1tst.f ${zpbtcom})
+
+add_executable(spb2tst psblas2tst.f ${spbtcom})
+add_executable(dpb2tst pdblas2tst.f ${dpbtcom})
+add_executable(cpb2tst pcblas2tst.f ${cpbtcom})
+add_executable(zpb2tst pzblas2tst.f ${zpbtcom})
+
+add_executable(spb3tst psblas3tst.f ${spbtcom})
+add_executable(dpb3tst pdblas3tst.f ${dpbtcom})
+add_executable(cpb3tst pcblas3tst.f ${cpbtcom})
+add_executable(zpb3tst pzblas3tst.f ${zpbtcom})
+
+target_link_libraries(spb1tst scalapack ${LAPACK_LIBRARIES} ${BLAS_LIBRARIES})
+target_link_libraries(dpb1tst scalapack ${LAPACK_LIBRARIES} ${BLAS_LIBRARIES})
+target_link_libraries(cpb1tst scalapack ${LAPACK_LIBRARIES} ${BLAS_LIBRARIES})
+target_link_libraries(zpb1tst scalapack ${LAPACK_LIBRARIES} ${BLAS_LIBRARIES})
+
+target_link_libraries(spb2tst scalapack ${LAPACK_LIBRARIES} ${BLAS_LIBRARIES})
+target_link_libraries(dpb2tst scalapack ${LAPACK_LIBRARIES} ${BLAS_LIBRARIES})
+target_link_libraries(cpb2tst scalapack ${LAPACK_LIBRARIES} ${BLAS_LIBRARIES})
+target_link_libraries(zpb2tst scalapack ${LAPACK_LIBRARIES} ${BLAS_LIBRARIES})
+
+target_link_libraries(spb3tst scalapack ${LAPACK_LIBRARIES} ${BLAS_LIBRARIES})
+target_link_libraries(dpb3tst scalapack ${LAPACK_LIBRARIES} ${BLAS_LIBRARIES})
+target_link_libraries(cpb3tst scalapack ${LAPACK_LIBRARIES} ${BLAS_LIBRARIES})
+target_link_libraries(zpb3tst scalapack ${LAPACK_LIBRARIES} ${BLAS_LIBRARIES})
+
+add_test(spb1tst ${MPIEXEC} ${MPIEXEC_NUMPROC_FLAG} 4 ./spb1tst)
+add_test(dpb1tst ${MPIEXEC} ${MPIEXEC_NUMPROC_FLAG} 4 ./dpb1tst)
+add_test(cpb1tst ${MPIEXEC} ${MPIEXEC_NUMPROC_FLAG} 4 ./cpb1tst)
+add_test(zpb1tst ${MPIEXEC} ${MPIEXEC_NUMPROC_FLAG} 4 ./zpb1tst)
+
+add_test(spb2tst ${MPIEXEC} ${MPIEXEC_NUMPROC_FLAG} 4 ./spb2tst)
+add_test(dpb2tst ${MPIEXEC} ${MPIEXEC_NUMPROC_FLAG} 4 ./dpb2tst)
+add_test(cpb2tst ${MPIEXEC} ${MPIEXEC_NUMPROC_FLAG} 4 ./cpb2tst)
+add_test(zpb2tst ${MPIEXEC} ${MPIEXEC_NUMPROC_FLAG} 4 ./zpb2tst)
+
+add_test(spb3tst ${MPIEXEC} ${MPIEXEC_NUMPROC_FLAG} 4 ./spb3tst)
+add_test(dpb3tst ${MPIEXEC} ${MPIEXEC_NUMPROC_FLAG} 4 ./dpb3tst)
+add_test(cpb3tst ${MPIEXEC} ${MPIEXEC_NUMPROC_FLAG} 4 ./cpb3tst)
+add_test(zpb3tst ${MPIEXEC} ${MPIEXEC_NUMPROC_FLAG} 4 ./zpb3tst)
+
+
+
diff --git a/PBLAS/TESTING/Makefile b/PBLAS/TESTING/Makefile
index 1aaa7eb..71373c4 100644
--- a/PBLAS/TESTING/Makefile
+++ b/PBLAS/TESTING/Makefile
@@ -31,20 +31,20 @@ dPBLAS3exe = xdpblas3tst
cPBLAS3exe = xcpblas3tst
zPBLAS3exe = xzpblas3tst
-spb1tst = $(PBLASTSTdir)/$(sPBLAS1exe)
-dpb1tst = $(PBLASTSTdir)/$(dPBLAS1exe)
-cpb1tst = $(PBLASTSTdir)/$(cPBLAS1exe)
-zpb1tst = $(PBLASTSTdir)/$(zPBLAS1exe)
+spb1tst = $(sPBLAS1exe)
+dpb1tst = $(dPBLAS1exe)
+cpb1tst = $(cPBLAS1exe)
+zpb1tst = $(zPBLAS1exe)
-spb2tst = $(PBLASTSTdir)/$(sPBLAS2exe)
-dpb2tst = $(PBLASTSTdir)/$(dPBLAS2exe)
-cpb2tst = $(PBLASTSTdir)/$(cPBLAS2exe)
-zpb2tst = $(PBLASTSTdir)/$(zPBLAS2exe)
+spb2tst = $(sPBLAS2exe)
+dpb2tst = $(dPBLAS2exe)
+cpb2tst = $(cPBLAS2exe)
+zpb2tst = $(zPBLAS2exe)
-spb3tst = $(PBLASTSTdir)/$(sPBLAS3exe)
-dpb3tst = $(PBLASTSTdir)/$(dPBLAS3exe)
-cpb3tst = $(PBLASTSTdir)/$(cPBLAS3exe)
-zpb3tst = $(PBLASTSTdir)/$(zPBLAS3exe)
+spb3tst = $(sPBLAS3exe)
+dpb3tst = $(dPBLAS3exe)
+cpb3tst = $(cPBLAS3exe)
+zpb3tst = $(zPBLAS3exe)
pbtcom = pblastst.o PB_Cwarn.o PB_Cabort.o
@@ -78,107 +78,59 @@ complex: PblasErrorHandler $(cpb1tst) $(cpb2tst) $(cpb3tst)
complex16: PblasErrorHandler $(zpb1tst) $(zpb2tst) $(zpb3tst)
-PblasErrorHandler:
- rm -f PB_Cwarn.c PB_Cwarn.o
- ln -s $(PBLASdir)/SRC/PTOOLS/PB_Cwarn.c PB_Cwarn.c
- $(CC) -c $(CCFLAGS) $(CDEFS) -DTestingPblas PB_Cwarn.c
- rm -f PB_Cabort.c PB_Cabort.o
- ln -s $(PBLASdir)/SRC/PTOOLS/PB_Cabort.c PB_Cabort.c
- $(CC) -c $(CCFLAGS) $(CDEFS) -DTestingPblas PB_Cabort.c
-
-$(PBLASTSTdir)/PSBLAS1TST.dat: PSBLAS1TST.dat
- cp PSBLAS1TST.dat $(PBLASTSTdir)
-$(PBLASTSTdir)/PDBLAS1TST.dat: PDBLAS1TST.dat
- cp PDBLAS1TST.dat $(PBLASTSTdir)
-$(PBLASTSTdir)/PCBLAS1TST.dat: PCBLAS1TST.dat
- cp PCBLAS1TST.dat $(PBLASTSTdir)
-$(PBLASTSTdir)/PZBLAS1TST.dat: PZBLAS1TST.dat
- cp PZBLAS1TST.dat $(PBLASTSTdir)
-
-$(spb1tst) : $(SCALAPACKLIB) $(spb1t)
- $(F77LOADER) $(F77LOADFLAGS) -o $(spb1tst) $(spb1t) $(LIBS)
- $(MAKE) $(PBLASTSTdir)/PSBLAS1TST.dat
-$(dpb1tst) : $(SCALAPACKLIB) $(dpb1t)
- $(F77LOADER) $(F77LOADFLAGS) -o $(dpb1tst) $(dpb1t) $(LIBS)
- $(MAKE) $(PBLASTSTdir)/PDBLAS1TST.dat
-$(cpb1tst) : $(SCALAPACKLIB) $(cpb1t)
- $(F77LOADER) $(F77LOADFLAGS) -o $(cpb1tst) $(cpb1t) $(LIBS)
- $(MAKE) $(PBLASTSTdir)/PCBLAS1TST.dat
-$(zpb1tst) : $(SCALAPACKLIB) $(zpb1t)
- $(F77LOADER) $(F77LOADFLAGS) -o $(zpb1tst) $(zpb1t) $(LIBS)
- $(MAKE) $(PBLASTSTdir)/PZBLAS1TST.dat
-
-$(PBLASTSTdir)/PSBLAS2TST.dat: PSBLAS2TST.dat
- cp PSBLAS2TST.dat $(PBLASTSTdir)
-$(PBLASTSTdir)/PDBLAS2TST.dat: PDBLAS2TST.dat
- cp PDBLAS2TST.dat $(PBLASTSTdir)
-$(PBLASTSTdir)/PCBLAS2TST.dat: PCBLAS2TST.dat
- cp PCBLAS2TST.dat $(PBLASTSTdir)
-$(PBLASTSTdir)/PZBLAS2TST.dat: PZBLAS2TST.dat
- cp PZBLAS2TST.dat $(PBLASTSTdir)
-
-$(spb2tst) : $(SCALAPACKLIB) $(spb2t)
- $(F77LOADER) $(F77LOADFLAGS) -o $(spb2tst) $(spb2t) $(LIBS)
- $(MAKE) $(PBLASTSTdir)/PSBLAS2TST.dat
-$(dpb2tst) : $(SCALAPACKLIB) $(dpb2t)
- $(F77LOADER) $(F77LOADFLAGS) -o $(dpb2tst) $(dpb2t) $(LIBS)
- $(MAKE) $(PBLASTSTdir)/PDBLAS2TST.dat
-$(cpb2tst) : $(SCALAPACKLIB) $(cpb2t)
- $(F77LOADER) $(F77LOADFLAGS) -o $(cpb2tst) $(cpb2t) $(LIBS)
- $(MAKE) $(PBLASTSTdir)/PCBLAS2TST.dat
-$(zpb2tst) : $(SCALAPACKLIB) $(zpb2t)
- $(F77LOADER) $(F77LOADFLAGS) -o $(zpb2tst) $(zpb2t) $(LIBS)
- $(MAKE) $(PBLASTSTdir)/PZBLAS2TST.dat
-
-$(PBLASTSTdir)/PSBLAS3TST.dat: PSBLAS3TST.dat
- cp PSBLAS3TST.dat $(PBLASTSTdir)
-$(PBLASTSTdir)/PDBLAS3TST.dat: PDBLAS3TST.dat
- cp PDBLAS3TST.dat $(PBLASTSTdir)
-$(PBLASTSTdir)/PCBLAS3TST.dat: PCBLAS3TST.dat
- cp PCBLAS3TST.dat $(PBLASTSTdir)
-$(PBLASTSTdir)/PZBLAS3TST.dat: PZBLAS3TST.dat
- cp PZBLAS3TST.dat $(PBLASTSTdir)
-
-$(spb3tst) : $(SCALAPACKLIB) $(spb3t)
- $(F77LOADER) $(F77LOADFLAGS) -o $(spb3tst) $(spb3t) $(LIBS)
- $(MAKE) $(PBLASTSTdir)/PSBLAS3TST.dat
-$(dpb3tst) : $(SCALAPACKLIB) $(dpb3t)
- $(F77LOADER) $(F77LOADFLAGS) -o $(dpb3tst) $(dpb3t) $(LIBS)
- $(MAKE) $(PBLASTSTdir)/PDBLAS3TST.dat
-$(cpb3tst) : $(SCALAPACKLIB) $(cpb3t)
- $(F77LOADER) $(F77LOADFLAGS) -o $(cpb3tst) $(cpb3t) $(LIBS)
- $(MAKE) $(PBLASTSTdir)/PCBLAS3TST.dat
-$(zpb3tst) : $(SCALAPACKLIB) $(zpb3t)
- $(F77LOADER) $(F77LOADFLAGS) -o $(zpb3tst) $(zpb3t) $(LIBS)
- $(MAKE) $(PBLASTSTdir)/PZBLAS3TST.dat
-
-$(spb1t): $(FRC)
-$(dpb1t): $(FRC)
-$(cpb1t): $(FRC)
-$(zpb1t): $(FRC)
-
-$(spb2t): $(FRC)
-$(dpb2t): $(FRC)
-$(cpb2t): $(FRC)
-$(zpb2t): $(FRC)
-
-$(spb3t): $(FRC)
-$(dpb3t): $(FRC)
-$(cpb3t): $(FRC)
-$(zpb3t): $(FRC)
-
-FRC:
- @FRC=$(FRC)
+PB_Cwarn.o:
+ $(CC) -c $(CDEFS) $(CCFLAGS) -I../SRC -o PB_Cwarn.o -DTestingPblas ../SRC/PTOOLS/PB_Cwarn.c
+
+PB_Cabort.o:
+ $(CC) -c $(CDEFS) $(CCFLAGS) -I../SRC -o PB_Cabort.o -DTestingPblas ../SRC/PTOOLS/PB_Cabort.c
+
+PblasErrorHandler: PB_Cwarn.o PB_Cwarn.o
+
+$(spb1tst) : ../../$(SCALAPACKLIB) $(spb1t)
+ $(FCLOADER) $(FCLOADFLAGS) -o $(spb1tst) $(spb1t) ../../$(SCALAPACKLIB) $(LIBS)
+
+$(dpb1tst) : ../../$(SCALAPACKLIB) $(dpb1t)
+ $(FCLOADER) $(FCLOADFLAGS) -o $(dpb1tst) $(dpb1t) ../../$(SCALAPACKLIB) $(LIBS)
+
+$(cpb1tst) : ../../$(SCALAPACKLIB) $(cpb1t)
+ $(FCLOADER) $(FCLOADFLAGS) -o $(cpb1tst) $(cpb1t) ../../$(SCALAPACKLIB) $(LIBS)
+
+$(zpb1tst) : ../../$(SCALAPACKLIB) $(zpb1t)
+ $(FCLOADER) $(FCLOADFLAGS) -o $(zpb1tst) $(zpb1t) ../../$(SCALAPACKLIB) $(LIBS)
+
+$(spb2tst) : ../../$(SCALAPACKLIB) $(spb2t)
+ $(FCLOADER) $(FCLOADFLAGS) -o $(spb2tst) $(spb2t) ../../$(SCALAPACKLIB) $(LIBS)
+
+$(dpb2tst) : ../../$(SCALAPACKLIB) $(dpb2t)
+ $(FCLOADER) $(FCLOADFLAGS) -o $(dpb2tst) $(dpb2t) ../../$(SCALAPACKLIB) $(LIBS)
+
+$(cpb2tst) : ../../$(SCALAPACKLIB) $(cpb2t)
+ $(FCLOADER) $(FCLOADFLAGS) -o $(cpb2tst) $(cpb2t) ../../$(SCALAPACKLIB) $(LIBS)
+
+$(zpb2tst) : ../../$(SCALAPACKLIB) $(zpb2t)
+ $(FCLOADER) $(FCLOADFLAGS) -o $(zpb2tst) $(zpb2t) ../../$(SCALAPACKLIB) $(LIBS)
+
+$(spb3tst) : ../../$(SCALAPACKLIB) $(spb3t)
+ $(FCLOADER) $(FCLOADFLAGS) -o $(spb3tst) $(spb3t) ../../$(SCALAPACKLIB) $(LIBS)
+
+$(dpb3tst) : ../../$(SCALAPACKLIB) $(dpb3t)
+ $(FCLOADER) $(FCLOADFLAGS) -o $(dpb3tst) $(dpb3t) ../../$(SCALAPACKLIB) $(LIBS)
+
+$(cpb3tst) : ../../$(SCALAPACKLIB) $(cpb3t)
+ $(FCLOADER) $(FCLOADFLAGS) -o $(cpb3tst) $(cpb3t) ../../$(SCALAPACKLIB) $(LIBS)
+
+$(zpb3tst) : ../../$(SCALAPACKLIB) $(zpb3t)
+ $(FCLOADER) $(FCLOADFLAGS) -o $(zpb3tst) $(zpb3t) ../../$(SCALAPACKLIB) $(LIBS)
clean :
- rm -f *.o
+ rm -f *.o x*
slamch.o:
- $(F77) -c $(NOOPT) slamch.f
+ $(FC) -c $(NOOPT) slamch.f
dlamch.o:
- $(F77) -c $(NOOPT) dlamch.f
+ $(FC) -c $(NOOPT) dlamch.f
-.f.o : ; $(F77) -c $(F77FLAGS) $*.f
+.f.o : ; $(FC) -c $(FCFLAGS) $*.f
-# .c.o : ; $(CC) -c $(CCFLAGS) $(CDEFS) -DTestingPblas $*.c
+.c.o : ; $(CC) -c $(CDEFS) $(CCFLAGS) -DTestingPblas $*.c
diff --git a/PBLAS/TESTING/PB_Cabort.c b/PBLAS/TESTING/PB_Cabort.c
deleted file mode 100644
index d97bca0..0000000
--- a/PBLAS/TESTING/PB_Cabort.c
+++ /dev/null
@@ -1,158 +0,0 @@
-/* ---------------------------------------------------------------------
-*
-* -- PBLAS auxiliary routine (version 2.0) --
-* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
-* and University of California, Berkeley.
-* April 1, 1998
-*
-* ---------------------------------------------------------------------
-*/
-/*
-* Include files
-*/
-#ifdef TestingPblas
-#include "../SRC/pblas.h"
-#include "../SRC/PBpblas.h"
-#include "../SRC/PBtools.h"
-#include "../SRC/PBblacs.h"
-#include "../SRC/PBblas.h"
-#else
-#include "../pblas.h"
-#include "../PBpblas.h"
-#include "../PBtools.h"
-#include "../PBblacs.h"
-#include "../PBblas.h"
-#endif
-
-/*
-* ---------------------------------------------------------------------
-* FORTRAN <-> C interface
-* ---------------------------------------------------------------------
-*
-* These macros identifies how the PBLAS will be called as follows:
-*
-* _F2C_ADD_: the FORTRAN compiler expects the name of C functions to be
-* in all lower case and to have an underscore postfixed it (Suns, Intel
-* compilers expect this).
-*
-* _F2C_NOCHANGE: the FORTRAN compiler expects the name of C functions
-* to be in all lower case (IBM RS6K compilers do this).
-*
-* _F2C_UPCASE: the FORTRAN compiler expects the name of C functions
-* to be in all upcase. (Cray compilers expect this).
-*
-* _F2C_F77ISF2C: the FORTRAN compiler in use is f2c, a FORTRAN to C
-* converter.
-*/
-#if (_F2C_CALL_ == _F2C_ADD_ )
-#define PB_NoAbort pb_noabort_
-#endif
-#if (_F2C_CALL_ == _F2C_UPCASE )
-#define PB_NoAbort PB_NOABORT
-#endif
-#if (_F2C_CALL_ == _F2C_NOCHANGE )
-#define PB_NoAbort pb_noabort
-#endif
-#if (_F2C_CALL_ == _F2C_F77ISF2C )
-#define PB_NoAbort pb_noabort__
-#endif
-
-#ifdef __STDC__
-void PB_Cabort( int ICTXT, char * ROUT, int INFO )
-#else
-void PB_Cabort( ICTXT, ROUT, INFO )
-/*
-* .. Scalar Arguments ..
-*/
- int ICTXT, INFO;
-/*
-* .. Array Arguments ..
-*/
- char * ROUT;
-#endif
-{
-/*
-* Purpose
-* =======
-*
-* PB_Cabort is an error handler for the PBLAS routines. This routine
-* displays an error message on stderr by calling PB_Cwarn, and halts
-* execution by calling Cblacs_abort().
-*
-* Arguments
-* =========
-*
-* ICTXT (local input) INTEGER
-* On entry, ICTXT specifies the BLACS context handle, indica-
-* ting the global context of the operation. The context itself
-* is global, but the value of ICTXT is local.
-*
-* ROUT (global input) pointer to CHAR
-* On entry, ROUT specifies the name of the routine calling this
-* error handler.
-*
-* INFO (local input) INTEGER
-* The error code computed by the calling PBLAS routine.
-* = 0: no error found
-* < 0: If the i-th argument is an array and the j-entry had
-* an illegal value, then INFO = -(i*100+j), if the i-th
-* argument is a scalar and had an illegal value, then
-* INFO = -i.
-*
-* -- Written on April 1, 1998 by
-* R. Clint Whaley, University of Tennessee, Knoxville 37996, USA.
-*
-* ---------------------------------------------------------------------
-*/
-/*
-* .. Local Scalars ..
-*/
- int mycol, myrow, npcol, nprow;
-/* ..
-* .. External Functions ..
-*/
-#ifdef TestingPblas
-#ifdef __STDC__
- int PB_NoAbort( int * );
-#else
- int PB_NoAbort();
-#endif
-#endif
-/* ..
-* .. Executable Statements ..
-*
-*/
- Cblacs_gridinfo( ICTXT, &nprow, &npcol, &myrow, &mycol );
-#ifdef TestingPblas
-/*
-* For testing purpose only, the error is reported, but the program execution
-* is not terminated
-*/
- if( PB_NoAbort( &INFO ) ) return;
-#endif
- if( INFO < 0 )
- {
-/*
-* Display an error message
-*/
- if( INFO < DESCMULT )
- PB_Cwarn( ICTXT, -1, ROUT,
- "Parameter number %d had an illegal value", -INFO );
- else
- PB_Cwarn( ICTXT, -1, ROUT,
- "Parameter number %d, entry number %d had an illegal value",
- (-INFO) / DESCMULT, (-INFO) % DESCMULT );
- }
- else
- {
-/*
-* Error code is incorrect, it should be negative
-*/
- PB_Cwarn( ICTXT, -1, ROUT,
- "Positive error code %d returned by %s!!!", INFO );
- }
- Cblacs_abort( ICTXT, INFO );
-/*
-* End of PB_Cabort
-*/
-}
diff --git a/PBLAS/TESTING/PB_Cwarn.c b/PBLAS/TESTING/PB_Cwarn.c
deleted file mode 100644
index 6f6ca18..0000000
--- a/PBLAS/TESTING/PB_Cwarn.c
+++ /dev/null
@@ -1,164 +0,0 @@
-/* ---------------------------------------------------------------------
-*
-* -- PBLAS auxiliary routine (version 2.0) --
-* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
-* and University of California, Berkeley.
-* April 1, 1998
-*
-* ---------------------------------------------------------------------
-*/
-/*
-* Include files
-*/
-#ifdef TestingPblas
-#include "../SRC/pblas.h"
-#include "../SRC/PBpblas.h"
-#include "../SRC/PBtools.h"
-#include "../SRC/PBblacs.h"
-#include "../SRC/PBblas.h"
-#else
-#include "../pblas.h"
-#include "../PBpblas.h"
-#include "../PBtools.h"
-#include "../PBblacs.h"
-#include "../PBblas.h"
-#endif
-
-/*
-* ---------------------------------------------------------------------
-* FORTRAN <-> C interface
-* ---------------------------------------------------------------------
-*
-* These macros identifies how the PBLAS will be called as follows:
-*
-* _F2C_ADD_: the FORTRAN compiler expects the name of C functions to be
-* in all lower case and to have an underscore postfixed it (Suns, Intel
-* compilers expect this).
-*
-* _F2C_NOCHANGE: the FORTRAN compiler expects the name of C functions
-* to be in all lower case (IBM RS6K compilers do this).
-*
-* _F2C_UPCASE: the FORTRAN compiler expects the name of C functions
-* to be in all upcase. (Cray compilers expect this).
-*
-* _F2C_F77ISF2C: the FORTRAN compiler in use is f2c, a FORTRAN to C
-* converter.
-*/
-#if (_F2C_CALL_ == _F2C_ADD_ )
-#define PB_NoAbort pb_noabort_
-#endif
-#if (_F2C_CALL_ == _F2C_UPCASE )
-#define PB_NoAbort PB_NOABORT
-#endif
-#if (_F2C_CALL_ == _F2C_NOCHANGE )
-#define PB_NoAbort pb_noabort
-#endif
-#if (_F2C_CALL_ == _F2C_F77ISF2C )
-#define PB_NoAbort pb_noabort__
-#endif
-
-#ifdef __STDC__
-void PB_Cwarn( int ICTXT, int LINE, char * ROUT, char * FORM, ... )
-#else
-void PB_Cwarn( va_alist )
-va_dcl
-#endif
-{
-/*
-* Purpose
-* =======
-*
-* PB_Cwarn is an error handler for the PBLAS routines. This routine
-* displays an error message on stderr.
-*
-* Arguments
-* =========
-*
-* ICTXT (local input) INTEGER
-* On entry, ICTXT specifies the BLACS context handle, indica-
-* ting the global context of the operation. The context itself
-* is global, but the value of ICTXT is local.
-*
-* LINE (local input) INTEGER
-* On entry, LINE specifies the line number in the file where
-* the error has occured. When LINE is not a valid line number,
-*
-* ROUT (global input) pointer to CHAR
-* On entry, ROUT specifies the name of the routine calling this
-* error handler.
-*
-* FORM (local input) pointer to CHAR
-* On entry, FORM is a control string specifying the format
-* conversion of its following arguments.
-*
-* ... (local input)
-* On entry, FORM is a control string specifying the format
-* On entry, the expressions that are to be evaluated and con-
-* verted according to the formats in the control string FORM
-* and then placed in the output stream.
-*
-* -- Written on April 1, 1998 by
-* R. Clint Whaley, University of Tennessee, Knoxville 37996, USA.
-*
-* ---------------------------------------------------------------------
-*/
- va_list argptr;
- int iam, mycol, myrow, npcol, nprow;
- char cline[100];
-/* ..
-* .. External Functions ..
-*/
-#ifdef TestingPblas
-#ifdef __STDC__
- int PB_NoAbort( int * );
-#else
- int PB_NoAbort();
-#endif
-#endif
-
-#ifdef __STDC__
- va_start( argptr, FORM );
-#else
- char * ROUT, * FORM;
- int ICTXT, LINE;
-/* ..
-* .. Executable Statements ..
-*
-*/
- va_start( argptr );
- ICTXT = va_arg( argptr, int );
- LINE = va_arg( argptr, int );
- ROUT = va_arg( argptr, char * );
- FORM = va_arg( argptr, char * );
-#endif
-
-#ifdef TestingPblas
-/*
-* For testing purpose only, the error is reported, but the program execution
-* is not terminated
-*/
- if( PB_NoAbort( &ICTXT ) ) return;
-#endif
- vsprintf( cline, FORM, argptr );
- va_end( argptr );
-
- Cblacs_gridinfo( ICTXT, &nprow, &npcol, &myrow, &mycol );
-
- if( nprow != -1 ) iam = Cblacs_pnum( ICTXT, myrow, mycol );
- else iam = -1;
-/*
-* Display an error message
-*/
- if( LINE <= 0 )
- (void) fprintf( stderr, "%s'%s'\n%s{%d,%d}, %s%d, %s%d%s'%s'.\n\n",
- "PBLAS ERROR ", cline, "from ", myrow, mycol, "pnum=",
- iam, "Contxt=", ICTXT, ", in routine ", ROUT );
- else
- (void) fprintf( stderr, "%s'%s'\n%s{%d,%d}, %s%d, %s%d%s%d%s'%s'.\n\n",
- "PBLAS ERROR ", cline, "from ", myrow, mycol, "pnum=",
- iam, "Contxt=", ICTXT, ", on line ", LINE,
- " of routine ", ROUT );
-/*
-* End of PB_Cwarn
-*/
-}
diff --git a/PBLAS/TESTING/pcblas1tst.f b/PBLAS/TESTING/pcblas1tst.f
index 16d46ed..f91915a 100644
--- a/PBLAS/TESTING/pcblas1tst.f
+++ b/PBLAS/TESTING/pcblas1tst.f
@@ -1,9 +1,19 @@
+ BLOCK DATA
+ INTEGER NSUBS
+ PARAMETER (NSUBS = 10)
+ CHARACTER*7 SNAMES( NSUBS )
+ COMMON /SNAMEC/SNAMES
+ DATA SNAMES/'PCSWAP ', 'PCSCAL ',
+ $ 'PCSSCAL', 'PCCOPY ', 'PCAXPY ',
+ $ 'PCDOTU ', 'PCDOTC ', 'PSCNRM2',
+ $ 'PSCASUM', 'PCAMAX'/
+ END BLOCK DATA
+
PROGRAM PCBLA1TST
*
-* -- PBLAS testing driver (version 2.0) --
-* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
-* and University of California, Berkeley.
-* April 1, 1998
+* -- PBLAS testing driver (version 2.0.2) --
+* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver
+* May 1 2012
*
* Purpose
* =======
@@ -169,10 +179,6 @@
COMMON /PBERRORC/NOUT, ABRTFLG
* ..
* .. Data Statements ..
- DATA SNAMES/'PCSWAP ', 'PCSCAL ',
- $ 'PCSSCAL', 'PCCOPY ', 'PCAXPY ',
- $ 'PCDOTU ', 'PCDOTC ', 'PSCNRM2',
- $ 'PSCASUM', 'PCAMAX'/
DATA YCHECK/.TRUE., .FALSE., .FALSE., .TRUE.,
$ .TRUE., .TRUE., .TRUE., .FALSE., .FALSE.,
$ .FALSE./
diff --git a/PBLAS/TESTING/pcblas2tst.f b/PBLAS/TESTING/pcblas2tst.f
index 03b6dbf..5341677 100644
--- a/PBLAS/TESTING/pcblas2tst.f
+++ b/PBLAS/TESTING/pcblas2tst.f
@@ -1,9 +1,18 @@
+ BLOCK DATA
+ INTEGER NSUBS
+ PARAMETER (NSUBS = 8)
+ CHARACTER*7 SNAMES( NSUBS )
+ COMMON /SNAMEC/SNAMES
+ DATA SNAMES/'PCGEMV ', 'PCHEMV ', 'PCTRMV ',
+ $ 'PCTRSV ', 'PCGERU ', 'PCGERC ',
+ $ 'PCHER ', 'PCHER2 '/
+ END BLOCK DATA
+
PROGRAM PCBLA2TST
*
-* -- PBLAS testing driver (version 2.0) --
-* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
-* and University of California, Berkeley.
-* April 1, 1998
+* -- PBLAS testing driver (version 2.0.2) --
+* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver
+* May 1 2012
*
* Purpose
* =======
@@ -204,9 +213,6 @@
COMMON /PBERRORC/NOUT, ABRTFLG
* ..
* .. Data Statements ..
- DATA SNAMES/'PCGEMV ', 'PCHEMV ', 'PCTRMV ',
- $ 'PCTRSV ', 'PCGERU ', 'PCGERC ',
- $ 'PCHER ', 'PCHER2 '/
DATA YCHECK/.TRUE., .TRUE., .FALSE., .FALSE.,
$ .TRUE., .TRUE., .FALSE., .TRUE./
* ..
diff --git a/PBLAS/TESTING/pcblas3tst.f b/PBLAS/TESTING/pcblas3tst.f
index 9776f90..b50a089 100644
--- a/PBLAS/TESTING/pcblas3tst.f
+++ b/PBLAS/TESTING/pcblas3tst.f
@@ -1,9 +1,19 @@
+ BLOCK DATA
+ INTEGER NSUBS
+ PARAMETER (NSUBS = 11)
+ CHARACTER*7 SNAMES( NSUBS )
+ COMMON /SNAMEC/SNAMES
+ DATA SNAMES/'PCGEMM ', 'PCSYMM ', 'PCHEMM ',
+ $ 'PCSYRK ', 'PCHERK ', 'PCSYR2K',
+ $ 'PCHER2K', 'PCTRMM ', 'PCTRSM ',
+ $ 'PCGEADD', 'PCTRADD'/
+ END BLOCK DATA
+
PROGRAM PCBLA3TST
*
-* -- PBLAS testing driver (version 2.0) --
-* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
-* and University of California, Berkeley.
-* April 1, 1998
+* -- PBLAS testing driver (version 2.0.2) --
+* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver
+* May 1 2012
*
* Purpose
* =======
@@ -212,10 +222,6 @@
COMMON /PBERRORC/NOUT, ABRTFLG
* ..
* .. Data Statements ..
- DATA SNAMES/'PCGEMM ', 'PCSYMM ', 'PCHEMM ',
- $ 'PCSYRK ', 'PCHERK ', 'PCSYR2K',
- $ 'PCHER2K', 'PCTRMM ', 'PCTRSM ',
- $ 'PCGEADD', 'PCTRADD'/
DATA BCHECK/.TRUE., .TRUE., .TRUE., .FALSE.,
$ .FALSE., .TRUE., .TRUE., .TRUE., .TRUE.,
$ .FALSE., .FALSE./
diff --git a/PBLAS/TESTING/pcblastst.f b/PBLAS/TESTING/pcblastst.f
index 39f7940..d17edbc 100644
--- a/PBLAS/TESTING/pcblastst.f
+++ b/PBLAS/TESTING/pcblastst.f
@@ -7487,10 +7487,12 @@
IF( LSAME( CMACH, 'E' ).OR.LSAME( CMACH, 'S' ).OR.
$ LSAME( CMACH, 'M' ).OR.LSAME( CMACH, 'U' ) ) THEN
CALL PB_TOPGET( ICTXT, 'Combine', 'All', TOP )
+ IDUMM = 0
CALL SGAMX2D( ICTXT, 'All', TOP, 1, 1, TEMP, 1, IDUMM,
$ IDUMM, -1, -1, IDUMM )
ELSE IF( LSAME( CMACH, 'L' ).OR.LSAME( CMACH, 'O' ) ) THEN
CALL PB_TOPGET( ICTXT, 'Combine', 'All', TOP )
+ IDUMM = 0
CALL SGAMN2D( ICTXT, 'All', TOP, 1, 1, TEMP, 1, IDUMM,
$ IDUMM, -1, -1, IDUMM )
END IF
diff --git a/PBLAS/TESTING/pdblas1tst.f b/PBLAS/TESTING/pdblas1tst.f
index 199f549..97975d0 100644
--- a/PBLAS/TESTING/pdblas1tst.f
+++ b/PBLAS/TESTING/pdblas1tst.f
@@ -1,9 +1,18 @@
+ BLOCK DATA
+ INTEGER NSUBS
+ PARAMETER (NSUBS = 8)
+ CHARACTER*7 SNAMES( NSUBS )
+ COMMON /SNAMEC/SNAMES
+ DATA SNAMES/'PDSWAP ', 'PDSCAL ', 'PDCOPY ',
+ $ 'PDAXPY ', 'PDDOT ', 'PDNRM2 ',
+ $ 'PDASUM ', 'PDAMAX '/
+ END BLOCK DATA
+
PROGRAM PDBLA1TST
*
-* -- PBLAS testing driver (version 2.0) --
-* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
-* and University of California, Berkeley.
-* April 1, 1998
+* -- PBLAS testing driver (version 2.0.2) --
+* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver
+* May 1 2012
*
* Purpose
* =======
@@ -161,9 +170,6 @@
COMMON /PBERRORC/NOUT, ABRTFLG
* ..
* .. Data Statements ..
- DATA SNAMES/'PDSWAP ', 'PDSCAL ', 'PDCOPY ',
- $ 'PDAXPY ', 'PDDOT ', 'PDNRM2 ',
- $ 'PDASUM ', 'PDAMAX '/
DATA YCHECK/.TRUE., .FALSE., .TRUE., .TRUE., .TRUE.,
$ .FALSE., .FALSE., .FALSE./
* ..
diff --git a/PBLAS/TESTING/pdblas2tst.f b/PBLAS/TESTING/pdblas2tst.f
index 3d1a5b0..a4745a0 100644
--- a/PBLAS/TESTING/pdblas2tst.f
+++ b/PBLAS/TESTING/pdblas2tst.f
@@ -1,9 +1,18 @@
+ BLOCK DATA
+ INTEGER NSUBS
+ PARAMETER (NSUBS = 7)
+ CHARACTER*7 SNAMES( NSUBS )
+ COMMON /SNAMEC/SNAMES
+ DATA SNAMES/'PDGEMV ', 'PDSYMV ', 'PDTRMV ',
+ $ 'PDTRSV ', 'PDGER ', 'PDSYR ',
+ $ 'PDSYR2 '/
+ END BLOCK DATA
+
PROGRAM PDBLA2TST
*
-* -- PBLAS testing driver (version 2.0) --
-* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
-* and University of California, Berkeley.
-* April 1, 1998
+* -- PBLAS testing driver (version 2.0.2) --
+* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver
+* May 1 2012
*
* Purpose
* =======
@@ -197,9 +206,6 @@
COMMON /PBERRORC/NOUT, ABRTFLG
* ..
* .. Data Statements ..
- DATA SNAMES/'PDGEMV ', 'PDSYMV ', 'PDTRMV ',
- $ 'PDTRSV ', 'PDGER ', 'PDSYR ',
- $ 'PDSYR2 '/
DATA YCHECK/.TRUE., .TRUE., .FALSE., .FALSE.,
$ .TRUE., .FALSE., .TRUE./
* ..
diff --git a/PBLAS/TESTING/pdblas3tst.f b/PBLAS/TESTING/pdblas3tst.f
index 4ff66f5..cc93663 100644
--- a/PBLAS/TESTING/pdblas3tst.f
+++ b/PBLAS/TESTING/pdblas3tst.f
@@ -1,9 +1,18 @@
- PROGRAM PDBLA3TST
+ BLOCK DATA
+ INTEGER NSUBS
+ PARAMETER (NSUBS = 8)
+ CHARACTER*7 SNAMES( NSUBS )
+ COMMON /SNAMEC/SNAMES
+ DATA SNAMES/'PDGEMM ', 'PDSYMM ', 'PDSYRK ',
+ $ 'PDSYR2K', 'PDTRMM ', 'PDTRSM ',
+ $ 'PDGEADD', 'PDTRADD'/
+ END BLOCK DATA
+
+ PROGRAM PDBA3TST
*
-* -- PBLAS testing driver (version 2.0) --
-* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
-* and University of California, Berkeley.
-* April 1, 1998
+* -- PBLAS testing driver (version 2.0.2) --
+* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver
+* May 1 2012
*
* Purpose
* =======
@@ -204,9 +213,6 @@
COMMON /PBERRORC/NOUT, ABRTFLG
* ..
* .. Data Statements ..
- DATA SNAMES/'PDGEMM ', 'PDSYMM ', 'PDSYRK ',
- $ 'PDSYR2K', 'PDTRMM ', 'PDTRSM ',
- $ 'PDGEADD', 'PDTRADD'/
DATA BCHECK/.TRUE., .TRUE., .FALSE., .TRUE., .TRUE.,
$ .TRUE., .FALSE., .FALSE./
DATA CCHECK/.TRUE., .TRUE., .TRUE., .TRUE., .FALSE.,
diff --git a/PBLAS/TESTING/pdblastst.f b/PBLAS/TESTING/pdblastst.f
index 8c8b5e4..818c4d5 100644
--- a/PBLAS/TESTING/pdblastst.f
+++ b/PBLAS/TESTING/pdblastst.f
@@ -6838,6 +6838,7 @@
* .. Executable Statements ..
*
TEMP = DLAMCH( CMACH )
+ IDUMM = 0
*
IF( LSAME( CMACH, 'E' ).OR.LSAME( CMACH, 'S' ).OR.
$ LSAME( CMACH, 'M' ).OR.LSAME( CMACH, 'U' ) ) THEN
diff --git a/PBLAS/TESTING/psblas1tst.f b/PBLAS/TESTING/psblas1tst.f
index ad33f91..57cedfe 100644
--- a/PBLAS/TESTING/psblas1tst.f
+++ b/PBLAS/TESTING/psblas1tst.f
@@ -1,9 +1,18 @@
+ BLOCK DATA
+ INTEGER NSUBS
+ PARAMETER (NSUBS = 8)
+ CHARACTER*7 SNAMES( NSUBS )
+ COMMON /SNAMEC/SNAMES
+ DATA SNAMES/'PSSWAP ', 'PSSCAL ', 'PSCOPY ',
+ $ 'PSAXPY ', 'PSDOT ', 'PSNRM2 ',
+ $ 'PSASUM ', 'PSAMAX '/
+ END BLOCK DATA
+
PROGRAM PSBLA1TST
*
-* -- PBLAS testing driver (version 2.0) --
-* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
-* and University of California, Berkeley.
-* April 1, 1998
+* -- PBLAS testing driver (version 2.0.2) --
+* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver
+* May 1 2012
*
* Purpose
* =======
@@ -161,9 +170,6 @@
COMMON /PBERRORC/NOUT, ABRTFLG
* ..
* .. Data Statements ..
- DATA SNAMES/'PSSWAP ', 'PSSCAL ', 'PSCOPY ',
- $ 'PSAXPY ', 'PSDOT ', 'PSNRM2 ',
- $ 'PSASUM ', 'PSAMAX '/
DATA YCHECK/.TRUE., .FALSE., .TRUE., .TRUE., .TRUE.,
$ .FALSE., .FALSE., .FALSE./
* ..
diff --git a/PBLAS/TESTING/psblas2tst.f b/PBLAS/TESTING/psblas2tst.f
index 8c293d7..51e93ba 100644
--- a/PBLAS/TESTING/psblas2tst.f
+++ b/PBLAS/TESTING/psblas2tst.f
@@ -1,9 +1,18 @@
+ BLOCK DATA
+ INTEGER NSUBS
+ PARAMETER (NSUBS = 7)
+ CHARACTER*7 SNAMES( NSUBS )
+ COMMON /SNAMEC/SNAMES
+ DATA SNAMES/'PSGEMV ', 'PSSYMV ', 'PSTRMV ',
+ $ 'PSTRSV ', 'PSGER ', 'PSSYR ',
+ $ 'PSSYR2 '/
+ END BLOCK DATA
+
PROGRAM PSBLA2TST
*
-* -- PBLAS testing driver (version 2.0) --
-* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
-* and University of California, Berkeley.
-* April 1, 1998
+* -- PBLAS testing driver (version 2.0.2) --
+* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver
+* May 1 2012
*
* Purpose
* =======
@@ -196,9 +205,6 @@
COMMON /PBERRORC/NOUT, ABRTFLG
* ..
* .. Data Statements ..
- DATA SNAMES/'PSGEMV ', 'PSSYMV ', 'PSTRMV ',
- $ 'PSTRSV ', 'PSGER ', 'PSSYR ',
- $ 'PSSYR2 '/
DATA YCHECK/.TRUE., .TRUE., .FALSE., .FALSE.,
$ .TRUE., .FALSE., .TRUE./
* ..
diff --git a/PBLAS/TESTING/psblas3tst.f b/PBLAS/TESTING/psblas3tst.f
index 74726d3..2ddaaa1 100644
--- a/PBLAS/TESTING/psblas3tst.f
+++ b/PBLAS/TESTING/psblas3tst.f
@@ -1,9 +1,18 @@
+ BLOCK DATA
+ INTEGER NSUBS
+ PARAMETER (NSUBS = 8)
+ CHARACTER*7 SNAMES( NSUBS )
+ COMMON /SNAMEC/SNAMES
+ DATA SNAMES/'PSGEMM ', 'PSSYMM ', 'PSSYRK ',
+ $ 'PSSYR2K', 'PSTRMM ', 'PSTRSM ',
+ $ 'PSGEADD', 'PSTRADD'/
+ END BLOCK DATA
+
PROGRAM PSBLA3TST
*
-* -- PBLAS testing driver (version 2.0) --
-* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
-* and University of California, Berkeley.
-* April 1, 1998
+* -- PBLAS testing driver (version 2.0.2) --
+* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver
+* May 1 2012
*
* Purpose
* =======
@@ -203,9 +212,6 @@
COMMON /PBERRORC/NOUT, ABRTFLG
* ..
* .. Data Statements ..
- DATA SNAMES/'PSGEMM ', 'PSSYMM ', 'PSSYRK ',
- $ 'PSSYR2K', 'PSTRMM ', 'PSTRSM ',
- $ 'PSGEADD', 'PSTRADD'/
DATA BCHECK/.TRUE., .TRUE., .FALSE., .TRUE., .TRUE.,
$ .TRUE., .FALSE., .FALSE./
DATA CCHECK/.TRUE., .TRUE., .TRUE., .TRUE., .FALSE.,
diff --git a/PBLAS/TESTING/psblastst.f b/PBLAS/TESTING/psblastst.f
index a377b1d..c6a2f28 100644
--- a/PBLAS/TESTING/psblastst.f
+++ b/PBLAS/TESTING/psblastst.f
@@ -6842,10 +6842,12 @@
IF( LSAME( CMACH, 'E' ).OR.LSAME( CMACH, 'S' ).OR.
$ LSAME( CMACH, 'M' ).OR.LSAME( CMACH, 'U' ) ) THEN
CALL PB_TOPGET( ICTXT, 'Combine', 'All', TOP )
+ IDUMM = 0
CALL SGAMX2D( ICTXT, 'All', TOP, 1, 1, TEMP, 1, IDUMM,
$ IDUMM, -1, -1, IDUMM )
ELSE IF( LSAME( CMACH, 'L' ).OR.LSAME( CMACH, 'O' ) ) THEN
CALL PB_TOPGET( ICTXT, 'Combine', 'All', TOP )
+ IDUMM = 0
CALL SGAMN2D( ICTXT, 'All', TOP, 1, 1, TEMP, 1, IDUMM,
$ IDUMM, -1, -1, IDUMM )
END IF
diff --git a/PBLAS/TESTING/pzblas1tst.f b/PBLAS/TESTING/pzblas1tst.f
index 779fd3a..fb9043b 100644
--- a/PBLAS/TESTING/pzblas1tst.f
+++ b/PBLAS/TESTING/pzblas1tst.f
@@ -1,9 +1,19 @@
+ BLOCK DATA
+ INTEGER NSUBS
+ PARAMETER (NSUBS = 10)
+ CHARACTER*7 SNAMES( NSUBS )
+ COMMON /SNAMEC/SNAMES
+ DATA SNAMES/'PZSWAP ', 'PZSCAL ',
+ $ 'PZDSCAL', 'PZCOPY ', 'PZAXPY ',
+ $ 'PZDOTU ', 'PZDOTC ', 'PDZNRM2',
+ $ 'PDZASUM', 'PZAMAX'/
+ END BLOCK DATA
+
PROGRAM PZBLA1TST
*
-* -- PBLAS testing driver (version 2.0) --
-* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
-* and University of California, Berkeley.
-* April 1, 1998
+* -- PBLAS testing driver (version 2.0.2) --
+* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver
+* May 1 2012
*
* Purpose
* =======
@@ -169,10 +179,6 @@
COMMON /PBERRORC/NOUT, ABRTFLG
* ..
* .. Data Statements ..
- DATA SNAMES/'PZSWAP ', 'PZSCAL ',
- $ 'PZDSCAL', 'PZCOPY ', 'PZAXPY ',
- $ 'PZDOTU ', 'PZDOTC ', 'PDZNRM2',
- $ 'PDZASUM', 'PZAMAX'/
DATA YCHECK/.TRUE., .FALSE., .FALSE., .TRUE.,
$ .TRUE., .TRUE., .TRUE., .FALSE., .FALSE.,
$ .FALSE./
diff --git a/PBLAS/TESTING/pzblas2tst.f b/PBLAS/TESTING/pzblas2tst.f
index 69fbd5d..0277240 100644
--- a/PBLAS/TESTING/pzblas2tst.f
+++ b/PBLAS/TESTING/pzblas2tst.f
@@ -1,9 +1,18 @@
+ BLOCK DATA
+ INTEGER NSUBS
+ PARAMETER (NSUBS = 8)
+ CHARACTER*7 SNAMES( NSUBS )
+ COMMON /SNAMEC/SNAMES
+ DATA SNAMES/'PZGEMV ', 'PZHEMV ', 'PZTRMV ',
+ $ 'PZTRSV ', 'PZGERU ', 'PZGERC ',
+ $ 'PZHER ', 'PZHER2 '/
+ END BLOCK DATA
+
PROGRAM PZBLA2TST
*
-* -- PBLAS testing driver (version 2.0) --
-* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
-* and University of California, Berkeley.
-* April 1, 1998
+* -- PBLAS testing driver (version 2.0.2) --
+* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver
+* May 1 2012
*
* Purpose
* =======
@@ -203,9 +212,6 @@
COMMON /PBERRORC/NOUT, ABRTFLG
* ..
* .. Data Statements ..
- DATA SNAMES/'PZGEMV ', 'PZHEMV ', 'PZTRMV ',
- $ 'PZTRSV ', 'PZGERU ', 'PZGERC ',
- $ 'PZHER ', 'PZHER2 '/
DATA YCHECK/.TRUE., .TRUE., .FALSE., .FALSE.,
$ .TRUE., .TRUE., .FALSE., .TRUE./
* ..
diff --git a/PBLAS/TESTING/pzblas3tst.f b/PBLAS/TESTING/pzblas3tst.f
index a200da0..cd947de 100644
--- a/PBLAS/TESTING/pzblas3tst.f
+++ b/PBLAS/TESTING/pzblas3tst.f
@@ -1,9 +1,19 @@
+ BLOCK DATA
+ INTEGER NSUBS
+ PARAMETER (NSUBS = 11)
+ CHARACTER*7 SNAMES( NSUBS )
+ COMMON /SNAMEC/SNAMES
+ DATA SNAMES/'PZGEMM ', 'PZSYMM ', 'PZHEMM ',
+ $ 'PZSYRK ', 'PZHERK ', 'PZSYR2K',
+ $ 'PZHER2K', 'PZTRMM ', 'PZTRSM ',
+ $ 'PZGEADD', 'PZTRADD'/
+ END BLOCK DATA
+
PROGRAM PZBLA3TST
*
-* -- PBLAS testing driver (version 2.0) --
-* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
-* and University of California, Berkeley.
-* April 1, 1998
+* -- PBLAS testing driver (version 2.0.2) --
+* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver
+* May 1 2012
*
* Purpose
* =======
@@ -212,10 +222,6 @@
COMMON /PBERRORC/NOUT, ABRTFLG
* ..
* .. Data Statements ..
- DATA SNAMES/'PZGEMM ', 'PZSYMM ', 'PZHEMM ',
- $ 'PZSYRK ', 'PZHERK ', 'PZSYR2K',
- $ 'PZHER2K', 'PZTRMM ', 'PZTRSM ',
- $ 'PZGEADD', 'PZTRADD'/
DATA BCHECK/.TRUE., .TRUE., .TRUE., .FALSE.,
$ .FALSE., .TRUE., .TRUE., .TRUE., .TRUE.,
$ .FALSE., .FALSE./
diff --git a/PBLAS/TESTING/pzblastst.f b/PBLAS/TESTING/pzblastst.f
index c7ce138..f614215 100644
--- a/PBLAS/TESTING/pzblastst.f
+++ b/PBLAS/TESTING/pzblastst.f
@@ -7488,10 +7488,12 @@
IF( LSAME( CMACH, 'E' ).OR.LSAME( CMACH, 'S' ).OR.
$ LSAME( CMACH, 'M' ).OR.LSAME( CMACH, 'U' ) ) THEN
CALL PB_TOPGET( ICTXT, 'Combine', 'All', TOP )
+ IDUMM = 0
CALL DGAMX2D( ICTXT, 'All', TOP, 1, 1, TEMP, 1, IDUMM,
$ IDUMM, -1, -1, IDUMM )
ELSE IF( LSAME( CMACH, 'L' ).OR.LSAME( CMACH, 'O' ) ) THEN
CALL PB_TOPGET( ICTXT, 'Combine', 'All', TOP )
+ IDUMM = 0
CALL DGAMN2D( ICTXT, 'All', TOP, 1, 1, TEMP, 1, IDUMM,
$ IDUMM, -1, -1, IDUMM )
END IF
diff --git a/PBLAS/TIMING/CMakeLists.txt b/PBLAS/TIMING/CMakeLists.txt
new file mode 100644
index 0000000..763330f
--- /dev/null
+++ b/PBLAS/TIMING/CMakeLists.txt
@@ -0,0 +1,78 @@
+file(COPY ../SRC/PTOOLS/PB_Cwarn.c DESTINATION ${CMAKE_CURRENT_SOURCE_DIR})
+file(COPY ../SRC/PTOOLS/PB_Cabort.c DESTINATION ${CMAKE_CURRENT_SOURCE_DIR})
+
+set (PblasErrorHandler PB_Cwarn.c PB_Cabort.c)
+set (pbtcom pblastim.f ${PblasErrorHandler})
+set (spbtcom psblastim.f ${pbtcom})
+set (dpbtcom pdblastim.f ${pbtcom})
+set (cpbtcom pcblastim.f ${pbtcom})
+set (zpbtcom pzblastim.f ${pbtcom})
+
+set_property(
+ SOURCE ${PblasErrorHandler}
+ APPEND PROPERTY COMPILE_DEFINITIONS TestingPblas
+ )
+
+set(CMAKE_RUNTIME_OUTPUT_DIRECTORY ${SCALAPACK_BINARY_DIR}/PBLAS/TIMING)
+
+file(COPY PCBLAS1TIM.dat DESTINATION ${CMAKE_RUNTIME_OUTPUT_DIRECTORY})
+file(COPY PCBLAS2TIM.dat DESTINATION ${CMAKE_RUNTIME_OUTPUT_DIRECTORY})
+file(COPY PCBLAS3TIM.dat DESTINATION ${CMAKE_RUNTIME_OUTPUT_DIRECTORY})
+file(COPY PDBLAS1TIM.dat DESTINATION ${CMAKE_RUNTIME_OUTPUT_DIRECTORY})
+file(COPY PDBLAS2TIM.dat DESTINATION ${CMAKE_RUNTIME_OUTPUT_DIRECTORY})
+file(COPY PDBLAS3TIM.dat DESTINATION ${CMAKE_RUNTIME_OUTPUT_DIRECTORY})
+file(COPY PSBLAS1TIM.dat DESTINATION ${CMAKE_RUNTIME_OUTPUT_DIRECTORY})
+file(COPY PSBLAS2TIM.dat DESTINATION ${CMAKE_RUNTIME_OUTPUT_DIRECTORY})
+file(COPY PSBLAS3TIM.dat DESTINATION ${CMAKE_RUNTIME_OUTPUT_DIRECTORY})
+file(COPY PZBLAS1TIM.dat DESTINATION ${CMAKE_RUNTIME_OUTPUT_DIRECTORY})
+file(COPY PZBLAS2TIM.dat DESTINATION ${CMAKE_RUNTIME_OUTPUT_DIRECTORY})
+file(COPY PZBLAS3TIM.dat DESTINATION ${CMAKE_RUNTIME_OUTPUT_DIRECTORY})
+
+
+add_executable(spb1tim psblas1tim.f ${spbtcom})
+add_executable(dpb1tim pdblas1tim.f ${dpbtcom})
+add_executable(cpb1tim pcblas1tim.f ${cpbtcom})
+add_executable(zpb1tim pzblas1tim.f ${zpbtcom})
+
+add_executable(spb2tim psblas2tim.f ${spbtcom})
+add_executable(dpb2tim pdblas2tim.f ${dpbtcom})
+add_executable(cpb2tim pcblas2tim.f ${cpbtcom})
+add_executable(zpb2tim pzblas2tim.f ${zpbtcom})
+
+add_executable(spb3tim psblas3tim.f ${spbtcom})
+add_executable(dpb3tim pdblas3tim.f ${dpbtcom})
+add_executable(cpb3tim pcblas3tim.f ${cpbtcom})
+add_executable(zpb3tim pzblas3tim.f ${zpbtcom})
+
+target_link_libraries(spb1tim scalapack ${LAPACK_LIBRARIES} ${BLAS_LIBRARIES})
+target_link_libraries(dpb1tim scalapack ${LAPACK_LIBRARIES} ${BLAS_LIBRARIES})
+target_link_libraries(cpb1tim scalapack ${LAPACK_LIBRARIES} ${BLAS_LIBRARIES})
+target_link_libraries(zpb1tim scalapack ${LAPACK_LIBRARIES} ${BLAS_LIBRARIES})
+
+target_link_libraries(spb2tim scalapack ${LAPACK_LIBRARIES} ${BLAS_LIBRARIES})
+target_link_libraries(dpb2tim scalapack ${LAPACK_LIBRARIES} ${BLAS_LIBRARIES})
+target_link_libraries(cpb2tim scalapack ${LAPACK_LIBRARIES} ${BLAS_LIBRARIES})
+target_link_libraries(zpb2tim scalapack ${LAPACK_LIBRARIES} ${BLAS_LIBRARIES})
+
+target_link_libraries(spb3tim scalapack ${LAPACK_LIBRARIES} ${BLAS_LIBRARIES})
+target_link_libraries(dpb3tim scalapack ${LAPACK_LIBRARIES} ${BLAS_LIBRARIES})
+target_link_libraries(cpb3tim scalapack ${LAPACK_LIBRARIES} ${BLAS_LIBRARIES})
+target_link_libraries(zpb3tim scalapack ${LAPACK_LIBRARIES} ${BLAS_LIBRARIES})
+
+add_test(spb1tim ${MPIEXEC} ${MPIEXEC_NUMPROC_FLAG} 4 ./spb1tim)
+add_test(dpb1tim ${MPIEXEC} ${MPIEXEC_NUMPROC_FLAG} 4 ./dpb1tim)
+add_test(cpb1tim ${MPIEXEC} ${MPIEXEC_NUMPROC_FLAG} 4 ./cpb1tim)
+add_test(zpb1tim ${MPIEXEC} ${MPIEXEC_NUMPROC_FLAG} 4 ./zpb1tim)
+
+add_test(spb2tim ${MPIEXEC} ${MPIEXEC_NUMPROC_FLAG} 4 ./spb2tim)
+add_test(dpb2tim ${MPIEXEC} ${MPIEXEC_NUMPROC_FLAG} 4 ./dpb2tim)
+add_test(cpb2tim ${MPIEXEC} ${MPIEXEC_NUMPROC_FLAG} 4 ./cpb2tim)
+add_test(zpb2tim ${MPIEXEC} ${MPIEXEC_NUMPROC_FLAG} 4 ./zpb2tim)
+
+add_test(spb3tim ${MPIEXEC} ${MPIEXEC_NUMPROC_FLAG} 4 ./spb3tim)
+add_test(dpb3tim ${MPIEXEC} ${MPIEXEC_NUMPROC_FLAG} 4 ./dpb3tim)
+add_test(cpb3tim ${MPIEXEC} ${MPIEXEC_NUMPROC_FLAG} 4 ./cpb3tim)
+add_test(zpb3tim ${MPIEXEC} ${MPIEXEC_NUMPROC_FLAG} 4 ./zpb3tim)
+
+
+
diff --git a/PBLAS/TIMING/Makefile b/PBLAS/TIMING/Makefile
index bd4ea17..c696d52 100644
--- a/PBLAS/TIMING/Makefile
+++ b/PBLAS/TIMING/Makefile
@@ -31,20 +31,20 @@ dPBLAS3exe = xdpblas3tim
cPBLAS3exe = xcpblas3tim
zPBLAS3exe = xzpblas3tim
-spb1tim = $(PBLASTSTdir)/$(sPBLAS1exe)
-dpb1tim = $(PBLASTSTdir)/$(dPBLAS1exe)
-cpb1tim = $(PBLASTSTdir)/$(cPBLAS1exe)
-zpb1tim = $(PBLASTSTdir)/$(zPBLAS1exe)
+spb1tim = $(sPBLAS1exe)
+dpb1tim = $(dPBLAS1exe)
+cpb1tim = $(cPBLAS1exe)
+zpb1tim = $(zPBLAS1exe)
-spb2tim = $(PBLASTSTdir)/$(sPBLAS2exe)
-dpb2tim = $(PBLASTSTdir)/$(dPBLAS2exe)
-cpb2tim = $(PBLASTSTdir)/$(cPBLAS2exe)
-zpb2tim = $(PBLASTSTdir)/$(zPBLAS2exe)
+spb2tim = $(sPBLAS2exe)
+dpb2tim = $(dPBLAS2exe)
+cpb2tim = $(cPBLAS2exe)
+zpb2tim = $(zPBLAS2exe)
-spb3tim = $(PBLASTSTdir)/$(sPBLAS3exe)
-dpb3tim = $(PBLASTSTdir)/$(dPBLAS3exe)
-cpb3tim = $(PBLASTSTdir)/$(cPBLAS3exe)
-zpb3tim = $(PBLASTSTdir)/$(zPBLAS3exe)
+spb3tim = $(sPBLAS3exe)
+dpb3tim = $(dPBLAS3exe)
+cpb3tim = $(cPBLAS3exe)
+zpb3tim = $(zPBLAS3exe)
pbtcom = pblastim.o PB_Cwarn.o PB_Cabort.o
@@ -73,101 +73,53 @@ complex: PblasErrorHandler $(cpb1tim) $(cpb2tim) $(cpb3tim)
complex16: PblasErrorHandler $(zpb1tim) $(zpb2tim) $(zpb3tim)
-PblasErrorHandler:
- rm -f PB_Cwarn.c PB_Cwarn.o
- ln -s $(PBLASdir)/SRC/PTOOLS/PB_Cwarn.c PB_Cwarn.c
- $(CC) -c $(CCFLAGS) $(CDEFS) -DTestingPblas PB_Cwarn.c
- rm -f PB_Cabort.c PB_Cabort.o
- ln -s $(PBLASdir)/SRC/PTOOLS/PB_Cabort.c PB_Cabort.c
- $(CC) -c $(CCFLAGS) $(CDEFS) -DTestingPblas PB_Cabort.c
-
-$(PBLASTSTdir)/PSBLAS1TIM.dat: PSBLAS1TIM.dat
- cp PSBLAS1TIM.dat $(PBLASTSTdir)
-$(PBLASTSTdir)/PDBLAS1TIM.dat: PDBLAS1TIM.dat
- cp PDBLAS1TIM.dat $(PBLASTSTdir)
-$(PBLASTSTdir)/PCBLAS1TIM.dat: PCBLAS1TIM.dat
- cp PCBLAS1TIM.dat $(PBLASTSTdir)
-$(PBLASTSTdir)/PZBLAS1TIM.dat: PZBLAS1TIM.dat
- cp PZBLAS1TIM.dat $(PBLASTSTdir)
-
-$(spb1tim) : $(SCALAPACKLIB) $(spb1t)
- $(F77LOADER) $(F77LOADFLAGS) -o $(spb1tim) $(spb1t) $(LIBS)
- $(MAKE) $(PBLASTSTdir)/PSBLAS1TIM.dat
-$(dpb1tim) : $(SCALAPACKLIB) $(dpb1t)
- $(F77LOADER) $(F77LOADFLAGS) -o $(dpb1tim) $(dpb1t) $(LIBS)
- $(MAKE) $(PBLASTSTdir)/PDBLAS1TIM.dat
-$(cpb1tim) : $(SCALAPACKLIB) $(cpb1t)
- $(F77LOADER) $(F77LOADFLAGS) -o $(cpb1tim) $(cpb1t) $(LIBS)
- $(MAKE) $(PBLASTSTdir)/PCBLAS1TIM.dat
-$(zpb1tim) : $(SCALAPACKLIB) $(zpb1t)
- $(F77LOADER) $(F77LOADFLAGS) -o $(zpb1tim) $(zpb1t) $(LIBS)
- $(MAKE) $(PBLASTSTdir)/PZBLAS1TIM.dat
-
-$(PBLASTSTdir)/PSBLAS2TIM.dat: PSBLAS2TIM.dat
- cp PSBLAS2TIM.dat $(PBLASTSTdir)
-$(PBLASTSTdir)/PDBLAS2TIM.dat: PDBLAS2TIM.dat
- cp PDBLAS2TIM.dat $(PBLASTSTdir)
-$(PBLASTSTdir)/PCBLAS2TIM.dat: PCBLAS2TIM.dat
- cp PCBLAS2TIM.dat $(PBLASTSTdir)
-$(PBLASTSTdir)/PZBLAS2TIM.dat: PZBLAS2TIM.dat
- cp PZBLAS2TIM.dat $(PBLASTSTdir)
-
-$(spb2tim) : $(SCALAPACKLIB) $(spb2t)
- $(F77LOADER) $(F77LOADFLAGS) -o $(spb2tim) $(spb2t) $(LIBS)
- $(MAKE) $(PBLASTSTdir)/PSBLAS2TIM.dat
-$(dpb2tim) : $(SCALAPACKLIB) $(dpb2t)
- $(F77LOADER) $(F77LOADFLAGS) -o $(dpb2tim) $(dpb2t) $(LIBS)
- $(MAKE) $(PBLASTSTdir)/PDBLAS2TIM.dat
-$(cpb2tim) : $(SCALAPACKLIB) $(cpb2t)
- $(F77LOADER) $(F77LOADFLAGS) -o $(cpb2tim) $(cpb2t) $(LIBS)
- $(MAKE) $(PBLASTSTdir)/PCBLAS2TIM.dat
-$(zpb2tim) : $(SCALAPACKLIB) $(zpb2t)
- $(F77LOADER) $(F77LOADFLAGS) -o $(zpb2tim) $(zpb2t) $(LIBS)
- $(MAKE) $(PBLASTSTdir)/PZBLAS2TIM.dat
-
-$(PBLASTSTdir)/PSBLAS3TIM.dat: PSBLAS3TIM.dat
- cp PSBLAS3TIM.dat $(PBLASTSTdir)
-$(PBLASTSTdir)/PDBLAS3TIM.dat: PDBLAS3TIM.dat
- cp PDBLAS3TIM.dat $(PBLASTSTdir)
-$(PBLASTSTdir)/PCBLAS3TIM.dat: PCBLAS3TIM.dat
- cp PCBLAS3TIM.dat $(PBLASTSTdir)
-$(PBLASTSTdir)/PZBLAS3TIM.dat: PZBLAS3TIM.dat
- cp PZBLAS3TIM.dat $(PBLASTSTdir)
-
-$(spb3tim) : $(SCALAPACKLIB) $(spb3t)
- $(F77LOADER) $(F77LOADFLAGS) -o $(spb3tim) $(spb3t) $(LIBS)
- $(MAKE) $(PBLASTSTdir)/PSBLAS3TIM.dat
-$(dpb3tim) : $(SCALAPACKLIB) $(dpb3t)
- $(F77LOADER) $(F77LOADFLAGS) -o $(dpb3tim) $(dpb3t) $(LIBS)
- $(MAKE) $(PBLASTSTdir)/PDBLAS3TIM.dat
-$(cpb3tim) : $(SCALAPACKLIB) $(cpb3t)
- $(F77LOADER) $(F77LOADFLAGS) -o $(cpb3tim) $(cpb3t) $(LIBS)
- $(MAKE) $(PBLASTSTdir)/PCBLAS3TIM.dat
-$(zpb3tim) : $(SCALAPACKLIB) $(zpb3t)
- $(F77LOADER) $(F77LOADFLAGS) -o $(zpb3tim) $(zpb3t) $(LIBS)
- $(MAKE) $(PBLASTSTdir)/PZBLAS3TIM.dat
-
-$(spb1t): $(FRC)
-$(dpb1t): $(FRC)
-$(cpb1t): $(FRC)
-$(zpb1t): $(FRC)
-
-$(spb2t): $(FRC)
-$(dpb2t): $(FRC)
-$(cpb2t): $(FRC)
-$(zpb2t): $(FRC)
-
-$(spb3t): $(FRC)
-$(dpb3t): $(FRC)
-$(cpb3t): $(FRC)
-$(zpb3t): $(FRC)
-
-FRC:
- @FRC=$(FRC)
+PB_Cwarn.o:
+ $(CC) -c $(CDEFS) $(CCFLAGS) -DTestingPblas -I../SRC -o PB_Cwarn.o ../SRC/PTOOLS/PB_Cwarn.c
+
+PB_Cabort.o:
+ $(CC) -c $(CDEFS) $(CCFLAGS) -DTestingPblas -I../SRC -o PB_Cabort.o ../SRC/PTOOLS/PB_Cabort.c
+
+PblasErrorHandler: PB_Cwarn.o PB_Cabort.o
+
+$(spb1tim) : ../../$(SCALAPACKLIB) $(spb1t)
+ $(FCLOADER) $(FCLOADFLAGS) -o $(spb1tim) $(spb1t) ../../$(SCALAPACKLIB) $(LIBS)
+
+$(dpb1tim) : ../../$(SCALAPACKLIB) $(dpb1t)
+ $(FCLOADER) $(FCLOADFLAGS) -o $(dpb1tim) $(dpb1t) ../../$(SCALAPACKLIB) $(LIBS)
+
+$(cpb1tim) : ../../$(SCALAPACKLIB) $(cpb1t)
+ $(FCLOADER) $(FCLOADFLAGS) -o $(cpb1tim) $(cpb1t) ../../$(SCALAPACKLIB) $(LIBS)
+
+$(zpb1tim) : ../../$(SCALAPACKLIB) $(zpb1t)
+ $(FCLOADER) $(FCLOADFLAGS) -o $(zpb1tim) $(zpb1t) ../../$(SCALAPACKLIB) $(LIBS)
+
+$(spb2tim) : ../../$(SCALAPACKLIB) $(spb2t)
+ $(FCLOADER) $(FCLOADFLAGS) -o $(spb2tim) $(spb2t) ../../$(SCALAPACKLIB) $(LIBS)
+
+$(dpb2tim) : ../../$(SCALAPACKLIB) $(dpb2t)
+ $(FCLOADER) $(FCLOADFLAGS) -o $(dpb2tim) $(dpb2t) ../../$(SCALAPACKLIB) $(LIBS)
+
+$(cpb2tim) : ../../$(SCALAPACKLIB) $(cpb2t)
+ $(FCLOADER) $(FCLOADFLAGS) -o $(cpb2tim) $(cpb2t) ../../$(SCALAPACKLIB) $(LIBS)
+
+$(zpb2tim) : ../../$(SCALAPACKLIB) $(zpb2t)
+ $(FCLOADER) $(FCLOADFLAGS) -o $(zpb2tim) $(zpb2t) ../../$(SCALAPACKLIB) $(LIBS)
+
+$(spb3tim) : ../../$(SCALAPACKLIB) $(spb3t)
+ $(FCLOADER) $(FCLOADFLAGS) -o $(spb3tim) $(spb3t) ../../$(SCALAPACKLIB) $(LIBS)
+
+$(dpb3tim) : ../../$(SCALAPACKLIB) $(dpb3t)
+ $(FCLOADER) $(FCLOADFLAGS) -o $(dpb3tim) $(dpb3t) ../../$(SCALAPACKLIB) $(LIBS)
+
+$(cpb3tim) : ../../$(SCALAPACKLIB) $(cpb3t)
+ $(FCLOADER) $(FCLOADFLAGS) -o $(cpb3tim) $(cpb3t) ../../$(SCALAPACKLIB) $(LIBS)
+
+$(zpb3tim) : ../../$(SCALAPACKLIB) $(zpb3t)
+ $(FCLOADER) $(FCLOADFLAGS) -o $(zpb3tim) $(zpb3t) ../../$(SCALAPACKLIB) $(LIBS)
clean :
- rm -f *.o
+ rm -f *.o x*
-.f.o : ; $(F77) -c $(F77FLAGS) $*.f
+.f.o : ; $(FC) -c $(FCFLAGS) $*.f
-# .c.o : ; $(CC) -c $(CCFLAGS) $(CDEFS) -DTestingPblas $*.c
+ .c.o : ; $(CC) -c $(CDEFS) $(CCFLAGS) -DTestingPblas $*.c
diff --git a/PBLAS/TIMING/PB_Cabort.c b/PBLAS/TIMING/PB_Cabort.c
deleted file mode 100644
index d97bca0..0000000
--- a/PBLAS/TIMING/PB_Cabort.c
+++ /dev/null
@@ -1,158 +0,0 @@
-/* ---------------------------------------------------------------------
-*
-* -- PBLAS auxiliary routine (version 2.0) --
-* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
-* and University of California, Berkeley.
-* April 1, 1998
-*
-* ---------------------------------------------------------------------
-*/
-/*
-* Include files
-*/
-#ifdef TestingPblas
-#include "../SRC/pblas.h"
-#include "../SRC/PBpblas.h"
-#include "../SRC/PBtools.h"
-#include "../SRC/PBblacs.h"
-#include "../SRC/PBblas.h"
-#else
-#include "../pblas.h"
-#include "../PBpblas.h"
-#include "../PBtools.h"
-#include "../PBblacs.h"
-#include "../PBblas.h"
-#endif
-
-/*
-* ---------------------------------------------------------------------
-* FORTRAN <-> C interface
-* ---------------------------------------------------------------------
-*
-* These macros identifies how the PBLAS will be called as follows:
-*
-* _F2C_ADD_: the FORTRAN compiler expects the name of C functions to be
-* in all lower case and to have an underscore postfixed it (Suns, Intel
-* compilers expect this).
-*
-* _F2C_NOCHANGE: the FORTRAN compiler expects the name of C functions
-* to be in all lower case (IBM RS6K compilers do this).
-*
-* _F2C_UPCASE: the FORTRAN compiler expects the name of C functions
-* to be in all upcase. (Cray compilers expect this).
-*
-* _F2C_F77ISF2C: the FORTRAN compiler in use is f2c, a FORTRAN to C
-* converter.
-*/
-#if (_F2C_CALL_ == _F2C_ADD_ )
-#define PB_NoAbort pb_noabort_
-#endif
-#if (_F2C_CALL_ == _F2C_UPCASE )
-#define PB_NoAbort PB_NOABORT
-#endif
-#if (_F2C_CALL_ == _F2C_NOCHANGE )
-#define PB_NoAbort pb_noabort
-#endif
-#if (_F2C_CALL_ == _F2C_F77ISF2C )
-#define PB_NoAbort pb_noabort__
-#endif
-
-#ifdef __STDC__
-void PB_Cabort( int ICTXT, char * ROUT, int INFO )
-#else
-void PB_Cabort( ICTXT, ROUT, INFO )
-/*
-* .. Scalar Arguments ..
-*/
- int ICTXT, INFO;
-/*
-* .. Array Arguments ..
-*/
- char * ROUT;
-#endif
-{
-/*
-* Purpose
-* =======
-*
-* PB_Cabort is an error handler for the PBLAS routines. This routine
-* displays an error message on stderr by calling PB_Cwarn, and halts
-* execution by calling Cblacs_abort().
-*
-* Arguments
-* =========
-*
-* ICTXT (local input) INTEGER
-* On entry, ICTXT specifies the BLACS context handle, indica-
-* ting the global context of the operation. The context itself
-* is global, but the value of ICTXT is local.
-*
-* ROUT (global input) pointer to CHAR
-* On entry, ROUT specifies the name of the routine calling this
-* error handler.
-*
-* INFO (local input) INTEGER
-* The error code computed by the calling PBLAS routine.
-* = 0: no error found
-* < 0: If the i-th argument is an array and the j-entry had
-* an illegal value, then INFO = -(i*100+j), if the i-th
-* argument is a scalar and had an illegal value, then
-* INFO = -i.
-*
-* -- Written on April 1, 1998 by
-* R. Clint Whaley, University of Tennessee, Knoxville 37996, USA.
-*
-* ---------------------------------------------------------------------
-*/
-/*
-* .. Local Scalars ..
-*/
- int mycol, myrow, npcol, nprow;
-/* ..
-* .. External Functions ..
-*/
-#ifdef TestingPblas
-#ifdef __STDC__
- int PB_NoAbort( int * );
-#else
- int PB_NoAbort();
-#endif
-#endif
-/* ..
-* .. Executable Statements ..
-*
-*/
- Cblacs_gridinfo( ICTXT, &nprow, &npcol, &myrow, &mycol );
-#ifdef TestingPblas
-/*
-* For testing purpose only, the error is reported, but the program execution
-* is not terminated
-*/
- if( PB_NoAbort( &INFO ) ) return;
-#endif
- if( INFO < 0 )
- {
-/*
-* Display an error message
-*/
- if( INFO < DESCMULT )
- PB_Cwarn( ICTXT, -1, ROUT,
- "Parameter number %d had an illegal value", -INFO );
- else
- PB_Cwarn( ICTXT, -1, ROUT,
- "Parameter number %d, entry number %d had an illegal value",
- (-INFO) / DESCMULT, (-INFO) % DESCMULT );
- }
- else
- {
-/*
-* Error code is incorrect, it should be negative
-*/
- PB_Cwarn( ICTXT, -1, ROUT,
- "Positive error code %d returned by %s!!!", INFO );
- }
- Cblacs_abort( ICTXT, INFO );
-/*
-* End of PB_Cabort
-*/
-}
diff --git a/PBLAS/TIMING/PB_Cwarn.c b/PBLAS/TIMING/PB_Cwarn.c
deleted file mode 100644
index 6f6ca18..0000000
--- a/PBLAS/TIMING/PB_Cwarn.c
+++ /dev/null
@@ -1,164 +0,0 @@
-/* ---------------------------------------------------------------------
-*
-* -- PBLAS auxiliary routine (version 2.0) --
-* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
-* and University of California, Berkeley.
-* April 1, 1998
-*
-* ---------------------------------------------------------------------
-*/
-/*
-* Include files
-*/
-#ifdef TestingPblas
-#include "../SRC/pblas.h"
-#include "../SRC/PBpblas.h"
-#include "../SRC/PBtools.h"
-#include "../SRC/PBblacs.h"
-#include "../SRC/PBblas.h"
-#else
-#include "../pblas.h"
-#include "../PBpblas.h"
-#include "../PBtools.h"
-#include "../PBblacs.h"
-#include "../PBblas.h"
-#endif
-
-/*
-* ---------------------------------------------------------------------
-* FORTRAN <-> C interface
-* ---------------------------------------------------------------------
-*
-* These macros identifies how the PBLAS will be called as follows:
-*
-* _F2C_ADD_: the FORTRAN compiler expects the name of C functions to be
-* in all lower case and to have an underscore postfixed it (Suns, Intel
-* compilers expect this).
-*
-* _F2C_NOCHANGE: the FORTRAN compiler expects the name of C functions
-* to be in all lower case (IBM RS6K compilers do this).
-*
-* _F2C_UPCASE: the FORTRAN compiler expects the name of C functions
-* to be in all upcase. (Cray compilers expect this).
-*
-* _F2C_F77ISF2C: the FORTRAN compiler in use is f2c, a FORTRAN to C
-* converter.
-*/
-#if (_F2C_CALL_ == _F2C_ADD_ )
-#define PB_NoAbort pb_noabort_
-#endif
-#if (_F2C_CALL_ == _F2C_UPCASE )
-#define PB_NoAbort PB_NOABORT
-#endif
-#if (_F2C_CALL_ == _F2C_NOCHANGE )
-#define PB_NoAbort pb_noabort
-#endif
-#if (_F2C_CALL_ == _F2C_F77ISF2C )
-#define PB_NoAbort pb_noabort__
-#endif
-
-#ifdef __STDC__
-void PB_Cwarn( int ICTXT, int LINE, char * ROUT, char * FORM, ... )
-#else
-void PB_Cwarn( va_alist )
-va_dcl
-#endif
-{
-/*
-* Purpose
-* =======
-*
-* PB_Cwarn is an error handler for the PBLAS routines. This routine
-* displays an error message on stderr.
-*
-* Arguments
-* =========
-*
-* ICTXT (local input) INTEGER
-* On entry, ICTXT specifies the BLACS context handle, indica-
-* ting the global context of the operation. The context itself
-* is global, but the value of ICTXT is local.
-*
-* LINE (local input) INTEGER
-* On entry, LINE specifies the line number in the file where
-* the error has occured. When LINE is not a valid line number,
-*
-* ROUT (global input) pointer to CHAR
-* On entry, ROUT specifies the name of the routine calling this
-* error handler.
-*
-* FORM (local input) pointer to CHAR
-* On entry, FORM is a control string specifying the format
-* conversion of its following arguments.
-*
-* ... (local input)
-* On entry, FORM is a control string specifying the format
-* On entry, the expressions that are to be evaluated and con-
-* verted according to the formats in the control string FORM
-* and then placed in the output stream.
-*
-* -- Written on April 1, 1998 by
-* R. Clint Whaley, University of Tennessee, Knoxville 37996, USA.
-*
-* ---------------------------------------------------------------------
-*/
- va_list argptr;
- int iam, mycol, myrow, npcol, nprow;
- char cline[100];
-/* ..
-* .. External Functions ..
-*/
-#ifdef TestingPblas
-#ifdef __STDC__
- int PB_NoAbort( int * );
-#else
- int PB_NoAbort();
-#endif
-#endif
-
-#ifdef __STDC__
- va_start( argptr, FORM );
-#else
- char * ROUT, * FORM;
- int ICTXT, LINE;
-/* ..
-* .. Executable Statements ..
-*
-*/
- va_start( argptr );
- ICTXT = va_arg( argptr, int );
- LINE = va_arg( argptr, int );
- ROUT = va_arg( argptr, char * );
- FORM = va_arg( argptr, char * );
-#endif
-
-#ifdef TestingPblas
-/*
-* For testing purpose only, the error is reported, but the program execution
-* is not terminated
-*/
- if( PB_NoAbort( &ICTXT ) ) return;
-#endif
- vsprintf( cline, FORM, argptr );
- va_end( argptr );
-
- Cblacs_gridinfo( ICTXT, &nprow, &npcol, &myrow, &mycol );
-
- if( nprow != -1 ) iam = Cblacs_pnum( ICTXT, myrow, mycol );
- else iam = -1;
-/*
-* Display an error message
-*/
- if( LINE <= 0 )
- (void) fprintf( stderr, "%s'%s'\n%s{%d,%d}, %s%d, %s%d%s'%s'.\n\n",
- "PBLAS ERROR ", cline, "from ", myrow, mycol, "pnum=",
- iam, "Contxt=", ICTXT, ", in routine ", ROUT );
- else
- (void) fprintf( stderr, "%s'%s'\n%s{%d,%d}, %s%d, %s%d%s%d%s'%s'.\n\n",
- "PBLAS ERROR ", cline, "from ", myrow, mycol, "pnum=",
- iam, "Contxt=", ICTXT, ", on line ", LINE,
- " of routine ", ROUT );
-/*
-* End of PB_Cwarn
-*/
-}
diff --git a/PBLAS/TIMING/pcblas1tim.f b/PBLAS/TIMING/pcblas1tim.f
index fb8e311..1c74954 100644
--- a/PBLAS/TIMING/pcblas1tim.f
+++ b/PBLAS/TIMING/pcblas1tim.f
@@ -1,9 +1,19 @@
+ BLOCK DATA
+ INTEGER NSUBS
+ PARAMETER (NSUBS = 10)
+ CHARACTER*7 SNAMES( NSUBS )
+ COMMON /SNAMEC/SNAMES
+ DATA SNAMES/'PCSWAP ', 'PCSCAL ',
+ $ 'PCSSCAL', 'PCCOPY', 'PCAXPY ',
+ $ 'PCDOTU ', 'PCDOTC' , 'PSCNRM2',
+ $ 'PSCASUM', 'PCAMAX '/
+ END BLOCK DATA
+
PROGRAM PCBLA1TIM
*
-* -- PBLAS timing driver (version 2.0) --
-* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
-* and University of California, Berkeley.
-* April 1, 1998
+* -- PBLAS timing driver (version 2.0.2) --
+* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver
+* May 1 2012
*
* Purpose
* =======
@@ -157,10 +167,6 @@
COMMON /PBERRORC/NOUT, ABRTFLG
* ..
* .. Data Statements ..
- DATA SNAMES/'PCSWAP ', 'PCSCAL ',
- $ 'PCSSCAL ', 'PCCOPY', 'PCAXPY ',
- $ 'PCDOTU ', 'PCDOTC' , 'PSCNRM2',
- $ 'PSCASUM', 'PCAMAX '/
DATA YCHECK/.TRUE., .FALSE., .FALSE., .TRUE.,
$ .TRUE., .TRUE., .TRUE., .FALSE., .FALSE.,
$ .FALSE./
diff --git a/PBLAS/TIMING/pcblas2tim.f b/PBLAS/TIMING/pcblas2tim.f
index 2850f10..eb14e25 100644
--- a/PBLAS/TIMING/pcblas2tim.f
+++ b/PBLAS/TIMING/pcblas2tim.f
@@ -1,9 +1,18 @@
+ BLOCK DATA
+ INTEGER NSUBS
+ PARAMETER (NSUBS = 8)
+ CHARACTER*7 SNAMES( 8 )
+ COMMON /SNAMEC/SNAMES
+ DATA SNAMES/'PCGEMV ', 'PCHEMV ', 'PCTRMV ',
+ $ 'PCTRSV ', 'PCGERU ', 'PCGERC ',
+ $ 'PCHER ', 'PCHER2 '/
+ END BLOCK DATA
+
PROGRAM PCBLA2TIM
*
-* -- PBLAS timing driver (version 2.0) --
-* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
-* and University of California, Berkeley.
-* April 1, 1998
+* -- PBLAS timing driver (version 2.0.2) --
+* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver
+* May 1 2012
*
* Purpose
* =======
@@ -188,9 +197,6 @@
COMMON /PBERRORC/NOUT, ABRTFLG
* ..
* .. Data Statements ..
- DATA SNAMES/'PCGEMV ', 'PCHEMV ', 'PCTRMV ',
- $ 'PCTRSV ', 'PCGERU ', 'PCGERC ',
- $ 'PCHER ', 'PCHER2 '/
DATA YCHECK/.TRUE., .TRUE., .FALSE., .FALSE.,
$ .TRUE., .TRUE., .FALSE., .TRUE./
* ..
diff --git a/PBLAS/TIMING/pcblas3tim.f b/PBLAS/TIMING/pcblas3tim.f
index 38915e2..0bf9f6b 100644
--- a/PBLAS/TIMING/pcblas3tim.f
+++ b/PBLAS/TIMING/pcblas3tim.f
@@ -1,9 +1,19 @@
+ BLOCK DATA
+ INTEGER NSUBS
+ PARAMETER (NSUBS = 11)
+ CHARACTER*7 SNAMES( NSUBS )
+ COMMON /SNAMEC/SNAMES
+ DATA SNAMES/'PCGEMM ', 'PCSYMM ', 'PCHEMM ',
+ $ 'PCSYRK ', 'PCHERK ', 'PCSYR2K',
+ $ 'PCHER2K', 'PCTRMM ', 'PCTRSM ',
+ $ 'PCGEADD', 'PCTRADD'/
+ END BLOCK DATA
+
PROGRAM PCBLA3TIM
*
-* -- PBLAS timing driver (version 2.0) --
-* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
-* and University of California, Berkeley.
-* April 1, 1998
+* -- PBLAS timing driver (version 2.0.2) --
+* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver
+* May 1 2012
*
* Purpose
* =======
@@ -195,10 +205,6 @@
COMMON /PBERRORC/NOUT, ABRTFLG
* ..
* .. Data Statements ..
- DATA SNAMES/'PCGEMM ', 'PCSYMM ', 'PCHEMM ',
- $ 'PCSYRK ', 'PCHERK ', 'PCSYR2K',
- $ 'PCHER2K', 'PCTRMM ', 'PCTRSM ',
- $ 'PCGEADD', 'PCTRADD'/
DATA BCHECK/.TRUE., .TRUE., .TRUE., .FALSE.,
$ .FALSE., .TRUE., .TRUE., .TRUE., .TRUE.,
$ .FALSE., .FALSE./
diff --git a/PBLAS/TIMING/pdblas1tim.f b/PBLAS/TIMING/pdblas1tim.f
index f1f2276..c97c04f 100644
--- a/PBLAS/TIMING/pdblas1tim.f
+++ b/PBLAS/TIMING/pdblas1tim.f
@@ -1,9 +1,18 @@
+ BLOCK DATA
+ INTEGER NSUBS
+ PARAMETER (NSUBS = 8)
+ CHARACTER*7 SNAMES( NSUBS )
+ COMMON /SNAMEC/SNAMES
+ DATA SNAMES/'PDSWAP ', 'PDSCAL ', 'PDCOPY ',
+ $ 'PDAXPY ', 'PDDOT ', 'PDNRM2 ',
+ $ 'PDASUM ', 'PDAMAX '/
+ END BLOCK DATA
+
PROGRAM PDBLA1TIM
*
-* -- PBLAS timing driver (version 2.0) --
-* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
-* and University of California, Berkeley.
-* April 1, 1998
+* -- PBLAS timing driver (version 2.0.2) --
+* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver
+* May 1 2012
*
* Purpose
* =======
@@ -150,9 +159,6 @@
COMMON /PBERRORC/NOUT, ABRTFLG
* ..
* .. Data Statements ..
- DATA SNAMES/'PDSWAP ', 'PDSCAL ', 'PDCOPY ',
- $ 'PDAXPY ', 'PDDOT ', 'PDNRM2 ',
- $ 'PDASUM ', 'PDAMAX '/
DATA YCHECK/.TRUE., .FALSE., .TRUE., .TRUE., .TRUE.,
$ .FALSE., .FALSE., .FALSE./
* ..
diff --git a/PBLAS/TIMING/pdblas2tim.f b/PBLAS/TIMING/pdblas2tim.f
index c6619ed..b1b889d 100644
--- a/PBLAS/TIMING/pdblas2tim.f
+++ b/PBLAS/TIMING/pdblas2tim.f
@@ -1,9 +1,18 @@
+ BLOCK DATA
+ INTEGER NSUBS
+ PARAMETER (NSUBS = 7)
+ CHARACTER*7 SNAMES( NSUBS )
+ COMMON /SNAMEC/SNAMES
+ DATA SNAMES/'PDGEMV ', 'PDSYMV ', 'PDTRMV ',
+ $ 'PDTRSV ', 'PDGER ', 'PDSYR ',
+ $ 'PDSYR2 '/
+ END BLOCK DATA
+
PROGRAM PDBLA2TIM
*
-* -- PBLAS timing driver (version 2.0) --
-* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
-* and University of California, Berkeley.
-* April 1, 1998
+* -- PBLAS timing driver (version 2.0.2) --
+* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver
+* May 1 2012
*
* Purpose
* =======
@@ -183,9 +192,6 @@
COMMON /PBERRORC/NOUT, ABRTFLG
* ..
* .. Data Statements ..
- DATA SNAMES/'PDGEMV ', 'PDSYMV ', 'PDTRMV ',
- $ 'PDTRSV ', 'PDGER ', 'PDSYR ',
- $ 'PDSYR2 '/
DATA YCHECK/.TRUE., .TRUE., .FALSE., .FALSE.,
$ .TRUE., .FALSE., .TRUE./
* ..
diff --git a/PBLAS/TIMING/pdblas3tim.f b/PBLAS/TIMING/pdblas3tim.f
index a952756..8ea69e3 100644
--- a/PBLAS/TIMING/pdblas3tim.f
+++ b/PBLAS/TIMING/pdblas3tim.f
@@ -1,9 +1,18 @@
+ BLOCK DATA
+ INTEGER NSUBS
+ PARAMETER (NSUBS = 8)
+ CHARACTER*7 SNAMES( NSUBS )
+ COMMON /SNAMEC/SNAMES
+ DATA SNAMES/'PDGEMM ', 'PDSYMM ', 'PDSYRK ',
+ $ 'PDSYR2K', 'PDTRMM ', 'PDTRSM ',
+ $ 'PDGEADD', 'PDTRADD'/
+ END BLOCK DATA
+
PROGRAM PDBLA3TIM
*
-* -- PBLAS timing driver (version 2.0) --
-* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
-* and University of California, Berkeley.
-* April 1, 1998
+* -- PBLAS timing driver (version 2.0.2) --
+* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver
+* May 1 2012
*
* Purpose
* =======
@@ -187,9 +196,6 @@
COMMON /PBERRORC/NOUT, ABRTFLG
* ..
* .. Data Statements ..
- DATA SNAMES/'PDGEMM ', 'PDSYMM ', 'PDSYRK ',
- $ 'PDSYR2K', 'PDTRMM ', 'PDTRSM ',
- $ 'PDGEADD', 'PDTRADD'/
DATA BCHECK/.TRUE., .TRUE., .FALSE., .TRUE., .TRUE.,
$ .TRUE., .FALSE., .FALSE./
DATA CCHECK/.TRUE., .TRUE., .TRUE., .TRUE., .FALSE.,
diff --git a/PBLAS/TIMING/psblas1tim.f b/PBLAS/TIMING/psblas1tim.f
index 8e635b4..aa006e3 100644
--- a/PBLAS/TIMING/psblas1tim.f
+++ b/PBLAS/TIMING/psblas1tim.f
@@ -1,9 +1,18 @@
+ BLOCK DATA
+ INTEGER NSUBS
+ PARAMETER (NSUBS = 8)
+ CHARACTER*7 SNAMES( NSUBS )
+ COMMON /SNAMEC/SNAMES
+ DATA SNAMES/'PSSWAP ', 'PSSCAL ', 'PSCOPY ',
+ $ 'PSAXPY ', 'PSDOT ', 'PSNRM2 ',
+ $ 'PSASUM ', 'PSAMAX '/
+ END BLOCK DATA
+
PROGRAM PSBLA1TIM
*
-* -- PBLAS timing driver (version 2.0) --
-* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
-* and University of California, Berkeley.
-* April 1, 1998
+* -- PBLAS timing driver (version 2.0.2) --
+* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver
+* May 1 2012
*
* Purpose
* =======
@@ -151,9 +160,6 @@
COMMON /PBERRORC/NOUT, ABRTFLG
* ..
* .. Data Statements ..
- DATA SNAMES/'PSSWAP ', 'PSSCAL ', 'PSCOPY ',
- $ 'PSAXPY ', 'PSDOT ', 'PSNRM2 ',
- $ 'PSASUM ', 'PSAMAX '/
DATA YCHECK/.TRUE., .FALSE., .TRUE., .TRUE., .TRUE.,
$ .FALSE., .FALSE., .FALSE./
* ..
diff --git a/PBLAS/TIMING/psblas2tim.f b/PBLAS/TIMING/psblas2tim.f
index 590313b..8593220 100644
--- a/PBLAS/TIMING/psblas2tim.f
+++ b/PBLAS/TIMING/psblas2tim.f
@@ -1,9 +1,18 @@
+ BLOCK DATA
+ INTEGER NSUBS
+ PARAMETER (NSUBS = 7)
+ CHARACTER*7 SNAMES( NSUBS )
+ COMMON /SNAMEC/SNAMES
+ DATA SNAMES/'PSGEMV ', 'PSSYMV ', 'PSTRMV ',
+ $ 'PSTRSV ', 'PSGER ', 'PSSYR ',
+ $ 'PSSYR2 '/
+ END BLOCK DATA
+
PROGRAM PSBLA2TIM
*
-* -- PBLAS timing driver (version 2.0) --
-* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
-* and University of California, Berkeley.
-* April 1, 1998
+* -- PBLAS timing driver (version 2.0.2) --
+* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver
+* May 1 2012
*
* Purpose
* =======
@@ -185,9 +194,6 @@
COMMON /PBERRORC/NOUT, ABRTFLG
* ..
* .. Data Statements ..
- DATA SNAMES/'PSGEMV ', 'PSSYMV ', 'PSTRMV ',
- $ 'PSTRSV ', 'PSGER ', 'PSSYR ',
- $ 'PSSYR2 '/
DATA YCHECK/.TRUE., .TRUE., .FALSE., .FALSE.,
$ .TRUE., .FALSE., .TRUE./
* ..
diff --git a/PBLAS/TIMING/psblas3tim.f b/PBLAS/TIMING/psblas3tim.f
index 6586441..160fc91 100644
--- a/PBLAS/TIMING/psblas3tim.f
+++ b/PBLAS/TIMING/psblas3tim.f
@@ -1,9 +1,18 @@
+ BLOCK DATA
+ INTEGER NSUBS
+ PARAMETER (NSUBS = 8)
+ CHARACTER*7 SNAMES( NSUBS )
+ COMMON /SNAMEC/SNAMES
+ DATA SNAMES/'PSGEMM ', 'PSSYMM ', 'PSSYRK ',
+ $ 'PSSYR2K', 'PSTRMM ', 'PSTRSM ',
+ $ 'PSGEADD', 'PSTRADD'/
+ END BLOCK DATA
+
PROGRAM PSBLA3TIM
*
-* -- PBLAS timing driver (version 2.0) --
-* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
-* and University of California, Berkeley.
-* April 1, 1998
+* -- PBLAS timing driver (version 2.0.2) --
+* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver
+* May 1 2012
*
* Purpose
* =======
@@ -189,9 +198,6 @@
COMMON /PBERRORC/NOUT, ABRTFLG
* ..
* .. Data Statements ..
- DATA SNAMES/'PSGEMM ', 'PSSYMM ', 'PSSYRK ',
- $ 'PSSYR2K', 'PSTRMM ', 'PSTRSM ',
- $ 'PSGEADD', 'PSTRADD'/
DATA BCHECK/.TRUE., .TRUE., .FALSE., .TRUE., .TRUE.,
$ .TRUE., .FALSE., .FALSE./
DATA CCHECK/.TRUE., .TRUE., .TRUE., .TRUE., .FALSE.,
diff --git a/PBLAS/TIMING/pzblas1tim.f b/PBLAS/TIMING/pzblas1tim.f
index 890e203..b0c956d 100644
--- a/PBLAS/TIMING/pzblas1tim.f
+++ b/PBLAS/TIMING/pzblas1tim.f
@@ -1,9 +1,19 @@
+ BLOCK DATA
+ INTEGER NSUBS
+ PARAMETER (NSUBS = 10)
+ CHARACTER*7 SNAMES( NSUBS )
+ COMMON /SNAMEC/SNAMES
+ DATA SNAMES/'PZSWAP ', 'PZSCAL ',
+ $ 'PZDSCAL', 'PZCOPY', 'PZAXPY ',
+ $ 'PZDOTU ', 'PZDOTC' , 'PDZNRM2',
+ $ 'PDZASUM', 'PZAMAX '/
+ END BLOCK DATA
+
PROGRAM PZBLA1TIM
*
-* -- PBLAS timing driver (version 2.0) --
-* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
-* and University of California, Berkeley.
-* April 1, 1998
+* -- PBLAS timing driver (version 2.0.2) --
+* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver
+* May 1 2012
*
* Purpose
* =======
@@ -156,10 +166,6 @@
COMMON /PBERRORC/NOUT, ABRTFLG
* ..
* .. Data Statements ..
- DATA SNAMES/'PZSWAP ', 'PZSCAL ',
- $ 'PZDSCAL ', 'PZCOPY', 'PZAXPY ',
- $ 'PZDOTU ', 'PZDOTC' , 'PDZNRM2',
- $ 'PDZASUM', 'PZAMAX '/
DATA YCHECK/.TRUE., .FALSE., .FALSE., .TRUE.,
$ .TRUE., .TRUE., .TRUE., .FALSE., .FALSE.,
$ .FALSE./
diff --git a/PBLAS/TIMING/pzblas2tim.f b/PBLAS/TIMING/pzblas2tim.f
index f3e69a7..8602635 100644
--- a/PBLAS/TIMING/pzblas2tim.f
+++ b/PBLAS/TIMING/pzblas2tim.f
@@ -1,9 +1,18 @@
+ BLOCK DATA
+ INTEGER NSUBS
+ PARAMETER (NSUBS = 8)
+ CHARACTER*7 SNAMES( NSUBS )
+ COMMON /SNAMEC/SNAMES
+ DATA SNAMES/'PZGEMV ', 'PZHEMV ', 'PZTRMV ',
+ $ 'PZTRSV ', 'PZGERU ', 'PZGERC ',
+ $ 'PZHER ', 'PZHER2 '/
+ END BLOCK DATA
+
PROGRAM PZBLA2TIM
*
-* -- PBLAS timing driver (version 2.0) --
-* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
-* and University of California, Berkeley.
-* April 1, 1998
+* -- PBLAS timing driver (version 2.0.2) --
+* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver
+* May 1 2012
*
* Purpose
* =======
@@ -188,9 +197,6 @@
COMMON /PBERRORC/NOUT, ABRTFLG
* ..
* .. Data Statements ..
- DATA SNAMES/'PZGEMV ', 'PZHEMV ', 'PZTRMV ',
- $ 'PZTRSV ', 'PZGERU ', 'PZGERC ',
- $ 'PZHER ', 'PZHER2 '/
DATA YCHECK/.TRUE., .TRUE., .FALSE., .FALSE.,
$ .TRUE., .TRUE., .FALSE., .TRUE./
* ..
diff --git a/PBLAS/TIMING/pzblas3tim.f b/PBLAS/TIMING/pzblas3tim.f
index 1a4ebb2..83f1be1 100644
--- a/PBLAS/TIMING/pzblas3tim.f
+++ b/PBLAS/TIMING/pzblas3tim.f
@@ -1,9 +1,19 @@
+ BLOCK DATA
+ INTEGER NSUBS
+ PARAMETER (NSUBS = 11)
+ CHARACTER*7 SNAMES( NSUBS )
+ COMMON /SNAMEC/SNAMES
+ DATA SNAMES/'PZGEMM ', 'PZSYMM ', 'PZHEMM ',
+ $ 'PZSYRK ', 'PZHERK ', 'PZSYR2K',
+ $ 'PZHER2K', 'PZTRMM ', 'PZTRSM ',
+ $ 'PZGEADD', 'PZTRADD'/
+ END BLOCK DATA
+
PROGRAM PZBLA3TIM
*
-* -- PBLAS timing driver (version 2.0) --
-* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
-* and University of California, Berkeley.
-* April 1, 1998
+* -- PBLAS timing driver (version 2.0.2) --
+* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver
+* May 1 2012
*
* Purpose
* =======
@@ -195,10 +205,6 @@
COMMON /PBERRORC/NOUT, ABRTFLG
* ..
* .. Data Statements ..
- DATA SNAMES/'PZGEMM ', 'PZSYMM ', 'PZHEMM ',
- $ 'PZSYRK ', 'PZHERK ', 'PZSYR2K',
- $ 'PZHER2K', 'PZTRMM ', 'PZTRSM ',
- $ 'PZGEADD', 'PZTRADD'/
DATA BCHECK/.TRUE., .TRUE., .TRUE., .FALSE.,
$ .FALSE., .TRUE., .TRUE., .TRUE., .TRUE.,
$ .FALSE., .FALSE./
diff --git a/README b/README
index b81f8bc..5a5e8a5 100644
--- a/README
+++ b/README
@@ -2,37 +2,37 @@
ScaLAPACK README FILE
=====================
- VERSION 1.0 : February 28, 1995
+ VERSION 1.0 : February 28, 1995
- UPDATES:
- VERSION 1.1 : March 20, 1995
+ VERSION 1.1 : March 20, 1995
- VERSION 1.2 : May 10, 1996
+ VERSION 1.2 : May 10, 1996
- UPDATES:
- VERSION 1.3 : June 5, 1996
+ VERSION 1.3 : June 5, 1996
- VERSION 1.4 : November 17, 1996
+ VERSION 1.4 : November 17, 1996
- VERSION 1.5 : May 1, 1997
+ VERSION 1.5 : May 1, 1997
- UPDATES:
- VERSION 1.6 : November 15, 1997
+ VERSION 1.6 : November 15, 1997
- VERSION 1.7 : August, 2001
+ VERSION 1.7 : August, 2001
- VERSION 1.8 : April 2007
+ VERSION 1.8 : April 2007
+
+ VERSION 2.0 : November, 2011
+ VERSION 2.0.1 : January, 2012
+ VERSION 2.0.2 : May, 2012
ScaLAPACK, or Scalable LAPACK, is a library of high performance linear
-algebra routines for distributed memory message-passing MIMD computers
-and networks of workstations supporting MPI and/or PVM.
+algebra routines for distributed memory computers supporting MPI.
The complete ScaLAPACK package is freely available on netlib and
can be obtained via the World Wide Web or anonymous ftp.
http://www.netlib.org/scalapack/
-ScaLAPACK, version 1.8, includes routines for the solution of dense,
+ScaLAPACK, version 2.0, includes routines for the solution of dense,
band, and tridiagonal linear systems of equations, condition estimation and
iterative refinement, for LU and Cholesky factorization, matrix inversion,
full-rank linear least squares problems, orthogonal and generalized orthogonal
@@ -42,54 +42,52 @@ Hermitian-definite generalized eigenproblem to standard form, the
symmetric/Hermitian, divide-and-conquer symmetric/Hermitian, generalized
symmetric/Hermitian and the nonsymmetric eigenproblem, and the singular value
decomposition. With the exception of the singular value decomposition,
-all routines are available in four types: single precision real, double
+most routines are available in four types: single precision real, double
precision real, single precision complex, and double precision complex.
+New in version 2.0:
+
+- ScaLAPACK now only supports MPI.
+
+- The BLACS is now part of ScaLAPACK, and is compiled into the ScaLAPACK
+ library. It is no longer necessary to link against BLACS libraries.
+
+- Building ScaLAPACK using cmake is now supported.
+
+- New MRRR Symmetric Eigenvalue Problem routines are included:
+ pssyevr, pdsyevr, pcheevr and pzheevr.
+
+- New Nonsymmetric Eigenvalue Problem QR routines for computing
+ eigenvalues of a Hessenberg matrix are included for real matrices:
+ pshseqr and pdhseqr.
+
Unless otherwise noted, the current scalapack.tgz on netlib contains
all available updates.
Errata for ScaLAPACK (source code and documentation) can be found at:
+
http://www.netlib.org/scalapack/errata.html
ScaLAPACK example programs can be found at:
+
http://www.netlib.org/scalapack/examples/
-Since ScaLAPACK 1.8, a basic example is include in the EXAMPLE directory.
-
-Prototype versions of ScaLAPACK routines using packed storage are
-now available in the scalapack/prototype directory on netlib:
- http://www.netlib.org/scalapack/prototype/packed.tgz
-
-It is highly recommended that you obtain a copy of the ScaLAPACK
-Users' Guide published by SIAM. This Users' Guide gives a detailed
-description of the philosophy behind ScaLAPACK as well as an explanation
-of its usage. Each Users' Guide includes a CD-ROM containing the HTML
-version of the ScaLAPACK Users' Guide, the source code for the package,
-testing and timing programs, prebuilt versions of the library for a number
-of computers, example programs, and a full set of LAPACK Working Notes.
-The ScaLAPACK Users' Guide can be purchased from:
-SIAM; 3600 University City Science Center; Philadelphia, PA 19104-2688;
-215-382-9800, FAX 215-386-7999. It will also be available from
-booksellers.
-
-To order by email, send email to service at siam.org. The book is also
-available via SIAM's World Wide Web URL at http://www.siam.org. The
-ISBN number is 0-89871-397-8, and SIAM order code is SE04. The list
-price for SIAM members is $39.60; the cost for nonmembers is $49.50.
+
+A basic example is included in the EXAMPLE directory.
+
+The ScaLAPACK User's Guide for ScaLAPACK version 1.5 is available
+from SIAM at:
+
+ http://www.ec-securehost.com/SIAM/SE04.html
-To view an HTML version of the Users' Guide please refer to the URL
+To view an HTML version of the Users' Guide for version 1.5, see:
http://www.netlib.org/scalapack/slug/
-
-Prebuilt ScaLAPACK libraries are available for a variety of
-architectures.
- http://www.netlib.org/scalapack/archives/
-
+
A number of technical reports were written during the development of
ScaLAPACK and published as LAPACK Working Notes by the University
-of Tennessee. These working notes are available in postscript and
-pdf format.
+of Tennessee. These working notes are available at:
+
http://www.netlib.org/lapack/lawns/
- http://www.netlib.org/lapack/lawnspdf/
All questions/comments should be directed to scalapack at cs.utk.edu.
@@ -103,32 +101,27 @@ directory structure below:
/ | | | <library.a> | SLmake.inc | | | \
| | | | | | |
| | | | | | |
- INSTALL/ EXAMPLE/ PBLAS/ REDIST/ SRC/ TESTING/ TOOLS/
+ BLACS/ EXAMPLE/ PBLAS/ REDIST/ SRC/ TESTING/ TOOLS/
/ Input \
/ Files & \
/Executables\
-NOTE: It is assumed that the BLAS, BLACSi and LAPACK libraries (and possibly
- MPI or PVM) are available on your machine. These libraries
- are NOT included with this distribution. They can be obtained
- from the respective blas, blacs, mpi, or pvm directory on netlib.
+NOTE: It is assumed that the BLAS and LAPACK libraries (and MPI)
+ are available on your machine. These libraries are NOT included
+ with this distribution, and may be obtained at the sites below.
+
http://www.netlib.org/blas/
http://www.netlib.org/lapack/
- http://www.netlib.org/blacs/
http://www.mcs.anl.gov/mpi/mpich/
http://www.lam-mpi.org/
http://www.open-mpi.org/
- http://www.netlib.org/pvm3/
All ScaLAPACK routines -- driver, computational, and auxiliary -- can be
found in the SRC/ directory. Testing routines and input files can be found
in the TESTING/ directory. All machine-specific parameters and the locations
-of BLAS, BLACSi and LAPACK libraries are specified in the SCALAPACK/SLmake.inc file.
+of BLAS and LAPACK libraries are specified in the SCALAPACK/SLmake.inc file.
This include file is then referenced in all subdirectory Makefiles. Once
the include file has been modified, the entire installation process (including
the building of testing executables) can be performed by typing ``make''
-in the top-level ScaLAPACK directory. For detailed information on the
-installation and testing process, please refer to the "Installation Guide
-for ScaLAPACK" (scalapack_install.ps) in the INSTALL/ directory, or the
-scalapack directory on netlib.
+in the top-level ScaLAPACK directory.
diff --git a/REDIST/CMakeLists.txt b/REDIST/CMakeLists.txt
new file mode 100644
index 0000000..3387cd1
--- /dev/null
+++ b/REDIST/CMakeLists.txt
@@ -0,0 +1,2 @@
+add_subdirectory(SRC)
+add_subdirectory(TESTING)
diff --git a/REDIST/SRC/CMakeLists.txt b/REDIST/SRC/CMakeLists.txt
new file mode 100644
index 0000000..bc01ee6
--- /dev/null
+++ b/REDIST/SRC/CMakeLists.txt
@@ -0,0 +1,20 @@
+set (ALLAUX
+ pgemraux.c)
+
+set (IMRSRC
+ pigemr.c pigemr2.c pitrmr.c pitrmr2.c)
+
+set (SMRSRC
+ psgemr.c psgemr2.c pstrmr.c pstrmr2.c)
+
+set (CMRSRC
+ pcgemr.c pcgemr2.c pctrmr.c pctrmr2.c)
+
+set (DMRSRC
+ pdgemr.c pdgemr2.c pdtrmr.c pdtrmr2.c)
+
+set (ZMRSRC
+ pzgemr.c pzgemr2.c pztrmr.c pztrmr2.c)
+
+set(redist ${ALLAUX} ${IMRSRC} ${SMRSRC} ${CMRSRC} ${DMRSRC} ${ZMRSRC})
+
diff --git a/REDIST/SRC/Makefile b/REDIST/SRC/Makefile
index 2ba932a..0587fa4 100644
--- a/REDIST/SRC/Makefile
+++ b/REDIST/SRC/Makefile
@@ -38,69 +38,51 @@ include ../../SLmake.inc
# Alternatively, the command
# make
# without any arguments creates a library of all four precisions.
-# The name of the library is defined by $(SCALAPACKLIB) in
-# ../../SLmake.inc and is created at the next higher directory level.
+# The name of the library is defined by ../../$(SCALAPACKLIB) in
+# ../../SLmake.inc.
#
# 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
#
#######################################################################
-ALLAUX = \
- pgemraux.o
+ALLAUX = pgemraux.o
-IMRSRC = \
- pigemr.o pigemr2.o pitrmr.o pitrmr2.o
+IMRSRC = pigemr.o pigemr2.o pitrmr.o pitrmr2.o
-SMRSRC = \
- psgemr.o psgemr2.o pstrmr.o pstrmr2.o
+SMRSRC = psgemr.o psgemr2.o pstrmr.o pstrmr2.o
-CMRSRC = \
- pcgemr.o pcgemr2.o pctrmr.o pctrmr2.o
+CMRSRC = pcgemr.o pcgemr2.o pctrmr.o pctrmr2.o
-DMRSRC = \
- pdgemr.o pdgemr2.o pdtrmr.o pdtrmr2.o
+DMRSRC = pdgemr.o pdgemr2.o pdtrmr.o pdtrmr2.o
-ZMRSRC = \
- pzgemr.o pzgemr2.o pztrmr.o pztrmr2.o
+ZMRSRC = pzgemr.o pzgemr2.o pztrmr.o pztrmr2.o
all: integer single complex double complex16
+
lib: all
integer: $(IMRSRC) $(ALLAUX)
- $(ARCH) $(ARCHFLAGS) $(SCALAPACKLIB) $(IMRSRC) $(ALLAUX)
- $(RANLIB) $(SCALAPACKLIB)
+ $(ARCH) $(ARCHFLAGS) ../../$(SCALAPACKLIB) $(IMRSRC) $(ALLAUX)
+ $(RANLIB) ../../$(SCALAPACKLIB)
single: $(SMRSRC) $(ALLAUX)
- $(ARCH) $(ARCHFLAGS) $(SCALAPACKLIB) $(SMRSRC) $(ALLAUX)
- $(RANLIB) $(SCALAPACKLIB)
+ $(ARCH) $(ARCHFLAGS) ../../$(SCALAPACKLIB) $(SMRSRC) $(ALLAUX)
+ $(RANLIB) ../../$(SCALAPACKLIB)
complex: $(CMRSRC) $(ALLAUX)
- $(ARCH) $(ARCHFLAGS) $(SCALAPACKLIB) $(CMRSRC) $(ALLAUX)
- $(RANLIB) $(SCALAPACKLIB)
+ $(ARCH) $(ARCHFLAGS) ../../$(SCALAPACKLIB) $(CMRSRC) $(ALLAUX)
+ $(RANLIB) ../../$(SCALAPACKLIB)
double: $(DMRSRC) $(ALLAUX)
- $(ARCH) $(ARCHFLAGS) $(SCALAPACKLIB) $(DMRSRC) $(ALLAUX)
- $(RANLIB) $(SCALAPACKLIB)
+ $(ARCH) $(ARCHFLAGS) ../../$(SCALAPACKLIB) $(DMRSRC) $(ALLAUX)
+ $(RANLIB) ../../$(SCALAPACKLIB)
complex16: $(ZMRSRC) $(ALLAUX)
- $(ARCH) $(ARCHFLAGS) $(SCALAPACKLIB) $(ZMRSRC) $(ALLAUX)
- $(RANLIB) $(SCALAPACKLIB)
-
-$(ALLAUX): $(FRC)
-$(IMRSRC): $(FRC)
-$(SMRSRC): $(FRC)
-$(CMRSRC): $(FRC)
-$(DMRSRC): $(FRC)
-$(ZMRSRC): $(FRC)
-
-FRC:
- @FRC=$(FRC)
+ $(ARCH) $(ARCHFLAGS) ../../$(SCALAPACKLIB) $(ZMRSRC) $(ALLAUX)
+ $(RANLIB) ../../$(SCALAPACKLIB)
clean :
rm -f *.o
-.c.o : ; $(CC) -c $(CCFLAGS) $(CDEFS) $*.c
+.c.o : ; $(CC) -c $(CDEFS) $(CCFLAGS) $*.c
diff --git a/REDIST/TESTING/CMakeLists.txt b/REDIST/TESTING/CMakeLists.txt
new file mode 100644
index 0000000..20a1258
--- /dev/null
+++ b/REDIST/TESTING/CMakeLists.txt
@@ -0,0 +1,41 @@
+set(CMAKE_RUNTIME_OUTPUT_DIRECTORY ${SCALAPACK_BINARY_DIR}/scalapack/REDIST/TESTING)
+
+file(COPY GEMR2D.dat DESTINATION ${CMAKE_RUNTIME_OUTPUT_DIRECTORY})
+file(COPY TRMR2D.dat DESTINATION ${CMAKE_RUNTIME_OUTPUT_DIRECTORY})
+
+add_executable(xigemr pigemrdrv.c)
+add_executable(xsgemr psgemrdrv.c)
+add_executable(xdgemr pdgemrdrv.c)
+add_executable(xcgemr pcgemrdrv.c)
+add_executable(xzgemr pzgemrdrv.c)
+
+add_executable(xitrmr pitrmrdrv.c)
+add_executable(xstrmr pstrmrdrv.c)
+add_executable(xdtrmr pdtrmrdrv.c)
+add_executable(xctrmr pctrmrdrv.c)
+add_executable(xztrmr pztrmrdrv.c)
+
+target_link_libraries(xigemr scalapack )
+target_link_libraries(xsgemr scalapack )
+target_link_libraries(xdgemr scalapack )
+target_link_libraries(xcgemr scalapack )
+target_link_libraries(xzgemr scalapack )
+
+target_link_libraries(xitrmr scalapack )
+target_link_libraries(xstrmr scalapack )
+target_link_libraries(xdtrmr scalapack )
+target_link_libraries(xctrmr scalapack )
+target_link_libraries(xztrmr scalapack )
+
+#add_test(xigemr ${MPIEXEC} ${MPIEXEC_NUMPROC_FLAG} 4 ./xigemr)
+#add_test(xsgemr ${MPIEXEC} ${MPIEXEC_NUMPROC_FLAG} 4 ./xsgemr)
+#add_test(xdgemr ${MPIEXEC} ${MPIEXEC_NUMPROC_FLAG} 4 ./xdgemr)
+#add_test(xcgemr ${MPIEXEC} ${MPIEXEC_NUMPROC_FLAG} 4 ./xcgemr)
+#add_test(xzgemr ${MPIEXEC} ${MPIEXEC_NUMPROC_FLAG} 4 ./xzgemr)
+
+#add_test(xitrmr ${MPIEXEC} ${MPIEXEC_NUMPROC_FLAG} 4 ./xitrmr)
+#add_test(xstrmr ${MPIEXEC} ${MPIEXEC_NUMPROC_FLAG} 4 ./xstrmr)
+#add_test(xdtrmr ${MPIEXEC} ${MPIEXEC_NUMPROC_FLAG} 4 ./xdtrmr)
+#add_test(xctrmr ${MPIEXEC} ${MPIEXEC_NUMPROC_FLAG} 4 ./xctrmr)
+#add_test(xztrmr ${MPIEXEC} ${MPIEXEC_NUMPROC_FLAG} 4 ./xztrmr)
+
diff --git a/REDIST/TESTING/Makefile b/REDIST/TESTING/Makefile
index 68c8bf3..07a97fd 100644
--- a/REDIST/TESTING/Makefile
+++ b/REDIST/TESTING/Makefile
@@ -16,16 +16,16 @@
include ../../SLmake.inc
-igemrexe = $(REDISTTSTdir)/xigemr
-sgemrexe = $(REDISTTSTdir)/xsgemr
-dgemrexe = $(REDISTTSTdir)/xdgemr
-cgemrexe = $(REDISTTSTdir)/xcgemr
-zgemrexe = $(REDISTTSTdir)/xzgemr
-itrmrexe = $(REDISTTSTdir)/xitrmr
-strmrexe = $(REDISTTSTdir)/xstrmr
-dtrmrexe = $(REDISTTSTdir)/xdtrmr
-ctrmrexe = $(REDISTTSTdir)/xctrmr
-ztrmrexe = $(REDISTTSTdir)/xztrmr
+igemrexe = xigemr
+sgemrexe = xsgemr
+dgemrexe = xdgemr
+cgemrexe = xcgemr
+zgemrexe = xzgemr
+itrmrexe = xitrmr
+strmrexe = xstrmr
+dtrmrexe = xdtrmr
+ctrmrexe = xctrmr
+ztrmrexe = xztrmr
igemr = pigemrdrv.o
sgemr = psgemrdrv.o
@@ -52,68 +52,37 @@ complex: $(cgemrexe) $(ctrmrexe)
complex16: $(zgemrexe) $(ztrmrexe)
-$(TESTINGdir)/GEMR2D.dat: GEMR2D.dat
- cp GEMR2D.dat $(TESTINGdir)
+$(igemrexe): ../../$(SCALAPACKLIB) $(igemr)
+ $(CCLOADER) $(CCLOADFLAGS) -o $(igemrexe) $(igemr) ../../$(SCALAPACKLIB) $(LIBS)
-$(igemrexe): $(SCALAPACKLIB) $(igemr)
- $(CCLOADER) $(CCLOADFLAGS) -o $(igemrexe) $(igemr) $(PRLIBS)
- $(MAKE) $(TESTINGdir)/GEMR2D.dat
+$(sgemrexe): ../../$(SCALAPACKLIB) $(sgemr)
+ $(CCLOADER) $(CCLOADFLAGS) -o $(sgemrexe) $(sgemr) ../../$(SCALAPACKLIB) $(LIBS)
-$(sgemrexe): $(SCALAPACKLIB) $(sgemr)
- $(CCLOADER) $(CCLOADFLAGS) -o $(sgemrexe) $(sgemr) $(PRLIBS)
- $(MAKE) $(TESTINGdir)/GEMR2D.dat
+$(dgemrexe): ../../$(SCALAPACKLIB) $(dgemr)
+ $(CCLOADER) $(CCLOADFLAGS) -o $(dgemrexe) $(dgemr) ../../$(SCALAPACKLIB) $(LIBS)
-$(dgemrexe): $(SCALAPACKLIB) $(dgemr)
- $(CCLOADER) $(CCLOADFLAGS) -o $(dgemrexe) $(dgemr) $(PRLIBS)
- $(MAKE) $(TESTINGdir)/GEMR2D.dat
+$(cgemrexe): ../../$(SCALAPACKLIB) $(cgemr)
+ $(CCLOADER) $(CCLOADFLAGS) -o $(cgemrexe) $(cgemr) ../../$(SCALAPACKLIB) $(LIBS)
-$(cgemrexe): $(SCALAPACKLIB) $(cgemr)
- $(CCLOADER) $(CCLOADFLAGS) -o $(cgemrexe) $(cgemr) $(PRLIBS)
- $(MAKE) $(TESTINGdir)/GEMR2D.dat
+$(zgemrexe): ../../$(SCALAPACKLIB) $(zgemr)
+ $(CCLOADER) $(CCLOADFLAGS) -o $(zgemrexe) $(zgemr) ../../$(SCALAPACKLIB) $(LIBS)
-$(zgemrexe): $(SCALAPACKLIB) $(zgemr)
- $(CCLOADER) $(CCLOADFLAGS) -o $(zgemrexe) $(zgemr) $(PRLIBS)
- $(MAKE) $(TESTINGdir)/GEMR2D.dat
+$(itrmrexe): ../../$(SCALAPACKLIB) $(itrmr)
+ $(CCLOADER) $(CCLOADFLAGS) -o $(itrmrexe) $(itrmr) ../../$(SCALAPACKLIB) $(LIBS)
-$(TESTINGdir)/TRMR2D.dat: TRMR2D.dat
- cp TRMR2D.dat $(TESTINGdir)
+$(strmrexe): ../../$(SCALAPACKLIB) $(strmr)
+ $(CCLOADER) $(CCLOADFLAGS) -o $(strmrexe) $(strmr) ../../$(SCALAPACKLIB) $(LIBS)
-$(itrmrexe): $(SCALAPACKLIB) $(itrmr)
- $(CCLOADER) $(CCLOADFLAGS) -o $(itrmrexe) $(itrmr) $(PRLIBS)
- $(MAKE) $(TESTINGdir)/TRMR2D.dat
+$(dtrmrexe): ../../$(SCALAPACKLIB) $(dtrmr)
+ $(CCLOADER) $(CCLOADFLAGS) -o $(dtrmrexe) $(dtrmr) ../../$(SCALAPACKLIB) $(LIBS)
-$(strmrexe): $(SCALAPACKLIB) $(strmr)
- $(CCLOADER) $(CCLOADFLAGS) -o $(strmrexe) $(strmr) $(PRLIBS)
- $(MAKE) $(TESTINGdir)/TRMR2D.dat
+$(ctrmrexe): ../../$(SCALAPACKLIB) $(ctrmr)
+ $(CCLOADER) $(CCLOADFLAGS) -o $(ctrmrexe) $(ctrmr) ../../$(SCALAPACKLIB) $(LIBS)
-$(dtrmrexe): $(SCALAPACKLIB) $(dtrmr)
- $(CCLOADER) $(CCLOADFLAGS) -o $(dtrmrexe) $(dtrmr) $(PRLIBS)
- $(MAKE) $(TESTINGdir)/TRMR2D.dat
-
-$(ctrmrexe): $(SCALAPACKLIB) $(ctrmr)
- $(CCLOADER) $(CCLOADFLAGS) -o $(ctrmrexe) $(ctrmr) $(PRLIBS)
- $(MAKE) $(TESTINGdir)/TRMR2D.dat
-
-$(ztrmrexe): $(SCALAPACKLIB) $(ztrmr)
- $(CCLOADER) $(CCLOADFLAGS) -o $(ztrmrexe) $(ztrmr) $(PRLIBS)
- $(MAKE) $(TESTINGdir)/TRMR2D.dat
-
-$(igemr): $(FRC)
-$(sgemr): $(FRC)
-$(dgemr): $(FRC)
-$(cgemr): $(FRC)
-$(zgemr): $(FRC)
-
-$(itrmr): $(FRC)
-$(strmr): $(FRC)
-$(dtrmr): $(FRC)
-$(ctrmr): $(FRC)
-$(ztrmr): $(FRC)
-
-FRC:
- @FRC=$(FRC)
+$(ztrmrexe): ../../$(SCALAPACKLIB) $(ztrmr)
+ $(CCLOADER) $(CCLOADFLAGS) -o $(ztrmrexe) $(ztrmr) ../../$(SCALAPACKLIB) $(LIBS)
clean :
- rm -f *.o
+ rm -f *.o x*
-.c.o : ; $(CC) -c $(CCFLAGS) $(CDEFS) $*.c
+.c.o : ; $(CC) -c $(CDEFS) $(CCFLAGS) $*.c
diff --git a/SLmake.inc b/SLmake.inc
deleted file mode 100644
index f1f07bc..0000000
--- a/SLmake.inc
+++ /dev/null
@@ -1,145 +0,0 @@
-############################################################################
-#
-# Program: ScaLAPACK
-#
-# Module: SLmake.inc
-#
-# Purpose: Top-level Definitions
-#
-# Creation date: February 15, 2000
-#
-# Modified:
-#
-# Send bug reports, comments or suggestions to scalapack at cs.utk.edu
-#
-############################################################################
-#
-SHELL = /bin/sh
-#
-# The complete path to the top level of ScaLAPACK directory, usually
-# $(HOME)/SCALAPACK
-#
-home = $(BASEDIR)
-#
-# The platform identifier to suffix to the end of library names
-#
-PLAT = LINUX
-#
-# BLACS setup. All version need the debug level (0 or 1),
-# and the directory where the BLACS libraries are
-#
-BLACSDBGLVL = 0
-BLACSdir = /usr/lib
-#
-# MPI setup; tailor to your system if using MPIBLACS
-#
-ifeq ($(MPI),lam)
-USEMPI = -DUsingMpiBlacs
-ifeq ($(BUILD),static)
-SMPLIB = -lmpi
-BLACSFINIT = /usr/lib/libblacsF77init-lam.a
-BLACSCINIT = /usr/lib/libblacsCinit-lam.a
-BLACSLIB = /usr/lib/libblacs-lam.a
-else
-SMPLIB = -lmpi
-BLACSFINIT = -lblacsF77init-lam
-BLACSCINIT = -lblacsCinit-lam
-BLACSLIB = -lblacs-lam
-endif
-TESTINGdir = $(home)/TESTING
-endif
-ifeq ($(MPI),mpich)
-USEMPI = -DUsingMpiBlacs
-ifeq ($(BUILD),static)
-SMPLIB = /usr/lib/mpich/lib/libmpich.a
-BLACSFINIT = /usr/lib/libblacsF77init-mpich.a
-BLACSCINIT = /usr/lib/libblacsCinit-mpich.a
-BLACSLIB = /usr/lib/libblacs-mpich.a
-else
-SMPLIB = /usr/lib/mpich/lib/libmpich.a
-BLACSFINIT = -lblacsF77init-mpich
-BLACSCINIT = -lblacsCinit-mpich
-BLACSLIB = -lblacs-mpich
-endif
-TESTINGdir = $(home)/TESTING
-endif
-ifeq ($(MPI),pvm)
-USEMPI =
-ifeq ($(BUILD),static)
-SMPLIB = /usr/lib/libpvm3.a
-BLACSFINIT =
-BLACSCINIT =
-BLACSLIB = /usr/lib/libblacs-pvm.a
-else
-SMPLIB = -lpvm3
-BLACSFINIT =
-BLACSCINIT =
-BLACSLIB = -lblacs-pvm
-endif
-#TESTINGdir = $(HOME)/pvm3/bin/$(PLAT)
-TESTINGdir = $(home)/TESTING
-endif
-
-CBLACSLIB = $(BLACSCINIT) $(BLACSLIB) $(BLACSCINIT)
-FBLACSLIB = $(BLACSFINIT) $(BLACSLIB) $(BLACSFINIT)
-
-#
-# The directories to find the various pieces of ScaLapack
-#
-PBLASdir = $(home)/PBLAS
-SRCdir = $(home)/SRC
-TESTdir = $(home)/TESTING
-PBLASTSTdir = $(TESTINGdir)
-TOOLSdir = $(home)/TOOLS
-REDISTdir = $(home)/REDIST
-REDISTTSTdir = $(TESTINGdir)
-#
-# The fortran and C compilers, loaders, and their flags
-#
-F77 = g77
-#F77 = /usr/local/pgi/linux86/bin/pgf77
-CC = gcc
-NOOPT = -w -fno-globals -fno-f90 -fugly-complex $(FPIC)
-F77FLAGS = -Wall -O6 -funroll-all-loops -ffast-math $(NOOPT)
-CCFLAGS = -Wall $(FPIC) -O6 -funroll-all-loops -ffast-math
-SRCFLAG =
-F77LOADER = $(F77)
-ifeq ($(MPI),mpich)
-CCLOADER = $(F77)
-SYSLIBS = -lm
-else
-CCLOADER = $(CC)
-SYSLIBS = -lm
-endif
-F77LOADFLAGS =
-CCLOADFLAGS =
-#
-# C preprocessor defs for compilation
-# (-DNoChange, -DAdd_, -DUpCase, or -Df77IsF2C)
-#
-CDEFS = -Df77IsF2C -DNO_IEEE $(USEMPI)
-#
-# The archiver and the flag(s) to use when building archive (library)
-# Also the ranlib routine. If your system has no ranlib, set RANLIB = echo
-#
-ARCH = ar
-ARCHFLAGS = cr
-RANLIB = ranlib
-#
-# The name of the libraries to be created/linked to
-#
-SCALAPACKLIB = $(home)/scalapack_$(MPI).a
-BLASLIB = -llapack-3 -lblas-3
-# BLASLIB = /usr/local/lib/libf77blas.a /usr/local/lib/libatlas.a
-#
-ifeq ($(BUILD),static)
-PBLIBS = $(SCALAPACKLIB) $(FBLACSLIB) $(BLASLIB) $(SMPLIB)
-PRLIBS = $(SCALAPACKLIB) $(CBLACSLIB) $(SMPLIB) $(BLASLIB) $(SYSLIBS)
-RLIBS = $(SCALAPACKLIB) $(FBLACSLIB) $(CBLACSLIB) $(BLASLIB) $(SMPLIB)
-LIBS = $(PBLIBS)
-else
-PBLIBS = -L $(BASEDIR) -lscalapack-$(MPI) $(FBLACSLIB) $(BLASLIB) $(SMPLIB)
-PRLIBS = -L $(BASEDIR) -lscalapack-$(MPI) $(CBLACSLIB) $(SMPLIB) $(BLASLIB) $(SYSLIBS)
-RLIBS = -L $(BASEDIR) -lscalapack-$(MPI) $(FBLACSLIB) $(CBLACSLIB) $(BLASLIB) $(SMPLIB)
-LIBS = $(PBLIBS)
-endif
diff --git a/SLmake.inc.example b/SLmake.inc.example
new file mode 100644
index 0000000..3a867c3
--- /dev/null
+++ b/SLmake.inc.example
@@ -0,0 +1,60 @@
+############################################################################
+#
+# Program: ScaLAPACK
+#
+# Module: SLmake.inc
+#
+# Purpose: Top-level Definitions
+#
+# Creation date: February 15, 2000
+#
+# Modified: October 13, 2011
+#
+# Send bug reports, comments or suggestions to scalapack at cs.utk.edu
+#
+############################################################################
+#
+# C preprocessor definitions: set CDEFS to one of the following:
+#
+# -DNoChange (fortran subprogram names are lower case without any suffix)
+# -DUpCase (fortran subprogram names are upper case without any suffix)
+# -DAdd_ (fortran subprogram names are lower case with "_" appended)
+
+CDEFS = -DAdd_
+
+#
+# The fortran and C compilers, loaders, and their flags
+#
+
+FC = mpif90
+CC = mpicc
+NOOPT = -O0
+FCFLAGS = -O3
+CCFLAGS = -O3
+FCLOADER = $(FC)
+CCLOADER = $(CC)
+FCLOADFLAGS = $(FCFLAGS)
+CCLOADFLAGS = $(CCFLAGS)
+
+#
+# The archiver and the flag(s) to use when building archive (library)
+# Also the ranlib routine. If your system has no ranlib, set RANLIB = echo
+#
+
+ARCH = ar
+ARCHFLAGS = cr
+RANLIB = ranlib
+
+#
+# The name of the ScaLAPACK library to be created
+#
+
+SCALAPACKLIB = libscalapack.a
+
+#
+# BLAS, LAPACK (and possibly other) libraries needed for linking test programs
+#
+
+BLASLIB = -lblas
+LAPACKLIB = -llapack
+LIBS = $(LAPACKLIB) $(BLASLIB)
diff --git a/SRC/CMakeLists.txt b/SRC/CMakeLists.txt
new file mode 100644
index 0000000..cf8738b
--- /dev/null
+++ b/SRC/CMakeLists.txt
@@ -0,0 +1,148 @@
+set (ALLAUX pjlaenv.f pilaenvx.f piparmq.f pilaver.f pmpim2.f pmpcol.f)
+set (ALLAUX-C pbchkvect.c getpbbuf.c pcrot.c pslaiect.c pdlaiect.c pzrot.c slamov.c clamov.c dlamov.c zlamov.c)
+
+set (SCLAUX
+ pslabad.f pslaed0.f pslaed1.f pslaed2.f pslaed3.f pslaedz.f
+ pslamch.f pslared1d.f pslasrt.f psstebz.f psstedc.f slapst.f slasrt2.f
+ sstein2.f
+ slar1va.f slarrb2.f slarrd2.f slarre2.f slarre2a.f slarrf2.f
+ slarrv2.f sstegr2.f sstegr2a.f sstegr2b.f)
+
+set (DZLAUX
+ pdlabad.f pdlaed0.f pdlaed1.f pdlaed2.f pdlaed3.f pdlaedz.f
+ pdlamch.f pdlared1d.f pdlasrt.f pdstebz.f pdstedc.f dlapst.f dlasrt2.f
+ dstein2.f
+ dlar1va.f dlarrb2.f dlarrd2.f dlarre2.f dlarre2a.f dlarrf2.f
+ dlarrv2.f dstegr2.f dstegr2a.f dstegr2b.f)
+
+set (SLASRC
+ psdbsv.f psdbtrf.f psdbtrs.f psdbtrsv.f
+ psdtsv.f psdttrf.f psdttrs.f psdttrsv.f
+ psgbsv.f psgbtrf.f psgbtrs.f
+ psgebd2.f psgebrd.f psgecon.f psgeequ.f psgehd2.f psgehrd.f
+ psgelq2.f psgelqf.f psgels.f psgeql2.f psgeqlf.f psgeqpf.f psgeqr2.f
+ psgeqrf.f psgerfs.f psgerq2.f psgerqf.f
+ psgesv.f psgesvd.f psgesvx.f psgetf2.f psgetrf.f psgetri.f psgetrs.f
+ psggqrf.f psggrqf.f pslabrd.f
+ pslacon.f pslacp2.f pslacpy.f pslahrd.f pslange.f pslanhs.f pslansy.f
+ pslantr.f pslapiv.f pslapv2.f pslaqge.f pslaqsy.f pslarf.f pslarfb.f
+ pslarfg.f pslarft.f pslase2.f pslaset.f pslascl.f pslassq.f pslaswp.f
+ pslatra.f pslatrd.f pslatrs.f pslauu2.f pslauum.f psorg2l.f psorg2r.f
+ psorgl2.f psorglq.f psorgql.f psorgqr.f psorgr2.f
+ psorgrq.f psorm2l.f psorm2r.f psormbr.f psormhr.f psorml2.f
+ psormlq.f psormql.f psormqr.f psormr2.f psormrq.f psormtr.f pspocon.f
+ pspbsv.f pspbtrf.f pspbtrs.f pspbtrsv.f
+ psptsv.f pspttrf.f pspttrs.f pspttrsv.f
+ pspoequ.f psporfs.f psposv.f psposvx.f pspotf2.f pspotrf.f pspotri.f
+ pspotrs.f psrscl.f psstein.f pssyev.f pssyevd.f pssyevx.f
+ pssygs2.f pssygst.f
+ pssygvx.f pssyngst.f pssyntrd.f pssyttrd.f pssytd2.f pssytrd.f
+ pstrti2.f pstrtri.f pstrtrs.f
+ pslaevswp.f
+ pslarzb.f pslarzt.f pslarz.f pslatrz.f pstzrzf.f psormr3.f psormrz.f
+ pslahqr.f pslaconsb.f pslacp3.f pslawil.f
+ pslasmsub.f pslared2d.f pslamr1d.f slaref.f slamsh.f slasorte.f ssteqr2.f
+ sdbtf2.f sdbtrf.f sdttrf.f sdttrsv.f spttrsv.f strmvt.f pssyevr.f
+ bslaapp.f bslaexc.f bstrexc.f pstrord.f pstrsen.f psgebal.f pshseqr.f
+ pslamve.f pslaqr0.f pslaqr1.f pslaqr2.f pslaqr3.f pslaqr4.f pslaqr5.f
+ psrot.f slaqr6.f)
+
+set (CLASRC
+ pcdbsv.f pcdbtrf.f pcdbtrs.f pcdbtrsv.f
+ pcdtsv.f pcdttrf.f pcdttrs.f pcdttrsv.f
+ pcgbsv.f pcgbtrf.f pcgbtrs.f
+ pcgebd2.f pcgebrd.f pcgecon.f pcgeequ.f pcgehd2.f pcgehrd.f
+ pcgelq2.f pcgelqf.f pcgels.f pcgeql2.f pcgeqlf.f pcgeqpf.f pcgeqr2.f
+ pcgeqrf.f pcgerfs.f pcgerq2.f pcgerqf.f
+ pcgesv.f pcgesvd.f pcgesvx.f pcgetf2.f pcgetrf.f pcgetri.f pcgetrs.f
+ pcggqrf.f
+ pcggrqf.f pcheev.f pcheevd.f pcheevx.f pchegs2.f pchegst.f pchegvx.f
+ pchengst.f pchentrd.f pchettrd.f pchetd2.f
+ pchetrd.f pclabrd.f pclacon.f pclacgv.f pclacp2.f pclacpy.f pclahrd.f
+ pclahqr.f pclaconsb.f pclasmsub.f pclacp3.f pclawil.f
+ pclange.f pclanhe.f pclanhs.f pclansy.f pclantr.f pclapiv.f pclapv2.f
+ pclaqge.f pclaqsy.f pclarf.f pclarfb.f pclarfc.f pclarfg.f pclarft.f
+ pclascl.f pclase2.f pclaset.f pclassq.f pclaswp.f pclatra.f pclatrd.f
+ pclatrs.f pclauu2.f pclauum.f pcpocon.f pcpoequ.f pcporfs.f pcposv.f
+ pcpbsv.f pcpbtrf.f pcpbtrs.f pcpbtrsv.f
+ pcptsv.f pcpttrf.f pcpttrs.f pcpttrsv.f
+ pcposvx.f pcpotf2.f pcpotrf.f pcpotri.f pcpotrs.f pcsrscl.f pcstein.f
+ pctrevc.f pctrti2.f pctrtri.f pctrtrs.f pcung2l.f pcung2r.f
+ pcungl2.f pcunglq.f pcungql.f pcungqr.f pcungr2.f pcungrq.f
+ pcunm2l.f pcunm2r.f pcunmbr.f pcunmhr.f pcunml2.f pcunmlq.f
+ pcunmql.f pcunmqr.f pcunmr2.f pcunmrq.f pcunmtr.f
+ pclaevswp.f
+ pclarzb.f pclarzt.f pclarz.f pclarzc.f pclatrz.f pctzrzf.f
+ pclattrs.f
+ pcunmr3.f pcunmrz.f pcmax1.f pscsum1.f pclamr1d.f
+ cdbtf2.f cdbtrf.f cdttrf.f cdttrsv.f cpttrsv.f csteqr2.f ctrmvt.f
+ clamsh.f claref.f clanv2.f clahqr2.f pcheevr.f)
+
+set (DLASRC
+ pddbsv.f pddbtrf.f pddbtrs.f pddbtrsv.f
+ pddtsv.f pddttrf.f pddttrs.f pddttrsv.f
+ pdgbsv.f pdgbtrf.f pdgbtrs.f
+ pdgebd2.f pdgebrd.f pdgecon.f pdgeequ.f pdgehd2.f pdgehrd.f
+ pdgelq2.f pdgelqf.f pdgels.f pdgeql2.f pdgeqlf.f pdgeqpf.f pdgeqr2.f
+ pdgeqrf.f pdgerfs.f pdgerq2.f pdgerqf.f
+ pdgesv.f pdgesvd.f pdgesvx.f pdgetf2.f pdgetrf.f pdgetri.f pdgetrs.f
+ pdggqrf.f pdggrqf.f pdlabrd.f
+ pdlacon.f pdlacp2.f pdlacpy.f pdlahrd.f pdlange.f pdlanhs.f pdlansy.f
+ pdlantr.f pdlapiv.f pdlapv2.f pdlaqge.f pdlaqsy.f pdlarf.f pdlarfb.f
+ pdlarfg.f pdlarft.f pdlase2.f pdlaset.f pdlascl.f pdlassq.f pdlaswp.f
+ pdlatra.f pdlatrd.f pdlatrs.f pdlauu2.f pdlauum.f pdorg2l.f pdorg2r.f
+ pdorgl2.f pdorglq.f pdorgql.f pdorgqr.f pdorgr2.f
+ pdorgrq.f pdorm2l.f pdorm2r.f pdormbr.f pdormhr.f pdorml2.f
+ pdormlq.f pdormql.f pdormqr.f pdormr2.f pdormrq.f pdormtr.f pdpocon.f
+ pdpbsv.f pdpbtrf.f pdpbtrs.f pdpbtrsv.f
+ pdptsv.f pdpttrf.f pdpttrs.f pdpttrsv.f
+ pdpoequ.f pdporfs.f pdposv.f pdposvx.f pdpotf2.f pdpotrf.f pdpotri.f
+ pdpotrs.f pdrscl.f pdstein.f pdsyev.f pdsyevd.f pdsyevx.f
+ pdsygs2.f pdsygst.f
+ pdsygvx.f pdsyngst.f pdsyntrd.f pdsyttrd.f pdsytd2.f pdsytrd.f pdtrti2.f
+ pdtrtri.f pdtrtrs.f
+ pdlaevswp.f
+ pdlarzb.f pdlarzt.f pdlarz.f pdlatrz.f pdtzrzf.f pdormr3.f pdormrz.f
+ pdlahqr.f pdlaconsb.f pdlacp3.f pdlawil.f
+ pdlasmsub.f pdlared2d.f pdlamr1d.f dlaref.f dlamsh.f dlasorte.f dsteqr2.f
+ ddbtf2.f ddbtrf.f ddttrf.f ddttrsv.f dpttrsv.f dtrmvt.f pdsyevr.f
+ bdlaapp.f bdlaexc.f bdtrexc.f dlaqr6.f pdtrord.f
+ pdtrsen.f pdgebal.f pdhseqr.f pdlamve.f pdlaqr0.f pdlaqr1.f pdlaqr2.f
+ pdlaqr3.f pdlaqr4.f pdlaqr5.f pdrot.f)
+
+set (ZLASRC
+ pzdbsv.f pzdbtrf.f pzdbtrs.f pzdbtrsv.f
+ pzdtsv.f pzdttrf.f pzdttrs.f pzdttrsv.f
+ pzgbsv.f pzgbtrf.f pzgbtrs.f
+ pzgebd2.f pzgebrd.f pzgecon.f pzgeequ.f pzgehd2.f pzgehrd.f
+ pzgelq2.f pzgelqf.f pzgels.f pzgeql2.f pzgeqlf.f pzgeqpf.f pzgeqr2.f
+ pzgeqrf.f pzgerfs.f pzgerq2.f pzgerqf.f
+ pzgesv.f pzgesvd.f pzgesvx.f pzgetf2.f pzgetrf.f pzgetri.f pzgetrs.f
+ pzggqrf.f
+ pzggrqf.f pzheev.f pzheevd.f pzheevx.f pzhegs2.f pzhegst.f pzhegvx.f
+ pzhengst.f pzhentrd.f pzhettrd.f pzhetd2.f
+ pzhetrd.f pzlabrd.f pzlacon.f pzlacgv.f pzlacp2.f pzlacpy.f pzlahrd.f
+ pzlahqr.f pzlaconsb.f pzlasmsub.f pzlacp3.f pzlawil.f
+ pzlange.f pzlanhe.f pzlanhs.f pzlansy.f pzlantr.f pzlapiv.f pzlapv2.f
+ pzlaqge.f pzlaqsy.f pzlarf.f pzlarfb.f pzlarfc.f pzlarfg.f pzlarft.f
+ pzlascl.f pzlase2.f pzlaset.f pzlassq.f pzlaswp.f pzlatra.f pzlatrd.f
+ pzlattrs.f
+ pzlatrs.f pzlauu2.f pzlauum.f pzpocon.f pzpoequ.f pzporfs.f pzposv.f
+ pzpbsv.f pzpbtrf.f pzpbtrs.f pzpbtrsv.f
+ pzptsv.f pzpttrf.f pzpttrs.f pzpttrsv.f
+ pzposvx.f pzpotf2.f pzpotrf.f pzpotri.f pzpotrs.f pzdrscl.f pzstein.f
+ pztrevc.f pztrti2.f pztrtri.f pztrtrs.f pzung2l.f pzung2r.f
+ pzungl2.f pzunglq.f pzungql.f pzungqr.f pzungr2.f pzungrq.f
+ pzunm2l.f pzunm2r.f pzunmbr.f pzunmhr.f pzunml2.f pzunmlq.f
+ pzunmql.f pzunmqr.f pzunmr2.f pzunmrq.f pzunmtr.f
+ pzlaevswp.f
+ pzlarzb.f pzlarzt.f pzlarz.f pzlarzc.f pzlatrz.f pztzrzf.f
+ pzunmr3.f pzunmrz.f pzmax1.f pdzsum1.f pzlamr1d.f
+ zdbtf2.f zdbtrf.f zdttrf.f zdttrsv.f zpttrsv.f zsteqr2.f ztrmvt.f
+ zlamsh.f zlaref.f zlanv2.f zlahqr2.f pzheevr.f)
+
+set(src
+ ${ALLAUX} ${SCLAUX} ${DZLAUX}
+ ${SLASRC} ${CLASRC} ${DLASRC} ${ZLASRC} )
+set(src-C
+ ${ALLAUX-C} )
diff --git a/SRC/Makefile b/SRC/Makefile
index 3ca8680..12e6f0a 100644
--- a/SRC/Makefile
+++ b/SRC/Makefile
@@ -30,7 +30,7 @@ include ../SLmake.inc
#
# The library can be set up to include routines for any combination
# of the four precisions. First, modify the ARCH, ARCHFLAGS, RANLIB,
-# F77 and F77FLAGS definitions in ../SLmake.inc to match your library
+# FC and FCFLAGS definitions in ../SLmake.inc to match your library
# archiver, compiler and the options to be used.
# Then to create or add to the library, enter make followed by one or
# more of the precisions desired. Some examples:
@@ -40,28 +40,29 @@ include ../SLmake.inc
# Alternatively, the command
# make
# without any arguments creates a library of all four precisions.
-# The name of the library is defined by $(SCALAPACKLIB) in
+# The name of the library is defined by ../$(SCALAPACKLIB) in
# ../SLmake.inc 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
#
#######################################################################
-ALLAUX = pjlaenv.o
+ALLAUX = pjlaenv.o pbchkvect.o getpbbuf.o pilaenvx.o piparmq.o pilaver.o pmpim2.o pmpcol.o
SCLAUX = \
pslabad.o pslaed0.o pslaed1.o pslaed2.o pslaed3.o pslaedz.o pslaiect.o \
pslamch.o pslared1d.o pslasrt.o psstebz.o psstedc.o slapst.o slasrt2.o \
- sstein2.o pbchkvect.o getpbbuf.o
+ sstein2.o \
+ slar1va.o slarrb2.o slarrd2.o slarre2.o slarre2a.o slarrf2.o \
+ slarrv2.o sstegr2.o sstegr2a.o sstegr2b.o slamov.o clamov.o
DZLAUX = \
pdlabad.o pdlaed0.o pdlaed1.o pdlaed2.o pdlaed3.o pdlaedz.o pdlaiect.o \
pdlamch.o pdlared1d.o pdlasrt.o pdstebz.o pdstedc.o dlapst.o dlasrt2.o \
- dstein2.o pbchkvect.o getpbbuf.o
+ dstein2.o \
+ dlar1va.o dlarrb2.o dlarrd2.o dlarre2.o dlarre2a.o dlarrf2.o \
+ dlarrv2.o dstegr2.o dstegr2a.o dstegr2b.o dlamov.o zlamov.o
SLASRC = \
psdbsv.o psdbtrf.o psdbtrs.o psdbtrsv.o \
@@ -90,8 +91,11 @@ SLASRC = \
pslarzb.o pslarzt.o pslarz.o pslatrz.o pstzrzf.o psormr3.o psormrz.o \
pslahqr.o pslaconsb.o pslacp3.o pslawil.o \
pslasmsub.o pslared2d.o pslamr1d.o slaref.o slamsh.o slasorte.o ssteqr2.o \
- sdbtf2.o sdbtrf.o sdttrf.o sdttrsv.o spttrsv.o strmvt.o
-
+ sdbtf2.o sdbtrf.o sdttrf.o sdttrsv.o spttrsv.o strmvt.o pssyevr.o \
+ bslaapp.o bslaexc.o bstrexc.o pstrord.o pstrsen.o psgebal.o pshseqr.o \
+ pslamve.o pslaqr0.o pslaqr1.o pslaqr2.o pslaqr3.o pslaqr4.o pslaqr5.o \
+ psrot.o slaqr6.o
+
CLASRC = \
pcdbsv.o pcdbtrf.o pcdbtrs.o pcdbtrsv.o \
pcdtsv.o pcdttrf.o pcdttrs.o pcdttrsv.o \
@@ -121,7 +125,7 @@ CLASRC = \
pclattrs.o \
pcunmr3.o pcunmrz.o pcmax1.o pscsum1.o pclamr1d.o \
cdbtf2.o cdbtrf.o cdttrf.o cdttrsv.o cpttrsv.o csteqr2.o ctrmvt.o \
- clamsh.o claref.o clanv2.o clahqr2.o
+ clamsh.o claref.o clanv2.o clahqr2.o pcheevr.o
DLASRC = \
pddbsv.o pddbtrf.o pddbtrs.o pddbtrsv.o \
@@ -150,7 +154,10 @@ DLASRC = \
pdlarzb.o pdlarzt.o pdlarz.o pdlatrz.o pdtzrzf.o pdormr3.o pdormrz.o \
pdlahqr.o pdlaconsb.o pdlacp3.o pdlawil.o \
pdlasmsub.o pdlared2d.o pdlamr1d.o dlaref.o dlamsh.o dlasorte.o dsteqr2.o \
- ddbtf2.o ddbtrf.o ddttrf.o ddttrsv.o dpttrsv.o dtrmvt.o
+ ddbtf2.o ddbtrf.o ddttrf.o ddttrsv.o dpttrsv.o dtrmvt.o pdsyevr.o \
+ bdlaapp.o bdlaexc.o bdtrexc.o dlaqr6.o pdtrord.o \
+ pdtrsen.o pdgebal.o pdhseqr.o pdlamve.o pdlaqr0.o pdlaqr1.o pdlaqr2.o \
+ pdlaqr3.o pdlaqr4.o pdlaqr5.o pdrot.o
ZLASRC = \
pzdbsv.o pzdbtrf.o pzdbtrs.o pzdbtrsv.o \
@@ -181,43 +188,42 @@ ZLASRC = \
pzlarzb.o pzlarzt.o pzlarz.o pzlarzc.o pzlatrz.o pztzrzf.o \
pzunmr3.o pzunmrz.o pzmax1.o pdzsum1.o pzlamr1d.o \
zdbtf2.o zdbtrf.o zdttrf.o zdttrsv.o zpttrsv.o zsteqr2.o ztrmvt.o \
- zlamsh.o zlaref.o zlanv2.o zlahqr2.o
+ zlamsh.o zlaref.o zlanv2.o zlahqr2.o pzheevr.o
all: single complex double complex16
single: $(SLASRC) $(SCLAUX) $(ALLAUX)
- $(ARCH) $(ARCHFLAGS) $(SCALAPACKLIB) $(SLASRC) $(SCLAUX) \
+ $(ARCH) $(ARCHFLAGS) ../$(SCALAPACKLIB) $(SLASRC) $(SCLAUX) \
$(ALLAUX)
- $(RANLIB) $(SCALAPACKLIB)
+ $(RANLIB) ../$(SCALAPACKLIB)
complex: $(CLASRC) $(SCLAUX) $(ALLAUX)
- $(ARCH) $(ARCHFLAGS) $(SCALAPACKLIB) $(CLASRC) $(SCLAUX) \
+ $(ARCH) $(ARCHFLAGS) ../$(SCALAPACKLIB) $(CLASRC) $(SCLAUX) \
$(ALLAUX)
- $(RANLIB) $(SCALAPACKLIB)
+ $(RANLIB) ../$(SCALAPACKLIB)
double: $(DLASRC) $(DZLAUX) $(ALLAUX)
- $(ARCH) $(ARCHFLAGS) $(SCALAPACKLIB) $(DLASRC) $(DZLAUX) \
+ $(ARCH) $(ARCHFLAGS) ../$(SCALAPACKLIB) $(DLASRC) $(DZLAUX) \
$(ALLAUX)
- $(RANLIB) $(SCALAPACKLIB)
+ $(RANLIB) ../$(SCALAPACKLIB)
complex16: $(ZLASRC) $(DZLAUX) $(ALLAUX)
- $(ARCH) $(ARCHFLAGS) $(SCALAPACKLIB) $(ZLASRC) $(DZLAUX) \
+ $(ARCH) $(ARCHFLAGS) ../$(SCALAPACKLIB) $(ZLASRC) $(DZLAUX) \
$(ALLAUX)
- $(RANLIB) $(SCALAPACKLIB)
-
-$(SCLAUX): $(FRC)
-$(DZLAUX): $(FRC)
-$(SLASRC): $(FRC)
-$(CLASRC): $(FRC)
-$(DLASRC): $(FRC)
-$(ZLASRC): $(FRC)
+ $(RANLIB) ../$(SCALAPACKLIB)
-FRC:
- @FRC=$(FRC)
+slamov.o: slamov.c
+dlamov.o: dlamov.c
+clamov.o: clamov.c
+zlamov.o: zlamov.c
+slamov.o dlamov.o clamov.o zlamov.o: lamov.h
+ $(CC) -c $(CFLAGS) $(CDEFS) $(@:.o=.c) -o $@
clean :
rm -f *.o
-.f.o : ; $(F77) -c $(F77FLAGS) $*.f
+.f.o :
+ $(FC) -c $(FCFLAGS) $*.f
-.c.o : ; $(CC) -c $(CCFLAGS) $(SRCFLAG) $(CDEFS) $*.c
+.c.o :
+ $(CC) -c $(CDEFS) $(CCFLAGS) $*.c
diff --git a/SRC/bdlaapp.f b/SRC/bdlaapp.f
new file mode 100644
index 0000000..44c17aa
--- /dev/null
+++ b/SRC/bdlaapp.f
@@ -0,0 +1,167 @@
+ SUBROUTINE BDLAAPP( ISIDE, M, N, NB, A, LDA, NITRAF, ITRAF,
+ $ DTRAF, WORK )
+ IMPLICIT NONE
+*
+* .. Scalar Arguments ..
+ INTEGER ISIDE, LDA, M, N, NB, NITRAF
+* ..
+* .. Array Arguments ..
+ INTEGER ITRAF( * )
+ DOUBLE PRECISION A( LDA, * ), DTRAF( * ), WORK( * )
+*
+*
+* Purpose
+* =======
+*
+* BDLAAPP computes
+*
+* B = Q**T * A or B = A * Q,
+*
+* where A is an M-by-N matrix and Q is an orthogonal matrix represented
+* by the parameters in the arrays ITRAF and DTRAF as described in
+* BDTREXC.
+*
+* This is an auxiliary routine called by BDTRSEN.
+*
+* Arguments
+* =========
+*
+* ISIDE (input) INTEGER
+* Specifies whether Q multiplies A from the left or right as
+* follows:
+* = 0: compute B = Q**T * A;
+* = 1: compute B = A * Q.
+*
+* M (input) INTEGER
+* The number of rows of A.
+*
+* N (input) INTEGER
+* The number of columns of A.
+*
+* NB (input) INTEGER
+* If ISIDE = 0, the Q is applied block column-wise to the rows
+* of A and NB specifies the maximal width of the block columns.
+* If ISIDE = 1, this variable is not referenced.
+*
+* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
+* On entry, the matrix A.
+* On exit, A is overwritten by B.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,N).
+*
+* NITRAF (input) INTEGER
+* Length of the array ITRAF. NITRAF >= 0.
+*
+* ITRAF (input) INTEGER array, length NITRAF
+* List of parameters for representing the transformation
+* matrix Q, see BDTREXC.
+*
+* DTRAF (output) DOUBLE PRECISION array, length k, where
+* List of parameters for representing the transformation
+* matrix Q, see BDTREXC.
+*
+* WORK (workspace) DOUBLE PRECISION array, dimension (N)
+*
+* =====================================================================
+*
+
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, ONE
+ PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
+* ..
+* .. Local Scalars ..
+ INTEGER I, IT, J, NNB, PD
+ DOUBLE PRECISION TAU
+* ..
+* .. External Subroutines ..
+ EXTERNAL DLARFX, DROT
+* .. Intrinsic Functions ..
+ INTRINSIC MIN
+* ..
+* .. Executable Statements ..
+*
+* Quick return if possible.
+*
+ IF( M.LE.0 .OR. N.LE.0 )
+ $ RETURN
+*
+ IF( ISIDE.EQ.0 ) THEN
+*
+* Apply Q from left.
+*
+ DO 20 J = 1, N, NB
+ PD = 1
+ NNB = MIN( NB, N - J + 1 )
+ DO 10 I = 1, NITRAF
+ IT = ITRAF(I)
+ IF( IT.LE.M ) THEN
+*
+* Apply Givens rotation.
+*
+ CALL DROT( NNB, A(IT,J), LDA, A(IT+1,J), LDA,
+ $ DTRAF(PD), DTRAF(PD+1) )
+ PD = PD + 2
+ ELSE IF( IT.LE.2*M ) THEN
+*
+* Apply Householder reflector of first kind.
+*
+ TAU = DTRAF(PD)
+ DTRAF(PD) = ONE
+ CALL DLARFX( 'Left', 3, NNB, DTRAF(PD), TAU,
+ $ A(IT-M,J), LDA, WORK )
+ DTRAF(PD) = TAU
+ PD = PD + 3
+ ELSE
+*
+* Apply Householder reflector of second kind.
+*
+ TAU = DTRAF(PD+2)
+ DTRAF(PD+2) = ONE
+ CALL DLARFX( 'Left', 3, NNB, DTRAF(PD), TAU,
+ $ A(IT-2*M,J), LDA, WORK )
+ DTRAF(PD+2) = TAU
+ PD = PD + 3
+ END IF
+ 10 CONTINUE
+ 20 CONTINUE
+ ELSE
+ PD = 1
+ DO 30 I = 1, NITRAF
+ IT = ITRAF(I)
+ IF( IT.LE.N ) THEN
+*
+* Apply Givens rotation.
+*
+ CALL DROT( M, A(1,IT), 1, A(1,IT+1), 1, DTRAF(PD),
+ $ DTRAF(PD+1) )
+ PD = PD + 2
+ ELSE IF( IT.LE.2*N ) THEN
+*
+* Apply Householder reflector of first kind.
+*
+ TAU = DTRAF(PD)
+ DTRAF(PD) = ONE
+ CALL DLARFX( 'Right', M, 3, DTRAF(PD), TAU, A(1,IT-N),
+ $ LDA, WORK )
+ DTRAF(PD) = TAU
+ PD = PD + 3
+ ELSE
+*
+* Apply Householder reflector of second kind.
+*
+ TAU = DTRAF(PD+2)
+ DTRAF(PD+2) = ONE
+ CALL DLARFX( 'Right', M, 3, DTRAF(PD), TAU, A(1,IT-2*N),
+ $ LDA, WORK )
+ DTRAF(PD+2) = TAU
+ PD = PD + 3
+ END IF
+ 30 CONTINUE
+ END IF
+*
+ RETURN
+*
+* End of BDLAAPP
+*
+ END
diff --git a/SRC/bdlaexc.f b/SRC/bdlaexc.f
new file mode 100644
index 0000000..28a8c94
--- /dev/null
+++ b/SRC/bdlaexc.f
@@ -0,0 +1,367 @@
+ SUBROUTINE BDLAEXC( N, T, LDT, J1, N1, N2, ITRAF, DTRAF, WORK,
+ $ INFO )
+ IMPLICIT NONE
+*
+* -- ScaLAPACK auxiliary routine (version 2.0.2) --
+* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver
+* May 1 2012
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, J1, LDT, N, N1, N2
+* ..
+* .. Array Arguments ..
+ INTEGER ITRAF( * )
+ DOUBLE PRECISION DTRAF( * ), T( LDT, * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* BDLAEXC swaps adjacent diagonal blocks T11 and T22 of order 1 or 2 in
+* an upper quasi-triangular matrix T by an orthogonal similarity
+* transformation.
+*
+* In contrast to the LAPACK routine DLAEXC, the orthogonal
+* transformation matrix Q is not explicitly constructed but
+* represented by paramaters contained in the arrays ITRAF and DTRAF,
+* see the description of BDTREXC for more details.
+*
+* T must be in Schur canonical form, that is, block upper triangular
+* with 1-by-1 and 2-by-2 diagonal blocks; each 2-by-2 diagonal block
+* has its diagonal elemnts equal and its off-diagonal elements of
+* opposite sign.
+*
+* Arguments
+* =========
+*
+* N (input) INTEGER
+* The order of the matrix T. N >= 0.
+*
+* T (input/output) DOUBLE PRECISION array, dimension (LDT,N)
+* On entry, the upper quasi-triangular matrix T, in Schur
+* canonical form.
+* On exit, the updated matrix T, again in Schur canonical form.
+*
+* LDT (input) INTEGER
+* The leading dimension of the array T. LDT >= max(1,N).
+*
+* J1 (input) INTEGER
+* The index of the first row of the first block T11.
+*
+* N1 (input) INTEGER
+* The order of the first block T11. N1 = 0, 1 or 2.
+*
+* N2 (input) INTEGER
+* The order of the second block T22. N2 = 0, 1 or 2.
+*
+* ITRAF (output) INTEGER array, length k, where
+* k = 1, if N1+N2 = 2;
+* k = 2, if N1+N2 = 3;
+* k = 4, if N1+N2 = 4.
+* List of parameters for representing the transformation
+* matrix Q, see BDTREXC.
+*
+* DTRAF (output) DOUBLE PRECISION array, length k, where
+* k = 2, if N1+N2 = 2;
+* k = 5, if N1+N2 = 3;
+* k = 10, if N1+N2 = 4.
+* List of parameters for representing the transformation
+* matrix Q, see BDTREXC.
+*
+* WORK (workspace) DOUBLE PRECISION array, dimension (N)
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* = 1: the transformed matrix T would be too far from Schur
+* form; the blocks are not swapped and T and Q are
+* unchanged.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, ONE
+ PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
+ DOUBLE PRECISION TEN
+ PARAMETER ( TEN = 1.0D+1 )
+ INTEGER LDD, LDX
+ PARAMETER ( LDD = 4, LDX = 2 )
+* ..
+* .. Local Scalars ..
+ INTEGER IERR, J2, J3, J4, K, LD, LI, 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 ), X( LDX, 2 )
+* ..
+* .. External Functions ..
+ DOUBLE PRECISION DLAMCH, DLANGE
+ EXTERNAL DLAMCH, DLANGE
+* ..
+* .. External Subroutines ..
+ EXTERNAL DLAMOV, 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
+*
+ ITRAF( 1 ) = J1
+ DTRAF( 1 ) = CS
+ DTRAF( 2 ) = SN
+*
+ ELSE
+*
+* Swapping involves at least one 2-by-2 block.
+*
+* Copy the diagonal block of order N1+N2 to the local array D
+* and compute its norm.
+*
+ ND = N1 + N2
+ CALL DLAMOV( '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, * )
+*
+ DTRAF( 1 ) = SCALE
+ DTRAF( 2 ) = X( 1, 1 )
+ DTRAF( 3 ) = X( 1, 2 )
+ CALL DLARFG( 3, DTRAF( 3 ), DTRAF, 1, TAU )
+ DTRAF( 3 ) = ONE
+ T11 = T( J1, J1 )
+*
+* Perform swap provisionally on diagonal block in D.
+*
+ CALL DLARFX( 'Left', 3, 3, DTRAF, TAU, D, LDD, WORK )
+ CALL DLARFX( 'Right', 3, 3, DTRAF, 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( 'Left', 3, N-J1+1, DTRAF, TAU, T( J1, J1 ), LDT,
+ $ WORK )
+ CALL DLARFX( 'Right', J2, 3, DTRAF, TAU, T( 1, J1 ), LDT,
+ $ WORK )
+*
+ T( J3, J1 ) = ZERO
+ T( J3, J2 ) = ZERO
+ T( J3, J3 ) = T11
+*
+ ITRAF( 1 ) = 2*N + J1
+ LI = 2
+ DTRAF( 3 ) = TAU
+ LD = 4
+ GO TO 40
+*
+ 20 CONTINUE
+*
+* N1 = 2, N2 = 1: generate elementary reflector H so that:
+*
+* H ( -X11 ) = ( * )
+* ( -X21 ) = ( 0 )
+* ( scale ) = ( 0 )
+*
+ DTRAF( 1 ) = -X( 1, 1 )
+ DTRAF( 2 ) = -X( 2, 1 )
+ DTRAF( 3 ) = SCALE
+ CALL DLARFG( 3, DTRAF( 1 ), DTRAF( 2 ), 1, TAU )
+ DTRAF( 1 ) = ONE
+ T33 = T( J3, J3 )
+*
+* Perform swap provisionally on diagonal block in D.
+*
+ CALL DLARFX( 'Left', 3, 3, DTRAF, TAU, D, LDD, WORK )
+ CALL DLARFX( 'Right', 3, 3, DTRAF, 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( 'Right', J3, 3, DTRAF, TAU, T( 1, J1 ), LDT,
+ $ WORK )
+ CALL DLARFX( 'Left', 3, N-J1, DTRAF, TAU, T( J1, J2 ), LDT,
+ $ WORK )
+*
+ T( J1, J1 ) = T33
+ T( J2, J1 ) = ZERO
+ T( J3, J1 ) = ZERO
+*
+ ITRAF( 1 ) = N + J1
+ LI = 2
+ DTRAF( 1 ) = TAU
+ LD = 4
+ 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 )
+*
+ DTRAF( 1 ) = -X( 1, 1 )
+ DTRAF( 2 ) = -X( 2, 1 )
+ DTRAF( 3 ) = SCALE
+ CALL DLARFG( 3, DTRAF( 1 ), DTRAF( 2 ), 1, TAU1 )
+ DTRAF( 1 ) = ONE
+*
+ TEMP = -TAU1*( X( 1, 2 )+DTRAF( 2 )*X( 2, 2 ) )
+ DTRAF( 4 ) = -TEMP*DTRAF( 2 ) - X( 2, 2 )
+ DTRAF( 5 ) = -TEMP*DTRAF( 3 )
+ DTRAF( 6 ) = SCALE
+ CALL DLARFG( 3, DTRAF( 4 ), DTRAF( 5 ), 1, TAU2 )
+ DTRAF( 4 ) = ONE
+*
+* Perform swap provisionally on diagonal block in D.
+*
+ CALL DLARFX( 'Left', 3, 4, DTRAF, TAU1, D, LDD, WORK )
+ CALL DLARFX( 'Right', 4, 3, DTRAF, TAU1, D, LDD, WORK )
+ CALL DLARFX( 'Left', 3, 4, DTRAF( 4 ), TAU2, D( 2, 1 ), LDD,
+ $ WORK )
+ CALL DLARFX( 'Right', 4, 3, DTRAF( 4 ), 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( 'Left', 3, N-J1+1, DTRAF, TAU1, T( J1, J1 ), LDT,
+ $ WORK )
+ CALL DLARFX( 'Right', J4, 3, DTRAF, TAU1, T( 1, J1 ), LDT,
+ $ WORK )
+ CALL DLARFX( 'Left', 3, N-J1+1, DTRAF( 4 ), TAU2, T( J2, J1 ),
+ $ LDT, WORK )
+ CALL DLARFX( 'Right', J4, 3, DTRAF( 4 ), TAU2, T( 1, J2 ), LDT,
+ $ WORK )
+*
+ T( J3, J1 ) = ZERO
+ T( J3, J2 ) = ZERO
+ T( J4, J1 ) = ZERO
+ T( J4, J2 ) = ZERO
+*
+ ITRAF( 1 ) = N + J1
+ ITRAF( 2 ) = N + J2
+ LI = 3
+ DTRAF( 1 ) = TAU1
+ DTRAF( 4 ) = TAU2
+ LD = 7
+ GO TO 40
+*
+ 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 )
+ ITRAF( LI ) = J1
+ LI = LI + 1
+ DTRAF( LD ) = CS
+ DTRAF( LD+1 ) = SN
+ LD = LD + 2
+ 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 )
+ ITRAF( LI ) = J3
+ DTRAF( LD ) = CS
+ DTRAF( LD+1 ) = SN
+ END IF
+*
+ END IF
+ RETURN
+*
+* Exit with INFO = 1 if swap was rejected.
+*
+ 50 CONTINUE
+ INFO = 1
+ RETURN
+*
+* End of BDLAEXC
+*
+ END
diff --git a/SRC/bdtrexc.f b/SRC/bdtrexc.f
new file mode 100644
index 0000000..ccb10f9
--- /dev/null
+++ b/SRC/bdtrexc.f
@@ -0,0 +1,564 @@
+ SUBROUTINE BDTREXC( N, T, LDT, IFST, ILST, NITRAF, ITRAF,
+ $ NDTRAF, DTRAF, WORK, INFO )
+ IMPLICIT NONE
+*
+*
+* -- LAPACK routine (version 3.0) --
+* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
+* Courant Institute, Argonne National Lab, and Rice University
+* March 31, 1993
+*
+* .. Scalar Arguments ..
+ INTEGER IFST, ILST, INFO, LDT, N, NDTRAF, NITRAF
+* ..
+* .. Array Arguments ..
+ INTEGER ITRAF( * )
+ DOUBLE PRECISION DTRAF( * ), T( LDT, * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* BDTREXC 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. In contrast to the LAPACK routine DTREXC,
+* the orthogonal matrix Z is not explicitly constructed but
+* represented by paramaters contained in the arrays ITRAF and DTRAF,
+* see further details.
+*
+* T must be in Schur canonical form (as returned by DHSEQR), that is,
+* block upper triangular with 1-by-1 and 2-by-2 diagonal blocks; each
+* 2-by-2 diagonal block has its diagonal elements equal and its
+* off-diagonal elements of opposite sign.
+*
+* Arguments
+* =========
+*
+* N (input) INTEGER
+* The order of the matrix T. N >= 0.
+*
+* T (input/output) DOUBLE PRECISION array, dimension (LDT,N)
+* On entry, the upper quasi-triangular matrix T, in Schur
+* Schur canonical form.
+* On exit, the reordered upper quasi-triangular matrix, again
+* in Schur canonical form.
+*
+* LDT (input) INTEGER
+* The leading dimension of the array T. LDT >= max(1,N).
+*
+* IFST (input/output) INTEGER
+* ILST (input/output) INTEGER
+* Specify the reordering of the diagonal blocks of T.
+* The block with row index IFST is moved to row ILST, by a
+* sequence of transpositions between adjacent blocks.
+* On exit, if IFST pointed on entry to the second row of a
+* 2-by-2 block, it is changed to point to the first row; ILST
+* always points to the first row of the block in its final
+* position (which may differ from its input value by +1 or -1).
+* 1 <= IFST <= N; 1 <= ILST <= N.
+*
+* NITRAF (input/output) INTEGER
+* On entry, length of the array ITRAF.
+* As a minimum requirement, NITRAF >= max(1,|ILST-IFST|).
+* If there are 2-by-2 blocks in T then NITRAF must be larger;
+* a safe choice is NITRAF >= max(1,2*|ILST-IFST|).
+* On exit, actual length of the array ITRAF.
+*
+* ITRAF (output) INTEGER array, length NITRAF
+* List of parameters for representing the transformation
+* matrix Z, see further details.
+*
+* NDTRAF (input/output) INTEGER
+* On entry, length of the array DTRAF.
+* As a minimum requirement, NDTRAF >= max(1,2*|ILST-IFST|).
+* If there are 2-by-2 blocks in T then NDTRAF must be larger;
+* a safe choice is NDTRAF >= max(1,5*|ILST-IFST|).
+* On exit, actual length of the array DTRAF.
+*
+* DTRAF (output) DOUBLE PRECISION array, length NDTRAF
+* List of parameters for representing the transformation
+* matrix Z, see further details.
+*
+* WORK (workspace) DOUBLE PRECISION array, dimension (N)
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+* = 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.
+* = 2: the 2 by 2 block to be reordered split into two 1 by 1
+* blocks and the second block failed to swap with an
+* adjacent block. ILST points to the first row of the
+* current position of the whole block being moved.
+*
+* Further Details
+* ===============
+*
+* The orthogonal transformation matrix Z is a product of NITRAF
+* elementary orthogonal transformations. The parameters defining these
+* transformations are stored in the arrays ITRAF and DTRAF as follows:
+*
+* Consider the i-th transformation acting on rows/columns POS,
+* POS+1, ... If this transformation is
+*
+* (1) a Givens rotation with cosine C and sine S then
+*
+* ITRAF(i) = POS,
+* DTRAF(j) = C, DTRAF(j+1) = S;
+*
+* (2) a Householder reflector H = I - tau * v * v' with
+* v = [ 1; v2; v3 ] then
+*
+* ITRAF(i) = N + POS,
+* DTRAF(j) = tau, DTRAF(j+1) = v2, DTRAF(j+2) = v3;
+*
+* (3) a Householder reflector H = I - tau * v * v' with
+* v = [ v1; v2; 1 ] then
+*
+* ITRAF(i) = 2*N + POS,
+* DTRAF(j) = v1, DTRAF(j+1) = v2, DTRAF(j+2) = tau;
+*
+* Note that the parameters in DTRAF are stored consecutively.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO
+ PARAMETER ( ZERO = 0.0D+0 )
+ INTEGER DLNGTH(3), ILNGTH(3)
+* ..
+* .. Local Scalars ..
+ INTEGER CDTRAF, CITRAF, LDTRAF, LITRAF, HERE, I, NBF,
+ $ NBL, NBNEXT
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL BDLAEXC, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX
+* .. Data Statements ..
+c DATA ( ILNGTH(I), I = 1, 3 ) / 1, 2, 4 /
+c DATA ( DLNGTH(I), I = 1, 3 ) / 2, 5, 10 /
+ DATA ILNGTH(1)/1/, ILNGTH(2)/2/, ILNGTH(3)/4/
+ DATA DLNGTH(1)/2/, DLNGTH(2)/5/, DLNGTH(3)/10/
+* ..
+* .. Executable Statements ..
+*
+* Decode and test the input arguments.
+*
+ INFO = 0
+ IF( N.LT.0 ) THEN
+ INFO = -1
+ ELSE IF( LDT.LT.MAX( 1, N ) ) THEN
+ INFO = -3
+ ELSE IF( IFST.LT.1 .OR. IFST.GT.N ) THEN
+ INFO = -4
+ ELSE IF( ILST.LT.1 .OR. ILST.GT.N ) THEN
+ INFO = -5
+ ELSE IF ( NITRAF.LT.MAX( 1, ABS( ILST-IFST ) ) ) THEN
+ INFO = -6
+ ELSE IF ( NDTRAF.LT.MAX( 1, 2*ABS( ILST-IFST ) ) ) 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
+ CITRAF = 1
+ CDTRAF = 1
+*
+* 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
+*
+ LITRAF = ILNGTH(NBF+NBNEXT-1)
+ LDTRAF = DLNGTH(NBF+NBNEXT-1)
+ IF( CITRAF+LITRAF-1.GT.NITRAF ) THEN
+ INFO = -6
+ CALL XERBLA( 'BDTREXC', -INFO )
+ RETURN
+ END IF
+ IF( CDTRAF+LDTRAF-1.GT.NDTRAF ) THEN
+ INFO = -8
+ CALL XERBLA( 'BDTREXC', -INFO )
+ RETURN
+ END IF
+ CALL BDLAEXC( N, T, LDT, HERE, NBF, NBNEXT, ITRAF(CITRAF),
+ $ DTRAF(CDTRAF), WORK, INFO )
+ IF( INFO.NE.0 ) THEN
+ ILST = HERE
+ NITRAF = CITRAF - 1
+ NDTRAF = CDTRAF - 1
+ RETURN
+ END IF
+ CITRAF = CITRAF + LITRAF
+ CDTRAF = CDTRAF + LDTRAF
+ 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
+ LITRAF = ILNGTH(NBNEXT)
+ LDTRAF = DLNGTH(NBNEXT)
+ IF( CITRAF+LITRAF-1.GT.NITRAF ) THEN
+ INFO = -6
+ CALL XERBLA( 'BDTREXC', -INFO )
+ RETURN
+ END IF
+ IF( CDTRAF+LDTRAF-1.GT.NDTRAF ) THEN
+ INFO = -8
+ CALL XERBLA( 'BDTREXC', -INFO )
+ RETURN
+ END IF
+ CALL BDLAEXC( N, T, LDT, HERE+1, 1, NBNEXT, ITRAF(CITRAF),
+ $ DTRAF(CDTRAF), WORK, INFO )
+ IF( INFO.NE.0 ) THEN
+ ILST = HERE
+ NITRAF = CITRAF - 1
+ NDTRAF = CDTRAF - 1
+ RETURN
+ END IF
+ CITRAF = CITRAF + LITRAF
+ CDTRAF = CDTRAF + LDTRAF
+*
+ IF( NBNEXT.EQ.1 ) THEN
+*
+* Swap two 1 by 1 blocks, no problems possible
+*
+ LITRAF = ILNGTH(1)
+ LDTRAF = DLNGTH(1)
+ IF( CITRAF+LITRAF-1.GT.NITRAF ) THEN
+ INFO = -6
+ CALL XERBLA( 'BDTREXC', -INFO )
+ RETURN
+ END IF
+ IF( CDTRAF+LDTRAF-1.GT.NDTRAF ) THEN
+ INFO = -8
+ CALL XERBLA( 'BDTREXC', -INFO )
+ RETURN
+ END IF
+ CALL BDLAEXC( N, T, LDT, HERE, 1, NBNEXT, ITRAF(CITRAF),
+ $ DTRAF(CDTRAF), WORK, INFO )
+ CITRAF = CITRAF + LITRAF
+ CDTRAF = CDTRAF + LDTRAF
+ 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
+*
+ LITRAF = ILNGTH(2)
+ LDTRAF = DLNGTH(2)
+ IF( CITRAF+LITRAF-1.GT.NITRAF ) THEN
+ INFO = -6
+ CALL XERBLA( 'BDTREXC', -INFO )
+ RETURN
+ END IF
+ IF( CDTRAF+LDTRAF-1.GT.NDTRAF ) THEN
+ INFO = -8
+ CALL XERBLA( 'BDTREXC', -INFO )
+ RETURN
+ END IF
+ CALL BDLAEXC( N, T, LDT, HERE, 1, NBNEXT,
+ $ ITRAF(CITRAF), DTRAF(CDTRAF), WORK,
+ $ INFO )
+ IF( INFO.NE.0 ) THEN
+ INFO = 2
+ ILST = HERE
+ NITRAF = CITRAF - 1
+ NDTRAF = CDTRAF - 1
+ RETURN
+ END IF
+ CITRAF = CITRAF + LITRAF
+ CDTRAF = CDTRAF + LDTRAF
+ HERE = HERE + 2
+ ELSE
+*
+* 2 by 2 Block did split
+*
+ LITRAF = ILNGTH(1)
+ LDTRAF = DLNGTH(1)
+ IF( CITRAF+2*LITRAF-1.GT.NITRAF ) THEN
+ INFO = -6
+ CALL XERBLA( 'BDTREXC', -INFO )
+ RETURN
+ END IF
+ IF( CDTRAF+2*LDTRAF-1.GT.NDTRAF ) THEN
+ INFO = -8
+ CALL XERBLA( 'BDTREXC', -INFO )
+ RETURN
+ END IF
+ CALL BDLAEXC( N, T, LDT, HERE, 1, 1, ITRAF(CITRAF),
+ $ DTRAF(CDTRAF), WORK, INFO )
+ CITRAF = CITRAF + LITRAF
+ CDTRAF = CDTRAF + LDTRAF
+ CALL BDLAEXC( N, T, LDT, HERE+1, 1, 1, ITRAF(CITRAF),
+ $ DTRAF(CDTRAF), WORK, INFO )
+ CITRAF = CITRAF + LITRAF
+ CDTRAF = CDTRAF + LDTRAF
+ 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
+*
+ LITRAF = ILNGTH(NBF+NBNEXT-1)
+ LDTRAF = DLNGTH(NBF+NBNEXT-1)
+ IF( CITRAF+LITRAF-1.GT.NITRAF ) THEN
+ INFO = -6
+ CALL XERBLA( 'BDTREXC', -INFO )
+ RETURN
+ END IF
+ IF( CDTRAF+LDTRAF-1.GT.NDTRAF ) THEN
+ INFO = -8
+ CALL XERBLA( 'BDTREXC', -INFO )
+ RETURN
+ END IF
+ CALL BDLAEXC( N, T, LDT, HERE-NBNEXT, NBNEXT, NBF,
+ $ ITRAF(CITRAF), DTRAF(CDTRAF), WORK, INFO )
+ IF( INFO.NE.0 ) THEN
+ ILST = HERE
+ NITRAF = CITRAF - 1
+ NDTRAF = CDTRAF - 1
+ RETURN
+ END IF
+ CITRAF = CITRAF + LITRAF
+ CDTRAF = CDTRAF + LDTRAF
+ 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
+ LITRAF = ILNGTH(NBNEXT)
+ LDTRAF = DLNGTH(NBNEXT)
+ IF( CITRAF+LITRAF-1.GT.NITRAF ) THEN
+ INFO = -6
+ CALL XERBLA( 'BDTREXC', -INFO )
+ RETURN
+ END IF
+ IF( CDTRAF+LDTRAF-1.GT.NDTRAF ) THEN
+ INFO = -8
+ CALL XERBLA( 'BDTREXC', -INFO )
+ RETURN
+ END IF
+ CALL BDLAEXC( N, T, LDT, HERE-NBNEXT, NBNEXT, 1,
+ $ ITRAF(CITRAF), DTRAF(CDTRAF), WORK, INFO )
+ IF( INFO.NE.0 ) THEN
+ ILST = HERE
+ NITRAF = CITRAF - 1
+ NDTRAF = CDTRAF - 1
+ RETURN
+ END IF
+ CITRAF = CITRAF + LITRAF
+ CDTRAF = CDTRAF + LDTRAF
+*
+ IF( NBNEXT.EQ.1 ) THEN
+*
+* Swap two 1 by 1 blocks, no problems possible
+*
+ LITRAF = ILNGTH(1)
+ LDTRAF = DLNGTH(1)
+ IF( CITRAF+LITRAF-1.GT.NITRAF ) THEN
+ INFO = -6
+ CALL XERBLA( 'BDTREXC', -INFO )
+ RETURN
+ END IF
+ IF( CDTRAF+LDTRAF-1.GT.NDTRAF ) THEN
+ INFO = -8
+ CALL XERBLA( 'BDTREXC', -INFO )
+ RETURN
+ END IF
+ CALL BDLAEXC( N, T, LDT, HERE, NBNEXT, 1, ITRAF(CITRAF),
+ $ DTRAF(CDTRAF), WORK, INFO )
+ CITRAF = CITRAF + LITRAF
+ CDTRAF = CDTRAF + LDTRAF
+ 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
+*
+ LITRAF = ILNGTH(2)
+ LDTRAF = DLNGTH(2)
+ IF( CITRAF+LITRAF-1.GT.NITRAF ) THEN
+ INFO = -6
+ CALL XERBLA( 'BDTREXC', -INFO )
+ RETURN
+ END IF
+ IF( CDTRAF+LDTRAF-1.GT.NDTRAF ) THEN
+ INFO = -8
+ CALL XERBLA( 'BDTREXC', -INFO )
+ RETURN
+ END IF
+ CALL BDLAEXC( N, T, LDT, HERE-1, 2, 1, ITRAF(CITRAF),
+ $ DTRAF(CDTRAF), WORK, INFO )
+ IF( INFO.NE.0 ) THEN
+ INFO = 2
+ ILST = HERE
+ NITRAF = CITRAF - 1
+ NDTRAF = CDTRAF - 1
+ RETURN
+ END IF
+ CITRAF = CITRAF + LITRAF
+ CDTRAF = CDTRAF + LDTRAF
+ HERE = HERE - 2
+ ELSE
+*
+* 2 by 2 Block did split
+*
+ LITRAF = ILNGTH(1)
+ LDTRAF = DLNGTH(1)
+ IF( CITRAF+2*LITRAF-1.GT.NITRAF ) THEN
+ INFO = -6
+ CALL XERBLA( 'BDTREXC', -INFO )
+ RETURN
+ END IF
+ IF( CDTRAF+2*LDTRAF-1.GT.NDTRAF ) THEN
+ INFO = -8
+ CALL XERBLA( 'BDTREXC', -INFO )
+ RETURN
+ END IF
+ CALL BDLAEXC( N, T, LDT, HERE, 1, 1, ITRAF(CITRAF),
+ $ DTRAF(CDTRAF), WORK, INFO )
+ CITRAF = CITRAF + LITRAF
+ CDTRAF = CDTRAF + LDTRAF
+ CALL BDLAEXC( N, T, LDT, HERE-1, 1, 1, ITRAF(CITRAF),
+ $ DTRAF(CDTRAF), WORK, INFO )
+ CITRAF = CITRAF + LITRAF
+ CDTRAF = CDTRAF + LDTRAF
+ HERE = HERE - 2
+ END IF
+ END IF
+ END IF
+ IF( HERE.GT.ILST )
+ $ GO TO 20
+ END IF
+ ILST = HERE
+ NITRAF = CITRAF - 1
+ NDTRAF = CDTRAF - 1
+*
+ RETURN
+*
+* End of BDTREXC
+*
+ END
diff --git a/SRC/bslaapp.f b/SRC/bslaapp.f
new file mode 100644
index 0000000..5abe5ce
--- /dev/null
+++ b/SRC/bslaapp.f
@@ -0,0 +1,167 @@
+ SUBROUTINE BSLAAPP( ISIDE, M, N, NB, A, LDA, NITRAF, ITRAF,
+ $ DTRAF, WORK )
+ IMPLICIT NONE
+*
+* .. Scalar Arguments ..
+ INTEGER ISIDE, LDA, M, N, NB, NITRAF
+* ..
+* .. Array Arguments ..
+ INTEGER ITRAF( * )
+ REAL A( LDA, * ), DTRAF( * ), WORK( * )
+*
+*
+* Purpose
+* =======
+*
+* BSLAAPP computes
+*
+* B = Q**T * A or B = A * Q,
+*
+* where A is an M-by-N matrix and Q is an orthogonal matrix represented
+* by the parameters in the arrays ITRAF and DTRAF as described in
+* BSTREXC.
+*
+* This is an auxiliary routine called by BDTRSEN.
+*
+* Arguments
+* =========
+*
+* ISIDE (input) INTEGER
+* Specifies whether Q multiplies A from the left or right as
+* follows:
+* = 0: compute B = Q**T * A;
+* = 1: compute B = A * Q.
+*
+* M (input) INTEGER
+* The number of rows of A.
+*
+* N (input) INTEGER
+* The number of columns of A.
+*
+* NB (input) INTEGER
+* If ISIDE = 0, the Q is applied block column-wise to the rows
+* of A and NB specifies the maximal width of the block columns.
+* If ISIDE = 1, this variable is not referenced.
+*
+* A (input/output) REAL array, dimension (LDA,N)
+* On entry, the matrix A.
+* On exit, A is overwritten by B.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,N).
+*
+* NITRAF (input) INTEGER
+* Length of the array ITRAF. NITRAF >= 0.
+*
+* ITRAF (input) INTEGER array, length NITRAF
+* List of parameters for representing the transformation
+* matrix Q, see BSTREXC.
+*
+* DTRAF (output) REAL array, length k, where
+* List of parameters for representing the transformation
+* matrix Q, see BSTREXC.
+*
+* WORK (workspace) REAL array, dimension (N)
+*
+* =====================================================================
+*
+
+* .. Parameters ..
+ REAL ZERO, ONE
+ PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
+* ..
+* .. Local Scalars ..
+ INTEGER I, IT, J, NNB, PD
+ REAL TAU
+* ..
+* .. External Subroutines ..
+ EXTERNAL SLARFX, SROT
+* .. Intrinsic Functions ..
+ INTRINSIC MIN
+* ..
+* .. Executable Statements ..
+*
+* Quick return if possible.
+*
+ IF( M.LE.0 .OR. N.LE.0 )
+ $ RETURN
+*
+ IF( ISIDE.EQ.0 ) THEN
+*
+* Apply Q from left.
+*
+ DO 20 J = 1, N, NB
+ PD = 1
+ NNB = MIN( NB, N - J + 1 )
+ DO 10 I = 1, NITRAF
+ IT = ITRAF(I)
+ IF( IT.LE.M ) THEN
+*
+* Apply Givens rotation.
+*
+ CALL SROT( NNB, A(IT,J), LDA, A(IT+1,J), LDA,
+ $ DTRAF(PD), DTRAF(PD+1) )
+ PD = PD + 2
+ ELSE IF( IT.LE.2*M ) THEN
+*
+* Apply Householder reflector of first kind.
+*
+ TAU = DTRAF(PD)
+ DTRAF(PD) = ONE
+ CALL SLARFX( 'Left', 3, NNB, DTRAF(PD), TAU,
+ $ A(IT-M,J), LDA, WORK )
+ DTRAF(PD) = TAU
+ PD = PD + 3
+ ELSE
+*
+* Apply Householder reflector of second kind.
+*
+ TAU = DTRAF(PD+2)
+ DTRAF(PD+2) = ONE
+ CALL SLARFX( 'Left', 3, NNB, DTRAF(PD), TAU,
+ $ A(IT-2*M,J), LDA, WORK )
+ DTRAF(PD+2) = TAU
+ PD = PD + 3
+ END IF
+ 10 CONTINUE
+ 20 CONTINUE
+ ELSE
+ PD = 1
+ DO 30 I = 1, NITRAF
+ IT = ITRAF(I)
+ IF( IT.LE.N ) THEN
+*
+* Apply Givens rotation.
+*
+ CALL SROT( M, A(1,IT), 1, A(1,IT+1), 1, DTRAF(PD),
+ $ DTRAF(PD+1) )
+ PD = PD + 2
+ ELSE IF( IT.LE.2*N ) THEN
+*
+* Apply Householder reflector of first kind.
+*
+ TAU = DTRAF(PD)
+ DTRAF(PD) = ONE
+ CALL SLARFX( 'Right', M, 3, DTRAF(PD), TAU, A(1,IT-N),
+ $ LDA, WORK )
+ DTRAF(PD) = TAU
+ PD = PD + 3
+ ELSE
+*
+* Apply Householder reflector of second kind.
+*
+ TAU = DTRAF(PD+2)
+ DTRAF(PD+2) = ONE
+ CALL SLARFX( 'Right', M, 3, DTRAF(PD), TAU, A(1,IT-2*N),
+ $ LDA, WORK )
+ DTRAF(PD+2) = TAU
+ PD = PD + 3
+ END IF
+ 30 CONTINUE
+ END IF
+*
+ RETURN
+*
+* End of BSLAAPP
+*
+ END
diff --git a/SRC/bslaexc.f b/SRC/bslaexc.f
new file mode 100644
index 0000000..c2d4f58
--- /dev/null
+++ b/SRC/bslaexc.f
@@ -0,0 +1,367 @@
+ SUBROUTINE BSLAEXC( N, T, LDT, J1, N1, N2, ITRAF, DTRAF, WORK,
+ $ INFO )
+ IMPLICIT NONE
+*
+* -- ScaLAPACK auxiliary routine (version 2.0.2) --
+* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver
+* May 1 2012
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, J1, LDT, N, N1, N2
+* ..
+* .. Array Arguments ..
+ INTEGER ITRAF( * )
+ REAL DTRAF( * ), T( LDT, * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* BSLAEXC swaps adjacent diagonal blocks T11 and T22 of order 1 or 2 in
+* an upper quasi-triangular matrix T by an orthogonal similarity
+* transformation.
+*
+* In contrast to the LAPACK routine DLAEXC, the orthogonal
+* transformation matrix Q is not explicitly constructed but
+* represented by paramaters contained in the arrays ITRAF and DTRAF,
+* see the description of BSTREXC for more details.
+*
+* T must be in Schur canonical form, that is, block upper triangular
+* with 1-by-1 and 2-by-2 diagonal blocks; each 2-by-2 diagonal block
+* has its diagonal elemnts equal and its off-diagonal elements of
+* opposite sign.
+*
+* Arguments
+* =========
+*
+* N (input) INTEGER
+* The order of the matrix T. N >= 0.
+*
+* T (input/output) REAL array, dimension (LDT,N)
+* On entry, the upper quasi-triangular matrix T, in Schur
+* canonical form.
+* On exit, the updated matrix T, again in Schur canonical form.
+*
+* LDT (input) INTEGER
+* The leading dimension of the array T. LDT >= max(1,N).
+*
+* J1 (input) INTEGER
+* The index of the first row of the first block T11.
+*
+* N1 (input) INTEGER
+* The order of the first block T11. N1 = 0, 1 or 2.
+*
+* N2 (input) INTEGER
+* The order of the second block T22. N2 = 0, 1 or 2.
+*
+* ITRAF (output) INTEGER array, length k, where
+* k = 1, if N1+N2 = 2;
+* k = 2, if N1+N2 = 3;
+* k = 4, if N1+N2 = 4.
+* List of parameters for representing the transformation
+* matrix Q, see BSTREXC.
+*
+* DTRAF (output) REAL array, length k, where
+* k = 2, if N1+N2 = 2;
+* k = 5, if N1+N2 = 3;
+* k = 10, if N1+N2 = 4.
+* List of parameters for representing the transformation
+* matrix Q, see BSTREXC.
+*
+* WORK (workspace) REAL array, dimension (N)
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* = 1: the transformed matrix T would be too far from Schur
+* form; the blocks are not swapped and T and Q are
+* unchanged.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ZERO, ONE
+ PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
+ REAL TEN
+ PARAMETER ( TEN = 10.0 )
+ INTEGER LDD, LDX
+ PARAMETER ( LDD = 4, LDX = 2 )
+* ..
+* .. Local Scalars ..
+ INTEGER IERR, J2, J3, J4, K, LD, LI, ND
+ REAL CS, DNORM, EPS, SCALE, SMLNUM, SN, T11, T22,
+ $ T33, TAU, TAU1, TAU2, TEMP, THRESH, WI1, WI2,
+ $ WR1, WR2, XNORM
+* ..
+* .. Local Arrays ..
+ REAL D( LDD, 4 ), X( LDX, 2 )
+* ..
+* .. External Functions ..
+ REAL SLAMCH, SLANGE
+ EXTERNAL SLAMCH, SLANGE
+* ..
+* .. External Subroutines ..
+ EXTERNAL SLAMOV, SLANV2, SLARFG, SLARFX, SLARTG, SLASY2,
+ $ SROT
+* ..
+* .. 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 SLARTG( T( J1, J2 ), T22-T11, CS, SN, TEMP )
+*
+* Apply transformation to the matrix T.
+*
+ IF( J3.LE.N )
+ $ CALL SROT( N-J1-1, T( J1, J3 ), LDT, T( J2, J3 ), LDT, CS,
+ $ SN )
+ CALL SROT( J1-1, T( 1, J1 ), 1, T( 1, J2 ), 1, CS, SN )
+*
+ T( J1, J1 ) = T22
+ T( J2, J2 ) = T11
+*
+ ITRAF( 1 ) = J1
+ DTRAF( 1 ) = CS
+ DTRAF( 2 ) = SN
+*
+ ELSE
+*
+* Swapping involves at least one 2-by-2 block.
+*
+* Copy the diagonal block of order N1+N2 to the local array D
+* and compute its norm.
+*
+ ND = N1 + N2
+ CALL SLAMOV( 'Full', ND, ND, T( J1, J1 ), LDT, D, LDD )
+ DNORM = SLANGE( 'Max', ND, ND, D, LDD, WORK )
+*
+* Compute machine-dependent threshold for test for accepting
+* swap.
+*
+ EPS = SLAMCH( 'P' )
+ SMLNUM = SLAMCH( 'S' ) / EPS
+ THRESH = MAX( TEN*EPS*DNORM, SMLNUM )
+*
+* Solve T11*X - X*T22 = scale*T12 for X.
+*
+ CALL SLASY2( .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, * )
+*
+ DTRAF( 1 ) = SCALE
+ DTRAF( 2 ) = X( 1, 1 )
+ DTRAF( 3 ) = X( 1, 2 )
+ CALL SLARFG( 3, DTRAF( 3 ), DTRAF, 1, TAU )
+ DTRAF( 3 ) = ONE
+ T11 = T( J1, J1 )
+*
+* Perform swap provisionally on diagonal block in D.
+*
+ CALL SLARFX( 'Left', 3, 3, DTRAF, TAU, D, LDD, WORK )
+ CALL SLARFX( 'Right', 3, 3, DTRAF, 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 SLARFX( 'Left', 3, N-J1+1, DTRAF, TAU, T( J1, J1 ), LDT,
+ $ WORK )
+ CALL SLARFX( 'Right', J2, 3, DTRAF, TAU, T( 1, J1 ), LDT,
+ $ WORK )
+*
+ T( J3, J1 ) = ZERO
+ T( J3, J2 ) = ZERO
+ T( J3, J3 ) = T11
+*
+ ITRAF( 1 ) = 2*N + J1
+ LI = 2
+ DTRAF( 3 ) = TAU
+ LD = 4
+ GO TO 40
+*
+ 20 CONTINUE
+*
+* N1 = 2, N2 = 1: generate elementary reflector H so that:
+*
+* H ( -X11 ) = ( * )
+* ( -X21 ) = ( 0 )
+* ( scale ) = ( 0 )
+*
+ DTRAF( 1 ) = -X( 1, 1 )
+ DTRAF( 2 ) = -X( 2, 1 )
+ DTRAF( 3 ) = SCALE
+ CALL SLARFG( 3, DTRAF( 1 ), DTRAF( 2 ), 1, TAU )
+ DTRAF( 1 ) = ONE
+ T33 = T( J3, J3 )
+*
+* Perform swap provisionally on diagonal block in D.
+*
+ CALL SLARFX( 'Left', 3, 3, DTRAF, TAU, D, LDD, WORK )
+ CALL SLARFX( 'Right', 3, 3, DTRAF, 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 SLARFX( 'Right', J3, 3, DTRAF, TAU, T( 1, J1 ), LDT,
+ $ WORK )
+ CALL SLARFX( 'Left', 3, N-J1, DTRAF, TAU, T( J1, J2 ), LDT,
+ $ WORK )
+*
+ T( J1, J1 ) = T33
+ T( J2, J1 ) = ZERO
+ T( J3, J1 ) = ZERO
+*
+ ITRAF( 1 ) = N + J1
+ LI = 2
+ DTRAF( 1 ) = TAU
+ LD = 4
+ 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 )
+*
+ DTRAF( 1 ) = -X( 1, 1 )
+ DTRAF( 2 ) = -X( 2, 1 )
+ DTRAF( 3 ) = SCALE
+ CALL SLARFG( 3, DTRAF( 1 ), DTRAF( 2 ), 1, TAU1 )
+ DTRAF( 1 ) = ONE
+*
+ TEMP = -TAU1*( X( 1, 2 )+DTRAF( 2 )*X( 2, 2 ) )
+ DTRAF( 4 ) = -TEMP*DTRAF( 2 ) - X( 2, 2 )
+ DTRAF( 5 ) = -TEMP*DTRAF( 3 )
+ DTRAF( 6 ) = SCALE
+ CALL SLARFG( 3, DTRAF( 4 ), DTRAF( 5 ), 1, TAU2 )
+ DTRAF( 4 ) = ONE
+*
+* Perform swap provisionally on diagonal block in D.
+*
+ CALL SLARFX( 'Left', 3, 4, DTRAF, TAU1, D, LDD, WORK )
+ CALL SLARFX( 'Right', 4, 3, DTRAF, TAU1, D, LDD, WORK )
+ CALL SLARFX( 'Left', 3, 4, DTRAF( 4 ), TAU2, D( 2, 1 ), LDD,
+ $ WORK )
+ CALL SLARFX( 'Right', 4, 3, DTRAF( 4 ), 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 SLARFX( 'Left', 3, N-J1+1, DTRAF, TAU1, T( J1, J1 ), LDT,
+ $ WORK )
+ CALL SLARFX( 'Right', J4, 3, DTRAF, TAU1, T( 1, J1 ), LDT,
+ $ WORK )
+ CALL SLARFX( 'Left', 3, N-J1+1, DTRAF( 4 ), TAU2, T( J2, J1 ),
+ $ LDT, WORK )
+ CALL SLARFX( 'Right', J4, 3, DTRAF( 4 ), TAU2, T( 1, J2 ), LDT,
+ $ WORK )
+*
+ T( J3, J1 ) = ZERO
+ T( J3, J2 ) = ZERO
+ T( J4, J1 ) = ZERO
+ T( J4, J2 ) = ZERO
+*
+ ITRAF( 1 ) = N + J1
+ ITRAF( 2 ) = N + J2
+ LI = 3
+ DTRAF( 1 ) = TAU1
+ DTRAF( 4 ) = TAU2
+ LD = 7
+ GO TO 40
+*
+ 40 CONTINUE
+*
+ IF( N2.EQ.2 ) THEN
+*
+* Standardize new 2-by-2 block T11
+*
+ CALL SLANV2( T( J1, J1 ), T( J1, J2 ), T( J2, J1 ),
+ $ T( J2, J2 ), WR1, WI1, WR2, WI2, CS, SN )
+ CALL SROT( N-J1-1, T( J1, J1+2 ), LDT, T( J2, J1+2 ), LDT,
+ $ CS, SN )
+ CALL SROT( J1-1, T( 1, J1 ), 1, T( 1, J2 ), 1, CS, SN )
+ ITRAF( LI ) = J1
+ LI = LI + 1
+ DTRAF( LD ) = CS
+ DTRAF( LD+1 ) = SN
+ LD = LD + 2
+ END IF
+*
+ IF( N1.EQ.2 ) THEN
+*
+* Standardize new 2-by-2 block T22
+*
+ J3 = J1 + N2
+ J4 = J3 + 1
+ CALL SLANV2( T( J3, J3 ), T( J3, J4 ), T( J4, J3 ),
+ $ T( J4, J4 ), WR1, WI1, WR2, WI2, CS, SN )
+ IF( J3+2.LE.N )
+ $ CALL SROT( N-J3-1, T( J3, J3+2 ), LDT, T( J4, J3+2 ),
+ $ LDT, CS, SN )
+ CALL SROT( J3-1, T( 1, J3 ), 1, T( 1, J4 ), 1, CS, SN )
+ ITRAF( LI ) = J3
+ DTRAF( LD ) = CS
+ DTRAF( LD+1 ) = SN
+ END IF
+*
+ END IF
+ RETURN
+*
+* Exit with INFO = 1 if swap was rejected.
+*
+ 50 CONTINUE
+ INFO = 1
+ RETURN
+*
+* End of BSLAEXC
+*
+ END
diff --git a/SRC/bstrexc.f b/SRC/bstrexc.f
new file mode 100644
index 0000000..017e873
--- /dev/null
+++ b/SRC/bstrexc.f
@@ -0,0 +1,564 @@
+ SUBROUTINE BSTREXC( N, T, LDT, IFST, ILST, NITRAF, ITRAF,
+ $ NDTRAF, DTRAF, WORK, INFO )
+ IMPLICIT NONE
+*
+*
+* -- LAPACK routine (version 3.0) --
+* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
+* Courant Institute, Argonne National Lab, and Rice University
+* March 31, 1993
+*
+* .. Scalar Arguments ..
+ INTEGER IFST, ILST, INFO, LDT, N, NDTRAF, NITRAF
+* ..
+* .. Array Arguments ..
+ INTEGER ITRAF( * )
+ REAL DTRAF( * ), T( LDT, * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* BSTREXC 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. In contrast to the LAPACK routine DTREXC,
+* the orthogonal matrix Z is not explicitly constructed but
+* represented by paramaters contained in the arrays ITRAF and DTRAF,
+* see further details.
+*
+* T must be in Schur canonical form (as returned by DHSEQR), that is,
+* block upper triangular with 1-by-1 and 2-by-2 diagonal blocks; each
+* 2-by-2 diagonal block has its diagonal elements equal and its
+* off-diagonal elements of opposite sign.
+*
+* Arguments
+* =========
+*
+* N (input) INTEGER
+* The order of the matrix T. N >= 0.
+*
+* T (input/output) REAL array, dimension (LDT,N)
+* On entry, the upper quasi-triangular matrix T, in Schur
+* Schur canonical form.
+* On exit, the reordered upper quasi-triangular matrix, again
+* in Schur canonical form.
+*
+* LDT (input) INTEGER
+* The leading dimension of the array T. LDT >= max(1,N).
+*
+* IFST (input/output) INTEGER
+* ILST (input/output) INTEGER
+* Specify the reordering of the diagonal blocks of T.
+* The block with row index IFST is moved to row ILST, by a
+* sequence of transpositions between adjacent blocks.
+* On exit, if IFST pointed on entry to the second row of a
+* 2-by-2 block, it is changed to point to the first row; ILST
+* always points to the first row of the block in its final
+* position (which may differ from its input value by +1 or -1).
+* 1 <= IFST <= N; 1 <= ILST <= N.
+*
+* NITRAF (input/output) INTEGER
+* On entry, length of the array ITRAF.
+* As a minimum requirement, NITRAF >= max(1,|ILST-IFST|).
+* If there are 2-by-2 blocks in T then NITRAF must be larger;
+* a safe choice is NITRAF >= max(1,2*|ILST-IFST|).
+* On exit, actual length of the array ITRAF.
+*
+* ITRAF (output) INTEGER array, length NITRAF
+* List of parameters for representing the transformation
+* matrix Z, see further details.
+*
+* NDTRAF (input/output) INTEGER
+* On entry, length of the array DTRAF.
+* As a minimum requirement, NDTRAF >= max(1,2*|ILST-IFST|).
+* If there are 2-by-2 blocks in T then NDTRAF must be larger;
+* a safe choice is NDTRAF >= max(1,5*|ILST-IFST|).
+* On exit, actual length of the array DTRAF.
+*
+* DTRAF (output) REAL array, length NDTRAF
+* List of parameters for representing the transformation
+* matrix Z, see further details.
+*
+* WORK (workspace) REAL array, dimension (N)
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+* = 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.
+* = 2: the 2 by 2 block to be reordered split into two 1 by 1
+* blocks and the second block failed to swap with an
+* adjacent block. ILST points to the first row of the
+* current position of the whole block being moved.
+*
+* Further Details
+* ===============
+*
+* The orthogonal transformation matrix Z is a product of NITRAF
+* elementary orthogonal transformations. The parameters defining these
+* transformations are stored in the arrays ITRAF and DTRAF as follows:
+*
+* Consider the i-th transformation acting on rows/columns POS,
+* POS+1, ... If this transformation is
+*
+* (1) a Givens rotation with cosine C and sine S then
+*
+* ITRAF(i) = POS,
+* DTRAF(j) = C, DTRAF(j+1) = S;
+*
+* (2) a Householder reflector H = I - tau * v * v' with
+* v = [ 1; v2; v3 ] then
+*
+* ITRAF(i) = N + POS,
+* DTRAF(j) = tau, DTRAF(j+1) = v2, DTRAF(j+2) = v3;
+*
+* (3) a Householder reflector H = I - tau * v * v' with
+* v = [ v1; v2; 1 ] then
+*
+* ITRAF(i) = 2*N + POS,
+* DTRAF(j) = v1, DTRAF(j+1) = v2, DTRAF(j+2) = tau;
+*
+* Note that the parameters in DTRAF are stored consecutively.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ZERO
+ PARAMETER ( ZERO = 0.0E+0 )
+ INTEGER DLNGTH(3), ILNGTH(3)
+* ..
+* .. Local Scalars ..
+ INTEGER CDTRAF, CITRAF, LDTRAF, LITRAF, HERE, I, NBF,
+ $ NBL, NBNEXT
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL BSLAEXC, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX
+* .. Data Statements ..
+c DATA ( ILNGTH(I), I = 1, 3 ) / 1, 2, 4 /
+c DATA ( DLNGTH(I), I = 1, 3 ) / 2, 5, 10 /
+ DATA ILNGTH(1)/1/, ILNGTH(2)/2/, ILNGTH(3)/4/
+ DATA DLNGTH(1)/2/, DLNGTH(2)/5/, DLNGTH(3)/10/
+* ..
+* .. Executable Statements ..
+*
+* Decode and test the input arguments.
+*
+ INFO = 0
+ IF( N.LT.0 ) THEN
+ INFO = -1
+ ELSE IF( LDT.LT.MAX( 1, N ) ) THEN
+ INFO = -3
+ ELSE IF( IFST.LT.1 .OR. IFST.GT.N ) THEN
+ INFO = -4
+ ELSE IF( ILST.LT.1 .OR. ILST.GT.N ) THEN
+ INFO = -5
+ ELSE IF ( NITRAF.LT.MAX( 1, ABS( ILST-IFST ) ) ) THEN
+ INFO = -6
+ ELSE IF ( NDTRAF.LT.MAX( 1, 2*ABS( ILST-IFST ) ) ) 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
+ CITRAF = 1
+ CDTRAF = 1
+*
+* 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
+*
+ LITRAF = ILNGTH(NBF+NBNEXT-1)
+ LDTRAF = DLNGTH(NBF+NBNEXT-1)
+ IF( CITRAF+LITRAF-1.GT.NITRAF ) THEN
+ INFO = -6
+ CALL XERBLA( 'BSTREXC', -INFO )
+ RETURN
+ END IF
+ IF( CDTRAF+LDTRAF-1.GT.NDTRAF ) THEN
+ INFO = -8
+ CALL XERBLA( 'BSTREXC', -INFO )
+ RETURN
+ END IF
+ CALL BSLAEXC( N, T, LDT, HERE, NBF, NBNEXT, ITRAF(CITRAF),
+ $ DTRAF(CDTRAF), WORK, INFO )
+ IF( INFO.NE.0 ) THEN
+ ILST = HERE
+ NITRAF = CITRAF - 1
+ NDTRAF = CDTRAF - 1
+ RETURN
+ END IF
+ CITRAF = CITRAF + LITRAF
+ CDTRAF = CDTRAF + LDTRAF
+ 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
+ LITRAF = ILNGTH(NBNEXT)
+ LDTRAF = DLNGTH(NBNEXT)
+ IF( CITRAF+LITRAF-1.GT.NITRAF ) THEN
+ INFO = -6
+ CALL XERBLA( 'BSTREXC', -INFO )
+ RETURN
+ END IF
+ IF( CDTRAF+LDTRAF-1.GT.NDTRAF ) THEN
+ INFO = -8
+ CALL XERBLA( 'BSTREXC', -INFO )
+ RETURN
+ END IF
+ CALL BSLAEXC( N, T, LDT, HERE+1, 1, NBNEXT, ITRAF(CITRAF),
+ $ DTRAF(CDTRAF), WORK, INFO )
+ IF( INFO.NE.0 ) THEN
+ ILST = HERE
+ NITRAF = CITRAF - 1
+ NDTRAF = CDTRAF - 1
+ RETURN
+ END IF
+ CITRAF = CITRAF + LITRAF
+ CDTRAF = CDTRAF + LDTRAF
+*
+ IF( NBNEXT.EQ.1 ) THEN
+*
+* Swap two 1 by 1 blocks, no problems possible
+*
+ LITRAF = ILNGTH(1)
+ LDTRAF = DLNGTH(1)
+ IF( CITRAF+LITRAF-1.GT.NITRAF ) THEN
+ INFO = -6
+ CALL XERBLA( 'BSTREXC', -INFO )
+ RETURN
+ END IF
+ IF( CDTRAF+LDTRAF-1.GT.NDTRAF ) THEN
+ INFO = -8
+ CALL XERBLA( 'BSTREXC', -INFO )
+ RETURN
+ END IF
+ CALL BSLAEXC( N, T, LDT, HERE, 1, NBNEXT, ITRAF(CITRAF),
+ $ DTRAF(CDTRAF), WORK, INFO )
+ CITRAF = CITRAF + LITRAF
+ CDTRAF = CDTRAF + LDTRAF
+ 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
+*
+ LITRAF = ILNGTH(2)
+ LDTRAF = DLNGTH(2)
+ IF( CITRAF+LITRAF-1.GT.NITRAF ) THEN
+ INFO = -6
+ CALL XERBLA( 'BSTREXC', -INFO )
+ RETURN
+ END IF
+ IF( CDTRAF+LDTRAF-1.GT.NDTRAF ) THEN
+ INFO = -8
+ CALL XERBLA( 'BSTREXC', -INFO )
+ RETURN
+ END IF
+ CALL BSLAEXC( N, T, LDT, HERE, 1, NBNEXT,
+ $ ITRAF(CITRAF), DTRAF(CDTRAF), WORK,
+ $ INFO )
+ IF( INFO.NE.0 ) THEN
+ INFO = 2
+ ILST = HERE
+ NITRAF = CITRAF - 1
+ NDTRAF = CDTRAF - 1
+ RETURN
+ END IF
+ CITRAF = CITRAF + LITRAF
+ CDTRAF = CDTRAF + LDTRAF
+ HERE = HERE + 2
+ ELSE
+*
+* 2 by 2 Block did split
+*
+ LITRAF = ILNGTH(1)
+ LDTRAF = DLNGTH(1)
+ IF( CITRAF+2*LITRAF-1.GT.NITRAF ) THEN
+ INFO = -6
+ CALL XERBLA( 'BSTREXC', -INFO )
+ RETURN
+ END IF
+ IF( CDTRAF+2*LDTRAF-1.GT.NDTRAF ) THEN
+ INFO = -8
+ CALL XERBLA( 'BSTREXC', -INFO )
+ RETURN
+ END IF
+ CALL BSLAEXC( N, T, LDT, HERE, 1, 1, ITRAF(CITRAF),
+ $ DTRAF(CDTRAF), WORK, INFO )
+ CITRAF = CITRAF + LITRAF
+ CDTRAF = CDTRAF + LDTRAF
+ CALL BSLAEXC( N, T, LDT, HERE+1, 1, 1, ITRAF(CITRAF),
+ $ DTRAF(CDTRAF), WORK, INFO )
+ CITRAF = CITRAF + LITRAF
+ CDTRAF = CDTRAF + LDTRAF
+ 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
+*
+ LITRAF = ILNGTH(NBF+NBNEXT-1)
+ LDTRAF = DLNGTH(NBF+NBNEXT-1)
+ IF( CITRAF+LITRAF-1.GT.NITRAF ) THEN
+ INFO = -6
+ CALL XERBLA( 'BSTREXC', -INFO )
+ RETURN
+ END IF
+ IF( CDTRAF+LDTRAF-1.GT.NDTRAF ) THEN
+ INFO = -8
+ CALL XERBLA( 'BSTREXC', -INFO )
+ RETURN
+ END IF
+ CALL BSLAEXC( N, T, LDT, HERE-NBNEXT, NBNEXT, NBF,
+ $ ITRAF(CITRAF), DTRAF(CDTRAF), WORK, INFO )
+ IF( INFO.NE.0 ) THEN
+ ILST = HERE
+ NITRAF = CITRAF - 1
+ NDTRAF = CDTRAF - 1
+ RETURN
+ END IF
+ CITRAF = CITRAF + LITRAF
+ CDTRAF = CDTRAF + LDTRAF
+ 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
+ LITRAF = ILNGTH(NBNEXT)
+ LDTRAF = DLNGTH(NBNEXT)
+ IF( CITRAF+LITRAF-1.GT.NITRAF ) THEN
+ INFO = -6
+ CALL XERBLA( 'BSTREXC', -INFO )
+ RETURN
+ END IF
+ IF( CDTRAF+LDTRAF-1.GT.NDTRAF ) THEN
+ INFO = -8
+ CALL XERBLA( 'BSTREXC', -INFO )
+ RETURN
+ END IF
+ CALL BSLAEXC( N, T, LDT, HERE-NBNEXT, NBNEXT, 1,
+ $ ITRAF(CITRAF), DTRAF(CDTRAF), WORK, INFO )
+ IF( INFO.NE.0 ) THEN
+ ILST = HERE
+ NITRAF = CITRAF - 1
+ NDTRAF = CDTRAF - 1
+ RETURN
+ END IF
+ CITRAF = CITRAF + LITRAF
+ CDTRAF = CDTRAF + LDTRAF
+*
+ IF( NBNEXT.EQ.1 ) THEN
+*
+* Swap two 1 by 1 blocks, no problems possible
+*
+ LITRAF = ILNGTH(1)
+ LDTRAF = DLNGTH(1)
+ IF( CITRAF+LITRAF-1.GT.NITRAF ) THEN
+ INFO = -6
+ CALL XERBLA( 'BSTREXC', -INFO )
+ RETURN
+ END IF
+ IF( CDTRAF+LDTRAF-1.GT.NDTRAF ) THEN
+ INFO = -8
+ CALL XERBLA( 'BSTREXC', -INFO )
+ RETURN
+ END IF
+ CALL BSLAEXC( N, T, LDT, HERE, NBNEXT, 1, ITRAF(CITRAF),
+ $ DTRAF(CDTRAF), WORK, INFO )
+ CITRAF = CITRAF + LITRAF
+ CDTRAF = CDTRAF + LDTRAF
+ 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
+*
+ LITRAF = ILNGTH(2)
+ LDTRAF = DLNGTH(2)
+ IF( CITRAF+LITRAF-1.GT.NITRAF ) THEN
+ INFO = -6
+ CALL XERBLA( 'BSTREXC', -INFO )
+ RETURN
+ END IF
+ IF( CDTRAF+LDTRAF-1.GT.NDTRAF ) THEN
+ INFO = -8
+ CALL XERBLA( 'BSTREXC', -INFO )
+ RETURN
+ END IF
+ CALL BSLAEXC( N, T, LDT, HERE-1, 2, 1, ITRAF(CITRAF),
+ $ DTRAF(CDTRAF), WORK, INFO )
+ IF( INFO.NE.0 ) THEN
+ INFO = 2
+ ILST = HERE
+ NITRAF = CITRAF - 1
+ NDTRAF = CDTRAF - 1
+ RETURN
+ END IF
+ CITRAF = CITRAF + LITRAF
+ CDTRAF = CDTRAF + LDTRAF
+ HERE = HERE - 2
+ ELSE
+*
+* 2 by 2 Block did split
+*
+ LITRAF = ILNGTH(1)
+ LDTRAF = DLNGTH(1)
+ IF( CITRAF+2*LITRAF-1.GT.NITRAF ) THEN
+ INFO = -6
+ CALL XERBLA( 'BSTREXC', -INFO )
+ RETURN
+ END IF
+ IF( CDTRAF+2*LDTRAF-1.GT.NDTRAF ) THEN
+ INFO = -8
+ CALL XERBLA( 'BSTREXC', -INFO )
+ RETURN
+ END IF
+ CALL BSLAEXC( N, T, LDT, HERE, 1, 1, ITRAF(CITRAF),
+ $ DTRAF(CDTRAF), WORK, INFO )
+ CITRAF = CITRAF + LITRAF
+ CDTRAF = CDTRAF + LDTRAF
+ CALL BSLAEXC( N, T, LDT, HERE-1, 1, 1, ITRAF(CITRAF),
+ $ DTRAF(CDTRAF), WORK, INFO )
+ CITRAF = CITRAF + LITRAF
+ CDTRAF = CDTRAF + LDTRAF
+ HERE = HERE - 2
+ END IF
+ END IF
+ END IF
+ IF( HERE.GT.ILST )
+ $ GO TO 20
+ END IF
+ ILST = HERE
+ NITRAF = CITRAF - 1
+ NDTRAF = CDTRAF - 1
+*
+ RETURN
+*
+* End of BSTREXC
+*
+ END
diff --git a/SRC/cdbtf2.f b/SRC/cdbtf2.f
index 89b127d..d14f8ce 100644
--- a/SRC/cdbtf2.f
+++ b/SRC/cdbtf2.f
@@ -1,5 +1,8 @@
SUBROUTINE CDBTF2( M, N, KL, KU, AB, LDAB, INFO )
*
+* -- ScaLAPACK auxiliary routine (version 2.0) --
+* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver
+*
* Modified by Andrew J. Cleary in November, 96 from:
* -- LAPACK auxiliary routine (preliminary version) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
diff --git a/SRC/cdbtrf.f b/SRC/cdbtrf.f
index ed984c8..204c908 100644
--- a/SRC/cdbtrf.f
+++ b/SRC/cdbtrf.f
@@ -1,5 +1,8 @@
SUBROUTINE CDBTRF( M, N, KL, KU, AB, LDAB, INFO )
*
+* -- ScaLAPACK auxiliary routine (version 2.0) --
+* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver
+*
* Written by Andrew J. Cleary, University of Tennessee.
* August, 1996.
* Modified from CGBTRF:
diff --git a/SRC/cdttrf.f b/SRC/cdttrf.f
index f8c9561..85dff76 100644
--- a/SRC/cdttrf.f
+++ b/SRC/cdttrf.f
@@ -1,5 +1,8 @@
SUBROUTINE CDTTRF( N, DL, D, DU, INFO )
*
+* -- ScaLAPACK auxiliary routine (version 2.0) --
+* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver
+*
* Written by Andrew J. Cleary, November 1996.
* Modified from CGTTRF:
* -- LAPACK routine (preliminary version) --
diff --git a/SRC/cdttrsv.f b/SRC/cdttrsv.f
index 64d713a..54a5f70 100644
--- a/SRC/cdttrsv.f
+++ b/SRC/cdttrsv.f
@@ -1,6 +1,9 @@
SUBROUTINE CDTTRSV( UPLO, TRANS, N, NRHS, DL, D, DU,
$ B, LDB, INFO )
*
+* -- ScaLAPACK auxiliary routine (version 2.0) --
+* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver
+*
* Written by Andrew J. Cleary, University of Tennessee.
* August, 1996.
* Modified from CGTTRS:
diff --git a/SRC/clamov.c b/SRC/clamov.c
new file mode 100644
index 0000000..d91ab8d
--- /dev/null
+++ b/SRC/clamov.c
@@ -0,0 +1,11 @@
+//
+// clamov.c
+//
+// Written by Lee Killough 04/19/2012
+//
+
+#define TYPE complex
+#define FUNC "CLAMOV"
+#define LAMOV clamov_
+#define LACPY clacpy_
+#include "lamov.h"
diff --git a/SRC/cpttrsv.f b/SRC/cpttrsv.f
index c7c91ce..2094265 100644
--- a/SRC/cpttrsv.f
+++ b/SRC/cpttrsv.f
@@ -1,6 +1,9 @@
SUBROUTINE CPTTRSV( UPLO, TRANS, N, NRHS, D, E, B, LDB,
$ INFO )
*
+* -- ScaLAPACK auxiliary routine (version 2.0) --
+* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver
+*
* Written by Andrew J. Cleary, University of Tennessee.
* November, 1996.
* Modified from CPTTRS:
diff --git a/SRC/ddbtf2.f b/SRC/ddbtf2.f
index 939139d..c70fb63 100644
--- a/SRC/ddbtf2.f
+++ b/SRC/ddbtf2.f
@@ -1,5 +1,8 @@
SUBROUTINE DDBTF2( M, N, KL, KU, AB, LDAB, INFO )
*
+* -- ScaLAPACK auxiliary routine (version 2.0) --
+* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver
+*
* Modified by Andrew J. Cleary in November, 96 from:
* -- LAPACK auxiliary routine (preliminary version) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
diff --git a/SRC/ddbtrf.f b/SRC/ddbtrf.f
index 6073084..78b7b4d 100644
--- a/SRC/ddbtrf.f
+++ b/SRC/ddbtrf.f
@@ -1,5 +1,8 @@
SUBROUTINE DDBTRF( M, N, KL, KU, AB, LDAB, INFO )
*
+* -- ScaLAPACK auxiliary routine (version 2.0) --
+* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver
+*
* Written by Andrew J. Cleary, University of Tennessee.
* August, 1996.
* Modified from DGBTRF:
diff --git a/SRC/ddttrf.f b/SRC/ddttrf.f
index ff4958b..a32d984 100644
--- a/SRC/ddttrf.f
+++ b/SRC/ddttrf.f
@@ -1,5 +1,8 @@
SUBROUTINE DDTTRF( N, DL, D, DU, INFO )
*
+* -- ScaLAPACK auxiliary routine (version 2.0) --
+* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver
+*
* Written by Andrew J. Cleary, November 1996.
* Modified from DGTTRF:
* -- LAPACK routine (preliminary version) --
diff --git a/SRC/ddttrsv.f b/SRC/ddttrsv.f
index d9da745..598c807 100644
--- a/SRC/ddttrsv.f
+++ b/SRC/ddttrsv.f
@@ -1,6 +1,9 @@
SUBROUTINE DDTTRSV( UPLO, TRANS, N, NRHS, DL, D, DU,
$ B, LDB, INFO )
*
+* -- ScaLAPACK auxiliary routine (version 2.0) --
+* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver
+*
* Written by Andrew J. Cleary, University of Tennessee.
* August, 1996.
* Modified from DGTTRS:
diff --git a/SRC/dlamov.c b/SRC/dlamov.c
new file mode 100644
index 0000000..176cf26
--- /dev/null
+++ b/SRC/dlamov.c
@@ -0,0 +1,11 @@
+//
+// dlamov.c
+//
+// Written by Lee Killough 04/19/2012
+//
+
+#define TYPE double
+#define FUNC "DLAMOV"
+#define LAMOV dlamov_
+#define LACPY dlacpy_
+#include "lamov.h"
diff --git a/SRC/dlaqr6.f b/SRC/dlaqr6.f
new file mode 100644
index 0000000..2e79083
--- /dev/null
+++ b/SRC/dlaqr6.f
@@ -0,0 +1,861 @@
+ SUBROUTINE DLAQR6( JOB, 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 )
+*
+* Contribution from the Department of Computing Science and HPC2N,
+* Umea University, Sweden
+*
+* -- ScaLAPACK auxiliary routine (version 2.0.2) --
+* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver
+* May 1 2012
+*
+ IMPLICIT NONE
+*
+* .. Scalar Arguments ..
+ CHARACTER JOB
+ INTEGER IHIZ, ILOZ, KACC22, KBOT, KTOP, LDH, LDU, LDV,
+ $ LDWH, LDWV, LDZ, N, NH, NSHFTS, NV
+ LOGICAL WANTT, WANTZ
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION H( LDH, * ), SI( * ), SR( * ), U( LDU, * ),
+ $ V( LDV, * ), WH( LDWH, * ), WV( LDWV, * ),
+ $ Z( LDZ, * )
+* ..
+*
+* This auxiliary subroutine called by PDLAQR5 performs a
+* single small-bulge multi-shift QR sweep, moving the chain
+* of bulges from top to bottom in the submatrix
+* H(KTOP:KBOT,KTOP:KBOT), collecting the transformations in the
+* matrix HV *or* accumulating the transformations in the matrix
+* Z (see below).
+*
+* This is a modified version of DLAQR5 from LAPACK 3.1.
+*
+* ======================================================================
+*
+* JOB (input) character scalar
+* Set the kind of job to do in DLAQR6, as follows:
+* JOB = 'I': Introduce and chase bulges in submatrix
+* JOB = 'C': Chase bulges from top to bottom of submatrix
+* JOB = 'O': Chase bulges off submatrix
+*
+* WANTT (input) logical scalar
+* WANTT = .true. if the quasi-triangular Schur factor
+* is being computed. WANTT is set to .false. otherwise.
+*
+* WANTZ (input) logical scalar
+* WANTZ = .true. if the orthogonal Schur factor is being
+* computed. WANTZ is set to .false. otherwise.
+*
+* KACC22 (input) integer with value 0, 1, or 2.
+* Specifies the computation mode of far-from-diagonal
+* orthogonal updates.
+* = 0: DLAQR6 does not accumulate reflections and does not
+* use matrix-matrix multiply to update far-from-diagonal
+* matrix entries.
+* = 1: DLAQR6 accumulates reflections and uses matrix-matrix
+* multiply to update the far-from-diagonal matrix entries.
+* = 2: DLAQR6 accumulates reflections, uses matrix-matrix
+* multiply to update the far-from-diagonal matrix entries,
+* and takes advantage of 2-by-2 block structure during
+* matrix multiplies.
+*
+* N (input) integer scalar
+* N is the order of the Hessenberg matrix H upon which this
+* subroutine operates.
+*
+* KTOP (input) integer scalar
+* KBOT (input) integer scalar
+* These are the first and last rows and columns of an
+* isolated diagonal block upon which the QR sweep is to be
+* applied. It is assumed without a check that
+* either KTOP = 1 or H(KTOP,KTOP-1) = 0
+* and
+* either KBOT = N or H(KBOT+1,KBOT) = 0.
+*
+* NSHFTS (input) integer scalar
+* NSHFTS gives the number of simultaneous shifts. NSHFTS
+* must be positive and even.
+*
+* SR (input) DOUBLE PRECISION array of size (NSHFTS)
+* SI (input) DOUBLE PRECISION array of size (NSHFTS)
+* SR contains the real parts and SI contains the imaginary
+* parts of the NSHFTS shifts of origin that define the
+* multi-shift QR sweep.
+*
+* H (input/output) DOUBLE PRECISION array of size (LDH,N)
+* On input H contains a Hessenberg matrix. On output a
+* multi-shift QR sweep with shifts SR(J)+i*SI(J) is applied
+* to the isolated diagonal block in rows and columns KTOP
+* through KBOT.
+*
+* LDH (input) integer scalar
+* LDH is the leading dimension of H just as declared in the
+* calling procedure. LDH.GE.MAX(1,N).
+*
+* ILOZ (input) INTEGER
+* IHIZ (input) INTEGER
+* Specify the rows of Z to which transformations must be
+* applied if WANTZ is .TRUE.. 1 .LE. ILOZ .LE. IHIZ .LE. N
+*
+* Z (input/output) DOUBLE PRECISION array of size (LDZ,IHI)
+* If WANTZ = .TRUE., then the QR Sweep orthogonal
+* similarity transformation is accumulated into
+* Z(ILOZ:IHIZ,ILO:IHI) from the right.
+* If WANTZ = .FALSE., then Z is unreferenced.
+*
+* LDZ (input) integer scalar
+* LDA is the leading dimension of Z just as declared in
+* the calling procedure. LDZ.GE.N.
+*
+* V (workspace) DOUBLE PRECISION array of size (LDV,NSHFTS/2)
+*
+* LDV (input) integer scalar
+* LDV is the leading dimension of V as declared in the
+* calling procedure. LDV.GE.3.
+*
+* U (workspace) DOUBLE PRECISION array of size
+* (LDU,3*NSHFTS-3)
+*
+* LDU (input) integer scalar
+* LDU is the leading dimension of U just as declared in the
+* in the calling subroutine. LDU.GE.3*NSHFTS-3.
+*
+* NH (input) integer scalar
+* NH is the number of columns in array WH available for
+* workspace. NH.GE.1 is required for usage of this
+* workspace, otherwise the updates of the far-from-diagonal
+* elements will be updated without level 3 BLAS.
+*
+* WH (workspace) DOUBLE PRECISION array of size (LDWH,NH)
+*
+* LDWH (input) integer scalar
+* Leading dimension of WH just as declared in the
+* calling procedure. LDWH.GE.3*NSHFTS-3.
+*
+* NV (input) integer scalar
+* NV is the number of rows in WV agailable for workspace.
+* NV.GE.1 is required for usage of this
+* workspace, otherwise the updates of the far-from-diagonal
+* elements will be updated without level 3 BLAS.
+*
+* WV (workspace) DOUBLE PRECISION array of size
+* (LDWV,3*NSHFTS-3)
+*
+* LDWV (input) integer scalar
+* LDWV is the leading dimension of WV as declared in the
+* in the calling subroutine. LDWV.GE.NV.
+*
+*
+* ================================================================
+* Based on contributions by
+* Karen Braman and Ralph Byers, Department of Mathematics,
+* University of Kansas, USA
+*
+* Robert Granat, Department of Computing Science and HPC2N,
+* Umea University, Sweden
+*
+* ============================================================
+* Reference:
+*
+* K. Braman, R. Byers and R. Mathias, The Multi-Shift QR
+* Algorithm Part I: Maintaining Well Focused Shifts, and
+* Level 3 Performance, SIAM Journal of Matrix Analysis,
+* volume 23, pages 929--947, 2002.
+*
+* ============================================================
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, ONE
+ PARAMETER ( ZERO = 0.0d0, ONE = 1.0d0 )
+* ..
+* .. Local Scalars ..
+ DOUBLE PRECISION ALPHA, BETA, H11, H12, H21, H22, REFSUM,
+ $ SAFMAX, SAFMIN, SCL, SMLNUM, SWAP, TST1, TST2,
+ $ ULP
+ INTEGER I, I2, I4, INCOL, J, J2, J4, JBOT, JCOL, JLEN,
+ $ JROW, JTOP, K, K1, KDU, KMS, KNZ, KRCOL, KZS,
+ $ M, M22, MBOT, MEND, MSTART, MTOP, NBMPS, NDCOL,
+ $ NS, NU, SINCOL, EINCOL, UINCOL, IPHV, CHUNK,
+ $ THREADS, JLEN2, JCOL2, GCHUNK, JROW2, MAXCHUNK
+ LOGICAL ACCUM, BLK22, BMP22, INTRO, CHASE, OFF, ALL
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ INTEGER PILAENVX
+ DOUBLE PRECISION DLAMCH
+ EXTERNAL LSAME, DLAMCH, PILAENVX
+* ..
+* .. Intrinsic Functions ..
+*
+ INTRINSIC ABS, DBLE, MAX, MIN, MOD
+* ..
+* .. Local Arrays ..
+ DOUBLE PRECISION VT( 3 )
+* ..
+* .. External Subroutines ..
+ EXTERNAL DGEMM, DLABAD, DLAMOV, 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
+ THREADS = 1
+*
+* ==== 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 ? This is only performed if both NH and NV is
+* greater than 1. ====
+*
+ ACCUM = ( KACC22.EQ.1 ) .OR. ( KACC22.EQ.2 )
+ ACCUM = ACCUM .AND. NH.GE.1 .AND. NV.GE.1
+*
+* ==== If so, exploit the 2-by-2 block structure? ====
+*
+ BLK22 = ( NS.GT.2 ) .AND. ( KACC22.EQ.2 )
+*
+* ==== Decode JOB ====
+*
+ ALL = LSAME( JOB, 'A' )
+ IF( .NOT. ALL )
+ $ INTRO = LSAME( JOB, 'I' )
+ IF( .NOT. ALL .AND. .NOT. INTRO )
+ $ CHASE = LSAME( JOB, 'C' )
+ IF( .NOT. ALL .AND. .NOT. INTRO .AND. .NOT. CHASE ) THEN
+ OFF = LSAME( JOB, 'O' )
+ IF( .NOT. OFF )
+ $ RETURN
+ END IF
+*
+* ==== clear trash ====
+*
+ IF( INTRO.OR.ALL .AND. 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
+*
+* Set loop limits for bulge-chasing depending on working mode
+*
+ IF( ALL ) THEN
+ SINCOL = 3*( 1-NBMPS ) + KTOP - 1
+ EINCOL = KBOT - 2
+ UINCOL = 3*NBMPS - 2
+ ELSEIF( INTRO ) THEN
+ SINCOL = 3*( 1-NBMPS ) + KTOP - 1
+ EINCOL = KBOT - 3*NBMPS - 1
+ UINCOL = 3*NBMPS - 2
+ ELSEIF( CHASE ) THEN
+ SINCOL = KTOP
+ EINCOL = KBOT - 3*NBMPS - 1
+ UINCOL = 3*NBMPS - 2
+ ELSEIF( OFF ) THEN
+ SINCOL = KTOP
+ EINCOL = KBOT - 2
+ UINCOL = 3*NBMPS - 2
+ END IF
+ IPHV = 0
+*
+* ==== Create and/or chase chains of NBMPS bulges ====
+*
+ DO 220 INCOL = SINCOL, EINCOL, UINCOL
+ NDCOL = MIN( INCOL + KDU, EINCOL )
+ 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( EINCOL, 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
+ ELSE
+*
+* ==== Initialize V(1,M22) here to avoid possible undefined
+* . variable problems later. ====
+*
+ V( 1, M22 ) = ZERO
+ END IF
+*
+* ==== Multiply H by reflections from the left ====
+*
+ IF( ACCUM ) THEN
+ JBOT = MIN( MAX(INCOL+KDU,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
+ K1 = MAX( 1, KTOP-INCOL )
+ NU = ( KDU-MAX( 0, MAX(INCOL+KDU,NDCOL)-KBOT ) ) - K1 + 1
+ IF( ( .NOT.BLK22 ) .OR. ( INCOL.LT.KTOP ) .OR.
+ $ ( NDCOL.GT.KBOT ) .OR. ( NS.LE.2 ) .OR.
+ $ NU.LT.KDU ) 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. ====
+*
+* ==== Horizontal Multiply ====
+*
+ DO 160 JCOL = MIN(MAX(INCOL+KDU,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 DLAMOV( '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 DLAMOV( '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 DLAMOV( '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(MAX(INCOL+KDU,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 DLAMOV( 'ALL', KNZ, JLEN, H( INCOL+1+J2, JCOL ),
+ $ LDH, WH( KZS+1, 1 ), LDWH )
+ CALL DLASET( 'ALL', KZS, JLEN, ZERO, ZERO, WH, LDWH )
+*
+* ==== Multiply by U21' ====
+*
+ CALL DTRMM( 'L', 'U', 'C', 'N', KNZ, JLEN, ONE,
+ $ U( J2+1, 1+KZS ), LDU, WH( KZS+1, 1 ),
+ $ LDWH )
+*
+* ==== Multiply top of H by U11' ====
+*
+ CALL DGEMM( 'C', 'N', I2, JLEN, J2, ONE, U, LDU,
+ $ H( INCOL+1, JCOL ), LDH, ONE, WH, LDWH )
+*
+* ==== Copy top of H to bottom of WH ====
+*
+ CALL DLAMOV( 'ALL', J2, JLEN, H( INCOL+1, JCOL ), LDH,
+ $ WH( I2+1, 1 ), LDWH )
+*
+* ==== Multiply by U21' ====
+*
+ CALL DTRMM( 'L', 'L', 'C', 'N', J2, JLEN, ONE,
+ $ U( 1, I2+1 ), LDU, WH( I2+1, 1 ), LDWH )
+*
+* ==== Multiply by U22 ====
+*
+ CALL DGEMM( 'C', 'N', I4-I2, JLEN, J4-J2, ONE,
+ $ U( J2+1, I2+1 ), LDU,
+ $ H( INCOL+1+J2, JCOL ), LDH, ONE,
+ $ WH( I2+1, 1 ), LDWH )
+*
+* ==== Copy it back ====
+*
+ CALL DLAMOV( '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 DLAMOV( 'ALL', JLEN, KNZ, H( JROW, INCOL+1+J2 ),
+ $ LDH, WV( 1, 1+KZS ), LDWV )
+ CALL DLASET( 'ALL', JLEN, KZS, ZERO, ZERO, WV, LDWV )
+*
+* ==== Multiply by U21 ====
+*
+ 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 DLAMOV( '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 DLAMOV( '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 DLAMOV( '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 DLAMOV( '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 DLAMOV( 'ALL', JLEN, KDU, WV, LDWV,
+ $ Z( JROW, INCOL+1 ), LDZ )
+ 210 CONTINUE
+ END IF
+ END IF
+ END IF
+ 220 CONTINUE
+*
+* ==== Clear out workspaces and return. ====
+*
+ IF( N.GE.5 )
+ $ CALL DLASET( 'Lower', N-4, N-4, ZERO, ZERO, H(5,1), LDH )
+*
+* ==== End of DLAQR6 ====
+*
+ END
diff --git a/SRC/dlar1va.f b/SRC/dlar1va.f
new file mode 100644
index 0000000..49f3352
--- /dev/null
+++ b/SRC/dlar1va.f
@@ -0,0 +1,423 @@
+ SUBROUTINE DLAR1VA(N, B1, BN, LAMBDA, D, L, LD, LLD,
+ $ PIVMIN, GAPTOL, Z, WANTNC, NEGCNT, ZTZ, MINGMA,
+ $ R, ISUPPZ, NRMINV, RESID, RQCORR, WORK )
+*
+ IMPLICIT NONE
+*
+* -- ScaLAPACK computational routine (version 2.0) --
+* Univ. of Tennessee, Univ. of California Berkeley, Univ of Colorado Denver
+* July 4, 2010
+*
+* .. 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( * )
+*
+* Purpose
+* =======
+*
+* DLAR1VA computes the (scaled) r-th column of the inverse of
+* the sumbmatrix in rows B1 through BN of the tridiagonal matrix
+* L D L^T - sigma I. When sigma is close to an eigenvalue, the
+* computed vector is an accurate eigenvector. Usually, r corresponds
+* to the index where the eigenvector is largest in magnitude.
+* The following steps accomplish this computation :
+* (a) Stationary qd transform, L D L^T - sigma I = L(+) D(+) L(+)^T,
+* (b) Progressive qd transform, L D L^T - sigma I = U(-) D(-) U(-)^T,
+* (c) Computation of the diagonal elements of the inverse of
+* L D L^T - sigma I by combining the above transforms, and choosing
+* r as the index where the diagonal of the inverse is (one of the)
+* largest in magnitude.
+* (d) Computation of the (scaled) r-th column of the inverse using the
+* twisted factorization obtained by combining the top part of the
+* the stationary and the bottom part of the progressive transform.
+*
+* Arguments
+* =========
+*
+* N (input) INTEGER
+* The order of the matrix L D L^T.
+*
+* B1 (input) INTEGER
+* First index of the submatrix of L D L^T.
+*
+* BN (input) INTEGER
+* Last index of the submatrix of L D L^T.
+*
+* LAMBDA (input) DOUBLE PRECISION
+* The shift. In order to compute an accurate eigenvector,
+* LAMBDA should be a good approximation to an eigenvalue
+* of L D L^T.
+*
+* L (input) DOUBLE PRECISION array, dimension (N-1)
+* The (n-1) subdiagonal elements of the unit bidiagonal matrix
+* L, in elements 1 to N-1.
+*
+* D (input) DOUBLE PRECISION array, dimension (N)
+* The n diagonal elements of the diagonal matrix D.
+*
+* LD (input) DOUBLE PRECISION array, dimension (N-1)
+* The n-1 elements L(i)*D(i).
+*
+* LLD (input) DOUBLE PRECISION array, dimension (N-1)
+* The n-1 elements L(i)*L(i)*D(i).
+*
+* PIVMIN (input) DOUBLE PRECISION
+* The minimum pivot in the Sturm sequence.
+*
+* GAPTOL (input) DOUBLE PRECISION
+* Tolerance that indicates when eigenvector entries are negligible
+* w.r.t. their contribution to the residual.
+*
+* Z (input/output) DOUBLE PRECISION array, dimension (N)
+* On input, all entries of Z must be set to 0.
+* On output, Z contains the (scaled) r-th column of the
+* inverse. The scaling is such that Z(R) equals 1.
+*
+* WANTNC (input) LOGICAL
+* Specifies whether NEGCNT has to be computed.
+*
+* NEGCNT (output) INTEGER
+* If WANTNC is .TRUE. then NEGCNT = the number of pivots < pivmin
+* in the matrix factorization L D L^T, and NEGCNT = -1 otherwise.
+*
+* ZTZ (output) DOUBLE PRECISION
+* The square of the 2-norm of Z.
+*
+* MINGMA (output) DOUBLE PRECISION
+* The reciprocal of the largest (in magnitude) diagonal
+* element of the inverse of L D L^T - sigma I.
+*
+* R (input/output) INTEGER
+* The twist index for the twisted factorization used to
+* compute Z.
+* On input, 0 <= R <= N. If R is input as 0, R is set to
+* the index where (L D L^T - sigma I)^{-1} is largest
+* in magnitude. If 1 <= R <= N, R is unchanged.
+* On output, R contains the twist index used to compute Z.
+* Ideally, R designates the position of the maximum entry in the
+* eigenvector.
+*
+* ISUPPZ (output) INTEGER array, dimension (2)
+* The support of the vector in Z, i.e., the vector Z is
+* nonzero only in elements ISUPPZ(1) through ISUPPZ( 2 ).
+*
+* NRMINV (output) DOUBLE PRECISION
+* NRMINV = 1/SQRT( ZTZ )
+*
+* RESID (output) DOUBLE PRECISION
+* The residual of the FP vector.
+* RESID = ABS( MINGMA )/SQRT( ZTZ )
+*
+* RQCORR (output) DOUBLE PRECISION
+* The Rayleigh Quotient correction to LAMBDA.
+* RQCORR = MINGMA*TMP
+*
+* WORK (workspace) DOUBLE PRECISION array, dimension (4*N)
+*
+* Further Details
+* ===============
+*
+* Based on contributions by
+* Beresford Parlett, University of California, Berkeley, USA
+* Jim Demmel, University of California, Berkeley, USA
+* Inderjit Dhillon, University of Texas, Austin, USA
+* Osni Marques, LBNL/NERSC, USA
+* Christof Voemel, University of California, Berkeley, USA
+*
+* =====================================================================
+*
+* .. Parameters ..
+ INTEGER BLKLEN
+ PARAMETER ( BLKLEN = 16 )
+ DOUBLE PRECISION ZERO, ONE
+ PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 )
+
+* ..
+* .. Local Scalars ..
+ LOGICAL SAWNAN1, SAWNAN2
+ INTEGER BI, I, INDLPL, INDP, INDS, INDUMN, NB, NEG1,
+ $ NEG2, NX, R1, R2, TO
+ DOUBLE PRECISION ABSZCUR, ABSZPREV, DMINUS, DPLUS, EPS,
+ $ S, TMP, ZPREV
+* ..
+* .. External Functions ..
+ LOGICAL DISNAN
+ DOUBLE PRECISION DLAMCH
+ EXTERNAL DISNAN, DLAMCH
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX, MIN, DBLE
+* ..
+* .. 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
+*
+ NB = INT((R-B1)/BLKLEN)
+ NX = R-NB*BLKLEN
+ IF( .NOT.SAWNAN1 ) THEN
+ DO 210 BI = R-1, NX, -BLKLEN
+ TO = BI-BLKLEN+1
+ DO 205 I = BI, TO, -1
+ Z( I ) = -( WORK(INDLPL+I)*Z(I+1) )
+ ZTZ = ZTZ + Z( I )*Z( I )
+ 205 CONTINUE
+ IF( ABS(Z(TO)).LT.EPS .AND.
+ $ ABS(Z(TO+1)).LT.EPS ) THEN
+ ISUPPZ(1) = TO
+ GOTO 220
+ ENDIF
+ 210 CONTINUE
+ DO 215 I = NX-1, B1, -1
+ Z( I ) = -( WORK(INDLPL+I)*Z(I+1) )
+ ZTZ = ZTZ + Z( I )*Z( I )
+ 215 CONTINUE
+ 220 CONTINUE
+ ELSE
+* Run slower loop if NaN occurred.
+ DO 230 BI = R-1, NX, -BLKLEN
+ TO = BI-BLKLEN+1
+ DO 225 I = BI, TO, -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
+ ZTZ = ZTZ + Z( I )*Z( I )
+ 225 CONTINUE
+ IF( ABS(Z(TO)).LT.EPS .AND.
+ $ ABS(Z(TO+1)).LT.EPS ) THEN
+ ISUPPZ(1) = TO
+ GOTO 240
+ ENDIF
+ 230 CONTINUE
+ DO 235 I = NX-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
+ ZTZ = ZTZ + Z( I )*Z( I )
+ 235 CONTINUE
+ 240 CONTINUE
+ ENDIF
+ DO 245 I= B1, (ISUPPZ(1)-1)
+ Z(I) = ZERO
+ 245 CONTINUE
+
+* Compute the FP vector downwards from R in blocks of size BLKLEN
+ IF( .NOT.SAWNAN2 ) THEN
+ DO 260 BI = R+1, BN, BLKLEN
+ TO = BI+BLKLEN-1
+ IF ( TO.LE.BN ) THEN
+ DO 250 I = BI, TO
+ Z(I) = -(WORK(INDUMN+I-1)*Z(I-1))
+ ZTZ = ZTZ + Z( I )*Z( I )
+ 250 CONTINUE
+ IF( ABS(Z(TO)).LE.EPS .AND.
+ $ ABS(Z(TO-1)).LE.EPS ) THEN
+ ISUPPZ(2) = TO
+ GOTO 265
+ ENDIF
+ ELSE
+ DO 255 I = BI, BN
+ Z(I) = -(WORK(INDUMN+I-1)*Z(I-1))
+ ZTZ = ZTZ + Z( I )*Z( I )
+ 255 CONTINUE
+ ENDIF
+ 260 CONTINUE
+ 265 CONTINUE
+ ELSE
+* Run slower loop if NaN occurred.
+ DO 280 BI = R+1, BN, BLKLEN
+ TO = BI+BLKLEN-1
+ IF ( TO.LE.BN ) THEN
+ DO 270 I = BI, TO
+ ZPREV = Z(I-1)
+ ABSZPREV = ABS(ZPREV)
+ IF( ZPREV.NE.ZERO ) THEN
+ Z(I)= -(WORK(INDUMN+I-1)*ZPREV)
+ ELSE
+ Z(I)= -(LD(I-2)/LD(I-1))*Z(I-2)
+ END IF
+ ABSZCUR = ABS(Z(I))
+ ZTZ = ZTZ + ABSZCUR**2
+ 270 CONTINUE
+ IF( ABSZCUR.LT.EPS .AND.
+ $ ABSZPREV.LT.EPS ) THEN
+ ISUPPZ(2) = I
+ GOTO 285
+ ENDIF
+ ELSE
+ DO 275 I = BI, BN
+ ZPREV = Z(I-1)
+ ABSZPREV = ABS(ZPREV)
+ IF( ZPREV.NE.ZERO ) THEN
+ Z(I)= -(WORK(INDUMN+I-1)*ZPREV)
+ ELSE
+ Z(I)= -(LD(I-2)/LD(I-1))*Z(I-2)
+ END IF
+ ABSZCUR = ABS(Z(I))
+ ZTZ = ZTZ + ABSZCUR**2
+ 275 CONTINUE
+ ENDIF
+ 280 CONTINUE
+ 285 CONTINUE
+ END IF
+ DO 290 I= ISUPPZ(2)+1,BN
+ Z(I) = ZERO
+ 290 CONTINUE
+*
+* Compute quantities for convergence test
+*
+ TMP = ONE / ZTZ
+ NRMINV = SQRT( TMP )
+ RESID = ABS( MINGMA )*NRMINV
+ RQCORR = MINGMA*TMP
+*
+ RETURN
+*
+* End of DLAR1VA
+*
+ END
diff --git a/SRC/dlaref.f b/SRC/dlaref.f
index d80f7ae..1a38bc6 100644
--- a/SRC/dlaref.f
+++ b/SRC/dlaref.f
@@ -1,11 +1,12 @@
SUBROUTINE DLAREF( TYPE, A, LDA, WANTZ, Z, LDZ, BLOCK, IROW1,
- $ ICOL1, ISTART, ISTOP, ITMP1, ITMP2, LILOZ,
- $ LIHIZ, VECS, V2, V3, T1, T2, T3 )
+ $ ICOL1, ISTART, ISTOP, ITMP1, ITMP2, LILOZ,
+ $ LIHIZ, VECS, V2, V3, T1, T2, T3 )
+ IMPLICIT NONE
*
-* -- ScaLAPACK routine (version 1.7) --
+* -- ScaLAPACK auxiliary routine (version 1.5) --
* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
* and University of California, Berkeley.
-* December 31, 1998
+* May 1, 1997
*
* .. Scalar Arguments ..
LOGICAL BLOCK, WANTZ
@@ -104,14 +105,16 @@
* reflector and is read when BLOCK is .FALSE., and
* overwritten when BLOCK is .TRUE.
*
-* Implemented by: G. Henry, November 17, 1996
+* Implemented by: G. Henry, May 1, 1997
*
* =====================================================================
*
* .. Local Scalars ..
INTEGER J, K
DOUBLE PRECISION H11, H22, SUM, T12, T13, T22, T23, T32, T33,
- $ V22, V23, V32, V33
+ $ V22, V23, V32, V33, A1, A2, A3, A4, A5, B1,
+ $ B2, B3, B4, B5, TMP1, TMP2, TMP3, SUM1, SUM2,
+ $ SUM3, A11, A22
* ..
* .. External Functions ..
LOGICAL LSAME
@@ -124,7 +127,7 @@
*
IF( LSAME( TYPE, 'R' ) ) THEN
IF( BLOCK ) THEN
- DO 20 K = ISTART, ISTOP - MOD( ISTOP-ISTART+1, 3 ), 3
+ DO 30 K = ISTART, ISTOP - MOD( ISTOP-ISTART+1, 3 ), 3
V2 = VECS( ( K-1 )*3+1 )
V3 = VECS( ( K-1 )*3+2 )
T1 = VECS( ( K-1 )*3+3 )
@@ -140,7 +143,43 @@
T32 = T12*V32
T23 = T13*V23
T33 = T13*V33
- DO 10 J = ITMP1, ITMP2
+ DO 10 J = ITMP1, ITMP2-MOD(ITMP2-ITMP1+1,2), 2
+ A1 = A ( IROW1 , J )
+ A2 = A ( IROW1+1, J )
+ A3 = A ( IROW1+2, J )
+ A4 = A ( IROW1+3, J )
+ A5 = A ( IROW1+4, J )
+ B1 = A ( IROW1 , J+1 )
+ B2 = A ( IROW1+1, J+1 )
+ B3 = A ( IROW1+2, J+1 )
+ B4 = A ( IROW1+3, J+1 )
+ B5 = A ( IROW1+4, J+1 )
+ SUM1 = A1 + V2*A2 + V3*A3
+ A( IROW1 , J ) = A1 - SUM1 * T1
+ H11 = A2 - SUM1 * T2
+ H22 = A3 - SUM1 * T3
+ TMP1 = B1 + V2*B2 + V3*B3
+ A( IROW1 , J+1 ) = B1 - TMP1 * T1
+ A11 = B2 - TMP1 * T2
+ A22 = B3 - TMP1 * T3
+ SUM2 = H11 + V22*H22 + V32*A4
+ A( IROW1+1, J ) = H11 - SUM2 * T12
+ H11 = H22 - SUM2 * T22
+ H22 = A4 - SUM2 * T32
+ TMP2 = A11 + V22*A22 + V32*B4
+ A( IROW1+1, J+1 ) = A11 - TMP2 * T12
+ A11 = A22 - TMP2 * T22
+ A22 = B4 - TMP2 * T32
+ SUM3 = H11 + V23*H22 + V33*A5
+ A( IROW1+2, J ) = H11 - SUM3 * T13
+ A( IROW1+3, J ) = H22 - SUM3 * T23
+ A( IROW1+4, J ) = A5 - SUM3 * T33
+ TMP3 = A11 + V23*A22 + V33*B5
+ A( IROW1+2, J+1 ) = A11 - TMP3 * T13
+ A( IROW1+3, J+1 ) = A22 - TMP3 * T23
+ A( IROW1+4, J+1 ) = B5 - TMP3 * T33
+ 10 CONTINUE
+ DO 20 J = ITMP2-MOD(ITMP2-ITMP1+1,2)+1, ITMP2
SUM = A( IROW1, J ) + V2*A( IROW1+1, J ) +
$ V3*A( IROW1+2, J )
A( IROW1, J ) = A( IROW1, J ) - SUM*T1
@@ -154,39 +193,39 @@
A( IROW1+2, J ) = H11 - SUM*T13
A( IROW1+3, J ) = H22 - SUM*T23
A( IROW1+4, J ) = A( IROW1+4, J ) - SUM*T33
- 10 CONTINUE
+ 20 CONTINUE
IROW1 = IROW1 + 3
- 20 CONTINUE
- DO 40 K = ISTOP - MOD( ISTOP-ISTART+1, 3 ) + 1, ISTOP
+ 30 CONTINUE
+ DO 50 K = ISTOP - MOD( ISTOP-ISTART+1, 3 ) + 1, ISTOP
V2 = VECS( ( K-1 )*3+1 )
V3 = VECS( ( K-1 )*3+2 )
T1 = VECS( ( K-1 )*3+3 )
T2 = T1*V2
T3 = T1*V3
- DO 30 J = ITMP1, ITMP2
+ DO 40 J = ITMP1, ITMP2
SUM = A( IROW1, J ) + V2*A( IROW1+1, J ) +
$ V3*A( IROW1+2, J )
A( IROW1, J ) = A( IROW1, J ) - SUM*T1
A( IROW1+1, J ) = A( IROW1+1, J ) - SUM*T2
A( IROW1+2, J ) = A( IROW1+2, J ) - SUM*T3
- 30 CONTINUE
+ 40 CONTINUE
IROW1 = IROW1 + 1
- 40 CONTINUE
+ 50 CONTINUE
ELSE
- DO 50 J = ITMP1, ITMP2
+ DO 60 J = ITMP1, ITMP2
SUM = A( IROW1, J ) + V2*A( IROW1+1, J ) +
$ V3*A( IROW1+2, J )
A( IROW1, J ) = A( IROW1, J ) - SUM*T1
A( IROW1+1, J ) = A( IROW1+1, J ) - SUM*T2
A( IROW1+2, J ) = A( IROW1+2, J ) - SUM*T3
- 50 CONTINUE
+ 60 CONTINUE
END IF
ELSE
*
* Do column transforms
*
IF( BLOCK ) THEN
- DO 80 K = ISTART, ISTOP - MOD( ISTOP-ISTART+1, 3 ), 3
+ DO 90 K = ISTART, ISTOP - MOD( ISTOP-ISTART+1, 3 ), 3
V2 = VECS( ( K-1 )*3+1 )
V3 = VECS( ( K-1 )*3+2 )
T1 = VECS( ( K-1 )*3+3 )
@@ -202,7 +241,7 @@
T32 = T12*V32
T23 = T13*V23
T33 = T13*V33
- DO 60 J = ITMP1, ITMP2
+ DO 70 J = ITMP1, ITMP2
SUM = A( J, ICOL1 ) + V2*A( J, ICOL1+1 ) +
$ V3*A( J, ICOL1+2 )
A( J, ICOL1 ) = A( J, ICOL1 ) - SUM*T1
@@ -216,9 +255,9 @@
A( J, ICOL1+2 ) = H11 - SUM*T13
A( J, ICOL1+3 ) = H22 - SUM*T23
A( J, ICOL1+4 ) = A( J, ICOL1+4 ) - SUM*T33
- 60 CONTINUE
+ 70 CONTINUE
IF( WANTZ ) THEN
- DO 70 J = LILOZ, LIHIZ
+ DO 80 J = LILOZ, LIHIZ
SUM = Z( J, ICOL1 ) + V2*Z( J, ICOL1+1 ) +
$ V3*Z( J, ICOL1+2 )
Z( J, ICOL1 ) = Z( J, ICOL1 ) - SUM*T1
@@ -232,42 +271,42 @@
Z( J, ICOL1+2 ) = H11 - SUM*T13
Z( J, ICOL1+3 ) = H22 - SUM*T23
Z( J, ICOL1+4 ) = Z( J, ICOL1+4 ) - SUM*T33
- 70 CONTINUE
+ 80 CONTINUE
END IF
ICOL1 = ICOL1 + 3
- 80 CONTINUE
- DO 110 K = ISTOP - MOD( ISTOP-ISTART+1, 3 ) + 1, ISTOP
+ 90 CONTINUE
+ DO 120 K = ISTOP - MOD( ISTOP-ISTART+1, 3 ) + 1, ISTOP
V2 = VECS( ( K-1 )*3+1 )
V3 = VECS( ( K-1 )*3+2 )
T1 = VECS( ( K-1 )*3+3 )
T2 = T1*V2
T3 = T1*V3
- DO 90 J = ITMP1, ITMP2
+ DO 100 J = ITMP1, ITMP2
SUM = A( J, ICOL1 ) + V2*A( J, ICOL1+1 ) +
$ V3*A( J, ICOL1+2 )
A( J, ICOL1 ) = A( J, ICOL1 ) - SUM*T1
A( J, ICOL1+1 ) = A( J, ICOL1+1 ) - SUM*T2
A( J, ICOL1+2 ) = A( J, ICOL1+2 ) - SUM*T3
- 90 CONTINUE
+ 100 CONTINUE
IF( WANTZ ) THEN
- DO 100 J = LILOZ, LIHIZ
+ DO 110 J = LILOZ, LIHIZ
SUM = Z( J, ICOL1 ) + V2*Z( J, ICOL1+1 ) +
$ V3*Z( J, ICOL1+2 )
Z( J, ICOL1 ) = Z( J, ICOL1 ) - SUM*T1
Z( J, ICOL1+1 ) = Z( J, ICOL1+1 ) - SUM*T2
Z( J, ICOL1+2 ) = Z( J, ICOL1+2 ) - SUM*T3
- 100 CONTINUE
+ 110 CONTINUE
END IF
ICOL1 = ICOL1 + 1
- 110 CONTINUE
+ 120 CONTINUE
ELSE
- DO 120 J = ITMP1, ITMP2
+ DO 130 J = ITMP1, ITMP2
SUM = A( J, ICOL1 ) + V2*A( J, ICOL1+1 ) +
$ V3*A( J, ICOL1+2 )
A( J, ICOL1 ) = A( J, ICOL1 ) - SUM*T1
A( J, ICOL1+1 ) = A( J, ICOL1+1 ) - SUM*T2
A( J, ICOL1+2 ) = A( J, ICOL1+2 ) - SUM*T3
- 120 CONTINUE
+ 130 CONTINUE
END IF
END IF
RETURN
@@ -275,4 +314,3 @@
* End of DLAREF
*
END
-*
diff --git a/SRC/dlarrb2.f b/SRC/dlarrb2.f
new file mode 100644
index 0000000..b1702f6
--- /dev/null
+++ b/SRC/dlarrb2.f
@@ -0,0 +1,662 @@
+ SUBROUTINE DLARRB2( N, D, LLD, IFIRST, ILAST, RTOL1,
+ $ RTOL2, OFFSET, W, WGAP, WERR, WORK, IWORK,
+ $ PIVMIN, LGPVMN, LGSPDM, TWIST, INFO )
+*
+* -- ScaLAPACK auxiliary routine (version 2.0) --
+* Univ. of Tennessee, Univ. of California Berkeley, Univ of Colorado Denver
+* July 4, 2010
+*
+ IMPLICIT NONE
+*
+* .. Scalar Arguments ..
+ INTEGER IFIRST, ILAST, INFO, N, OFFSET, TWIST
+ DOUBLE PRECISION LGPVMN, LGSPDM, PIVMIN,
+ $ RTOL1, RTOL2
+* ..
+* .. Array Arguments ..
+ INTEGER IWORK( * )
+ DOUBLE PRECISION D( * ), LLD( * ), W( * ),
+ $ WERR( * ), WGAP( * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* Given the relatively robust representation(RRR) L D L^T, DLARRB2
+* 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.
+*
+* NOTE:
+* There are very few minor differences between DLARRB from LAPACK
+* and this current subroutine DLARRB2.
+* The most important reason for creating this nearly identical copy
+* is profiling: in the ScaLAPACK MRRR algorithm, eigenvalue computation
+* using DLARRB2 is used for refinement in the construction of
+* the representation tree, as opposed to the initial computation of the
+* eigenvalues for the root RRR which uses DLARRB. When profiling,
+* this allows an easy quantification of refinement work vs. computing
+* eigenvalues of the root.
+*
+* Arguments
+* =========
+*
+* N (input) INTEGER
+* The order of the matrix.
+*
+* D (input) DOUBLE PRECISION array, dimension (N)
+* The N diagonal elements of the diagonal matrix D.
+*
+* LLD (input) DOUBLE PRECISION array, dimension (N-1)
+* The (N-1) elements L(i)*L(i)*D(i).
+*
+* IFIRST (input) INTEGER
+* The index of the first eigenvalue to be computed.
+*
+* ILAST (input) INTEGER
+* The index of the last eigenvalue to be computed.
+*
+* RTOL1 (input) DOUBLE PRECISION
+* RTOL2 (input) DOUBLE PRECISION
+* Tolerance for the convergence of the bisection intervals.
+* An interval [LEFT,RIGHT] has converged if
+* RIGHT-LEFT.LT.MAX( RTOL1*GAP, RTOL2*MAX(|LEFT|,|RIGHT|) )
+* where GAP is the (estimated) distance to the nearest
+* eigenvalue.
+*
+* OFFSET (input) INTEGER
+* Offset for the arrays W, WGAP and WERR, i.e., the IFIRST-OFFSET
+* through ILAST-OFFSET elements of these arrays are to be used.
+*
+* W (input/output) DOUBLE PRECISION array, dimension (N)
+* On input, W( IFIRST-OFFSET ) through W( ILAST-OFFSET ) are
+* estimates of the eigenvalues of L D L^T indexed IFIRST through ILAST.
+* On output, these estimates are refined.
+*
+* WGAP (input/output) DOUBLE PRECISION array, dimension (N-1)
+* On input, the (estimated) gaps between consecutive
+* eigenvalues of L D L^T, i.e., WGAP(I-OFFSET) is the gap between
+* eigenvalues I and I+1. Note that if IFIRST.EQ.ILAST
+* then WGAP(IFIRST-OFFSET) must be set to ZERO.
+* On output, these gaps are refined.
+*
+* WERR (input/output) DOUBLE PRECISION array, dimension (N)
+* On input, WERR( IFIRST-OFFSET ) through WERR( ILAST-OFFSET ) are
+* the errors in the estimates of the corresponding elements in W.
+* On output, these errors are refined.
+*
+* WORK (workspace) DOUBLE PRECISION array, dimension (4*N)
+* Workspace.
+*
+* IWORK (workspace) INTEGER array, dimension (2*N)
+* Workspace.
+*
+* PIVMIN (input) DOUBLE PRECISION
+* The minimum pivot in the sturm sequence.
+*
+* LGPVMN (input) DOUBLE PRECISION
+* Logarithm of PIVMIN, precomputed.
+*
+* LGSPDM (input) DOUBLE PRECISION
+* Logarithm of the spectral diameter, precomputed.
+*
+* TWIST (input) INTEGER
+* The twist index for the twisted factorization that is used
+* for the negcount.
+* TWIST = N: Compute negcount from L D L^T - LAMBDA I = L+ D+ L+^T
+* TWIST = 1: Compute negcount from L D L^T - LAMBDA I = U- D- U-^T
+* TWIST = R: Compute negcount from L D L^T - LAMBDA I = N(r) D(r) N(r)
+*
+* INFO (output) INTEGER
+* Error flag.
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, TWO, HALF
+ PARAMETER ( ZERO = 0.0D0, TWO = 2.0D0,
+ $ HALF = 0.5D0 )
+ INTEGER MAXITR
+* ..
+* .. Local Scalars ..
+ INTEGER I, I1, II, INDLLD, IP, ITER, J, K, NEGCNT,
+ $ NEXT, NINT, OLNINT, PREV, R
+ DOUBLE PRECISION BACK, CVRGD, GAP, LEFT, LGAP, MID, MNWDTH,
+ $ RGAP, RIGHT, SAVGAP, TMP, WIDTH
+ LOGICAL PARANOID
+* ..
+* .. External Functions ..
+ LOGICAL DISNAN
+ DOUBLE PRECISION DLAMCH
+ INTEGER DLANEG2A
+ EXTERNAL DISNAN, DLAMCH,
+ $ DLANEG2A
+*
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX, MIN
+* ..
+* .. Executable Statements ..
+*
+ INFO = 0
+*
+* Turn on paranoid check for rounding errors
+* invalidating uncertainty intervals of eigenvalues
+*
+ PARANOID = .TRUE.
+*
+ MAXITR = INT( ( LGSPDM - LGPVMN ) / LOG( TWO ) ) + 2
+ MNWDTH = TWO * PIVMIN
+*
+ R = TWIST
+*
+ INDLLD = 2*N
+ DO 5 J = 1, N-1
+ I=2*J
+ WORK(INDLLD+I-1) = D(J)
+ WORK(INDLLD+I) = LLD(J)
+ 5 CONTINUE
+ WORK(INDLLD+2*N-1) = D(N)
+*
+ 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 )
+
+ IF((ABS(LEFT).LE.16*PIVMIN).OR.(ABS(RIGHT).LE.16*PIVMIN))
+ $ THEN
+ INFO = -1
+ RETURN
+ ENDIF
+
+ IF( PARANOID ) THEN
+* 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 = DLANEG2A( N, WORK(INDLLD+1), 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 = DLANEG2A( N, WORK(INDLLD+1),RIGHT, PIVMIN, R )
+
+ IF( NEGCNT.LT.I ) THEN
+ RIGHT = RIGHT + BACK
+ BACK = TWO*BACK
+ GO TO 50
+ END IF
+ ENDIF
+
+ 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 = DLANEG2A( N, WORK(INDLLD+1), 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
+*
+* save this gap to restore it after the loop
+ SAVGAP = WGAP( ILAST-OFFSET )
+*
+ LEFT = WORK( 2*IFIRST-1 )
+ DO 110 I = IFIRST, ILAST
+ K = 2*I
+ II = I - OFFSET
+* RIGHT is the right boundary of this current interval
+ RIGHT = WORK( K )
+* All intervals marked by '0' have been refined.
+ IF( IWORK( K-1 ).EQ.0 ) THEN
+ W( II ) = HALF*( LEFT+RIGHT )
+ WERR( II ) = RIGHT - W( II )
+ END IF
+* Left is the boundary of the next interval
+ LEFT = WORK( K +1 )
+ WGAP( II ) = MAX( ZERO, LEFT - RIGHT )
+ 110 CONTINUE
+* restore the last gap which was overwritten by garbage
+ WGAP( ILAST-OFFSET ) = SAVGAP
+
+ RETURN
+*
+* End of DLARRB2
+*
+ END
+*
+*
+*
+ FUNCTION DLANEG2( N, D, LLD, SIGMA, PIVMIN, R )
+*
+ IMPLICIT NONE
+*
+ INTEGER DLANEG2
+*
+* .. Scalar Arguments ..
+ INTEGER N, R
+ DOUBLE PRECISION PIVMIN, SIGMA
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION D( * ), LLD( * )
+*
+ DOUBLE PRECISION ZERO
+ PARAMETER ( ZERO = 0.0D0 )
+
+ INTEGER BLKLEN
+ PARAMETER ( BLKLEN = 2048 )
+* ..
+* .. Local Scalars ..
+ INTEGER BJ, J, NEG1, NEG2, NEGCNT, TO
+ DOUBLE PRECISION DMINUS, DPLUS, GAMMA, P, S, T, TMP, XSAV
+ LOGICAL SAWNAN
+* ..
+* .. External Functions ..
+ LOGICAL DISNAN
+ EXTERNAL DISNAN
+
+ NEGCNT = 0
+*
+* I) upper part: L D L^T - SIGMA I = L+ D+ L+^T
+* run dstqds block-wise to avoid excessive work when NaNs occur
+*
+ S = ZERO
+ DO 210 BJ = 1, R-1, BLKLEN
+ NEG1 = 0
+ XSAV = S
+ TO = BJ+BLKLEN-1
+ IF ( TO.LE.R-1 ) THEN
+ DO 21 J = BJ, TO
+ T = S - SIGMA
+ DPLUS = D( J ) + T
+ IF( DPLUS.LT.ZERO ) NEG1=NEG1 + 1
+ S = T*LLD( J ) / DPLUS
+ 21 CONTINUE
+ ELSE
+ DO 22 J = BJ, R-1
+ T = S - SIGMA
+ DPLUS = D( J ) + T
+ IF( DPLUS.LT.ZERO ) NEG1=NEG1 + 1
+ S = T*LLD( J ) / DPLUS
+ 22 CONTINUE
+ ENDIF
+ SAWNAN = DISNAN( S )
+*
+ IF( SAWNAN ) THEN
+ NEG1 = 0
+ S = XSAV
+ TO = BJ+BLKLEN-1
+ IF ( TO.LE.R-1 ) THEN
+ DO 23 J = BJ, TO
+ T = S - SIGMA
+ DPLUS = D( J ) + T
+ IF(ABS(DPLUS).LT.PIVMIN)
+ $ DPLUS = -PIVMIN
+ TMP = LLD( J ) / DPLUS
+ IF( DPLUS.LT.ZERO )
+ $ NEG1 = NEG1 + 1
+ S = T*TMP
+ IF( TMP.EQ.ZERO ) S = LLD( J )
+ 23 CONTINUE
+ ELSE
+ DO 24 J = BJ, R-1
+ T = S - SIGMA
+ DPLUS = D( J ) + T
+ IF(ABS(DPLUS).LT.PIVMIN)
+ $ DPLUS = -PIVMIN
+ TMP = LLD( J ) / DPLUS
+ IF( DPLUS.LT.ZERO ) NEG1=NEG1+1
+ S = T*TMP
+ IF( TMP.EQ.ZERO ) S = LLD( J )
+ 24 CONTINUE
+ ENDIF
+ 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
+ XSAV = P
+ TO = BJ-BLKLEN+1
+ IF ( TO.GE.R ) THEN
+ DO 25 J = BJ, TO, -1
+ DMINUS = LLD( J ) + P
+ IF( DMINUS.LT.ZERO ) NEG2=NEG2+1
+ TMP = P / DMINUS
+ P = TMP * D( J ) - SIGMA
+ 25 CONTINUE
+ ELSE
+ DO 26 J = BJ, R, -1
+ DMINUS = LLD( J ) + P
+ IF( DMINUS.LT.ZERO ) NEG2=NEG2+1
+ TMP = P / DMINUS
+ P = TMP * D( J ) - SIGMA
+ 26 CONTINUE
+ ENDIF
+ SAWNAN = DISNAN( P )
+*
+ IF( SAWNAN ) THEN
+ NEG2 = 0
+ P = XSAV
+ TO = BJ-BLKLEN+1
+ IF ( TO.GE.R ) THEN
+ DO 27 J = BJ, TO, -1
+ DMINUS = LLD( J ) + P
+ IF(ABS(DMINUS).LT.PIVMIN)
+ $ DMINUS = -PIVMIN
+ TMP = D( J ) / DMINUS
+ IF( DMINUS.LT.ZERO )
+ $ NEG2 = NEG2 + 1
+ P = P*TMP - SIGMA
+ IF( TMP.EQ.ZERO )
+ $ P = D( J ) - SIGMA
+ 27 CONTINUE
+ ELSE
+ DO 28 J = BJ, R, -1
+ DMINUS = LLD( J ) + P
+ IF(ABS(DMINUS).LT.PIVMIN)
+ $ DMINUS = -PIVMIN
+ TMP = D( J ) / DMINUS
+ IF( DMINUS.LT.ZERO )
+ $ NEG2 = NEG2 + 1
+ P = P*TMP - SIGMA
+ IF( TMP.EQ.ZERO )
+ $ P = D( J ) - SIGMA
+ 28 CONTINUE
+ ENDIF
+ END IF
+ NEGCNT = NEGCNT + NEG2
+ 230 CONTINUE
+*
+* III) Twist index
+*
+ GAMMA = S + P
+ IF( GAMMA.LT.ZERO ) NEGCNT = NEGCNT+1
+
+ DLANEG2 = NEGCNT
+ END
+*
+*
+*
+ FUNCTION DLANEG2A( N, DLLD, SIGMA, PIVMIN, R )
+*
+ IMPLICIT NONE
+*
+ INTEGER DLANEG2A
+*
+* .. Scalar Arguments ..
+ INTEGER N, R
+ DOUBLE PRECISION PIVMIN, SIGMA
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION DLLD( * )
+*
+ DOUBLE PRECISION ZERO
+ PARAMETER ( ZERO = 0.0D0 )
+
+ INTEGER BLKLEN
+ PARAMETER ( BLKLEN = 512 )
+*
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC INT
+* ..
+* .. Local Scalars ..
+ INTEGER BJ, I, J, NB, NEG1, NEG2, NEGCNT, NX
+ DOUBLE PRECISION DMINUS, DPLUS, GAMMA, P, S, T, TMP, XSAV
+ LOGICAL SAWNAN
+* ..
+* .. External Functions ..
+ LOGICAL DISNAN
+ EXTERNAL DISNAN
+
+ NEGCNT = 0
+*
+* I) upper part: L D L^T - SIGMA I = L+ D+ L+^T
+* run dstqds block-wise to avoid excessive work when NaNs occur,
+* first in chunks of size BLKLEN and then the remainder
+*
+ NB = INT((R-1)/BLKLEN)
+ NX = NB*BLKLEN
+ S = ZERO
+ DO 210 BJ = 1, NX, BLKLEN
+ NEG1 = 0
+ XSAV = S
+ DO 21 J = BJ, BJ+BLKLEN-1
+ I = 2*J
+ T = S - SIGMA
+ DPLUS = DLLD( I-1 ) + T
+ IF( DPLUS.LT.ZERO ) NEG1=NEG1 + 1
+ S = T*DLLD( I ) / DPLUS
+ 21 CONTINUE
+ SAWNAN = DISNAN( S )
+*
+ IF( SAWNAN ) THEN
+ NEG1 = 0
+ S = XSAV
+ DO 23 J = BJ, BJ+BLKLEN-1
+ I = 2*J
+ T = S - SIGMA
+ DPLUS = DLLD( I-1 ) + T
+ IF(ABS(DPLUS).LT.PIVMIN)
+ $ DPLUS = -PIVMIN
+ TMP = DLLD( I ) / DPLUS
+ IF( DPLUS.LT.ZERO )
+ $ NEG1 = NEG1 + 1
+ S = T*TMP
+ IF( TMP.EQ.ZERO ) S = DLLD( I )
+ 23 CONTINUE
+ END IF
+ NEGCNT = NEGCNT + NEG1
+ 210 CONTINUE
+*
+ NEG1 = 0
+ XSAV = S
+ DO 22 J = NX+1, R-1
+ I = 2*J
+ T = S - SIGMA
+ DPLUS = DLLD( I-1 ) + T
+ IF( DPLUS.LT.ZERO ) NEG1=NEG1 + 1
+ S = T*DLLD( I ) / DPLUS
+ 22 CONTINUE
+ SAWNAN = DISNAN( S )
+*
+ IF( SAWNAN ) THEN
+ NEG1 = 0
+ S = XSAV
+ DO 24 J = NX+1, R-1
+ I = 2*J
+ T = S - SIGMA
+ DPLUS = DLLD( I-1 ) + T
+ IF(ABS(DPLUS).LT.PIVMIN)
+ $ DPLUS = -PIVMIN
+ TMP = DLLD( I ) / DPLUS
+ IF( DPLUS.LT.ZERO ) NEG1=NEG1+1
+ S = T*TMP
+ IF( TMP.EQ.ZERO ) S = DLLD( I )
+ 24 CONTINUE
+ ENDIF
+ NEGCNT = NEGCNT + NEG1
+*
+* II) lower part: L D L^T - SIGMA I = U- D- U-^T
+*
+ NB = INT((N-R)/BLKLEN)
+ NX = N-NB*BLKLEN
+ P = DLLD( 2*N-1 ) - SIGMA
+ DO 230 BJ = N-1, NX, -BLKLEN
+ NEG2 = 0
+ XSAV = P
+ DO 25 J = BJ, BJ-BLKLEN+1, -1
+ I = 2*J
+ DMINUS = DLLD( I ) + P
+ IF( DMINUS.LT.ZERO ) NEG2=NEG2+1
+ TMP = P / DMINUS
+ P = TMP * DLLD( I-1 ) - SIGMA
+ 25 CONTINUE
+ SAWNAN = DISNAN( P )
+*
+ IF( SAWNAN ) THEN
+ NEG2 = 0
+ P = XSAV
+ DO 27 J = BJ, BJ-BLKLEN+1, -1
+ I = 2*J
+ DMINUS = DLLD( I ) + P
+ IF(ABS(DMINUS).LT.PIVMIN)
+ $ DMINUS = -PIVMIN
+ TMP = DLLD( I-1 ) / DMINUS
+ IF( DMINUS.LT.ZERO )
+ $ NEG2 = NEG2 + 1
+ P = P*TMP - SIGMA
+ IF( TMP.EQ.ZERO )
+ $ P = DLLD( I-1 ) - SIGMA
+ 27 CONTINUE
+ END IF
+ NEGCNT = NEGCNT + NEG2
+ 230 CONTINUE
+
+ NEG2 = 0
+ XSAV = P
+ DO 26 J = NX-1, R, -1
+ I = 2*J
+ DMINUS = DLLD( I ) + P
+ IF( DMINUS.LT.ZERO ) NEG2=NEG2+1
+ TMP = P / DMINUS
+ P = TMP * DLLD( I-1 ) - SIGMA
+ 26 CONTINUE
+ SAWNAN = DISNAN( P )
+*
+ IF( SAWNAN ) THEN
+ NEG2 = 0
+ P = XSAV
+ DO 28 J = NX-1, R, -1
+ I = 2*J
+ DMINUS = DLLD( I ) + P
+ IF(ABS(DMINUS).LT.PIVMIN)
+ $ DMINUS = -PIVMIN
+ TMP = DLLD( I-1 ) / DMINUS
+ IF( DMINUS.LT.ZERO )
+ $ NEG2 = NEG2 + 1
+ P = P*TMP - SIGMA
+ IF( TMP.EQ.ZERO )
+ $ P = DLLD( I-1 ) - SIGMA
+ 28 CONTINUE
+ END IF
+ NEGCNT = NEGCNT + NEG2
+*
+* III) Twist index
+*
+ GAMMA = S + P
+ IF( GAMMA.LT.ZERO ) NEGCNT = NEGCNT+1
+
+ DLANEG2A = NEGCNT
+ END
+
diff --git a/SRC/dlarrd2.f b/SRC/dlarrd2.f
new file mode 100644
index 0000000..51aaccc
--- /dev/null
+++ b/SRC/dlarrd2.f
@@ -0,0 +1,678 @@
+ SUBROUTINE DLARRD2( RANGE, ORDER, N, VL, VU, IL, IU, GERS,
+ $ RELTOL, D, E, E2, PIVMIN, NSPLIT, ISPLIT,
+ $ M, W, WERR, WL, WU, IBLOCK, INDEXW,
+ $ WORK, IWORK, DOL, DOU, INFO )
+*
+* -- ScaLAPACK auxiliary routine (version 2.0) --
+* Univ. of Tennessee, Univ. of California Berkeley, Univ of Colorado Denver
+* July 4, 2010
+*
+* .. Scalar Arguments ..
+ CHARACTER ORDER, RANGE
+ INTEGER DOL, DOU, 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( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DLARRD2 computes the eigenvalues of a symmetric tridiagonal
+* matrix T to limited initial accuracy. This is an auxiliary code to be
+* called from DLARRE2A.
+*
+* DLARRD2 has been created using the LAPACK code DLARRD
+* which itself stems from DSTEBZ. The motivation for creating
+* DLARRD2 is efficiency: When computing eigenvalues in parallel
+* and the input tridiagonal matrix splits into blocks, DLARRD2
+* can skip over blocks which contain none of the eigenvalues from
+* DOL to DOU for which the processor responsible. In extreme cases (such
+* as large matrices consisting of many blocks of small size, e.g. 2x2,
+* the gain can be substantial.
+*
+* Arguments
+* =========
+*
+* RANGE (input) CHARACTER
+* = 'A': ("All") all eigenvalues will be found.
+* = 'V': ("Value") all eigenvalues in the half-open interval
+* (VL, VU] will be found.
+* = 'I': ("Index") the IL-th through IU-th eigenvalues (of the
+* entire matrix) will be found.
+*
+* ORDER (input) CHARACTER
+* = 'B': ("By Block") the eigenvalues will be grouped by
+* split-off block (see IBLOCK, ISPLIT) and
+* ordered from smallest to largest within
+* the block.
+* = 'E': ("Entire matrix")
+* the eigenvalues for the entire matrix
+* will be ordered from smallest to
+* largest.
+*
+* N (input) INTEGER
+* The order of the tridiagonal matrix T. N >= 0.
+*
+* VL (input) DOUBLE PRECISION
+* VU (input) DOUBLE PRECISION
+* If RANGE='V', the lower and upper bounds of the interval to
+* be searched for eigenvalues. Eigenvalues less than or equal
+* to VL, or greater than VU, will not be returned. VL < VU.
+* Not referenced if RANGE = 'A' or 'I'.
+*
+* IL (input) INTEGER
+* IU (input) INTEGER
+* If RANGE='I', the indices (in ascending order) of the
+* smallest and largest eigenvalues to be returned.
+* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.
+* Not referenced if RANGE = 'A' or 'V'.
+*
+* GERS (input) DOUBLE PRECISION array, dimension (2*N)
+* The N Gerschgorin intervals (the i-th Gerschgorin interval
+* is (GERS(2*i-1), GERS(2*i)).
+*
+* RELTOL (input) DOUBLE PRECISION
+* The minimum relative width of an interval. When an interval
+* is narrower than RELTOL times the larger (in
+* magnitude) endpoint, then it is considered to be
+* sufficiently small, i.e., converged. Note: this should
+* always be at least radix*machine epsilon.
+*
+* D (input) DOUBLE PRECISION array, dimension (N)
+* The n diagonal elements of the tridiagonal matrix T.
+*
+* E (input) DOUBLE PRECISION array, dimension (N-1)
+* The (n-1) off-diagonal elements of the tridiagonal matrix T.
+*
+* E2 (input) DOUBLE PRECISION array, dimension (N-1)
+* The (n-1) squared off-diagonal elements of the tridiagonal matrix T.
+*
+* PIVMIN (input) DOUBLE PRECISION
+* The minimum pivot allowed in the sturm sequence for T.
+*
+* NSPLIT (input) INTEGER
+* The number of diagonal blocks in the matrix T.
+* 1 <= NSPLIT <= N.
+*
+* ISPLIT (input) INTEGER array, dimension (N)
+* The splitting points, at which T breaks up into submatrices.
+* The first submatrix consists of rows/columns 1 to ISPLIT(1),
+* the second of rows/columns ISPLIT(1)+1 through ISPLIT(2),
+* etc., and the NSPLIT-th consists of rows/columns
+* ISPLIT(NSPLIT-1)+1 through ISPLIT(NSPLIT)=N.
+* (Only the first NSPLIT elements will actually be used, but
+* since the user cannot know a priori what value NSPLIT will
+* have, N words must be reserved for ISPLIT.)
+*
+* M (output) INTEGER
+* The actual number of eigenvalues found. 0 <= M <= N.
+* (See also the description of INFO=2,3.)
+*
+* W (output) DOUBLE PRECISION array, dimension (N)
+* On exit, the first M elements of W will contain the
+* eigenvalue approximations. DLARRD2 computes an interval
+* I_j = (a_j, b_j] that includes eigenvalue j. The eigenvalue
+* approximation is given as the interval midpoint
+* W(j)= ( a_j + b_j)/2. The corresponding error is bounded by
+* WERR(j) = abs( a_j - b_j)/2
+*
+* WERR (output) DOUBLE PRECISION array, dimension (N)
+* The error bound on the corresponding eigenvalue approximation
+* in W.
+*
+* WL (output) DOUBLE PRECISION
+* WU (output) DOUBLE PRECISION
+* The interval (WL, WU] contains all the wanted eigenvalues.
+* If RANGE='V', then WL=VL and WU=VU.
+* If RANGE='A', then WL and WU are the global Gerschgorin bounds
+* on the spectrum.
+* If RANGE='I', then WL and WU are computed by DLAEBZ from the
+* index range specified.
+*
+* IBLOCK (output) INTEGER array, dimension (N)
+* At each row/column j where E(j) is zero or small, the
+* matrix T is considered to split into a block diagonal
+* matrix. On exit, if INFO = 0, IBLOCK(i) specifies to which
+* block (from 1 to the number of blocks) the eigenvalue W(i)
+* belongs. (DLARRD2 may use the remaining N-M elements as
+* workspace.)
+*
+* INDEXW (output) INTEGER array, dimension (N)
+* The indices of the eigenvalues within each block (submatrix);
+* for example, INDEXW(i)= j and IBLOCK(i)=k imply that the
+* i-th eigenvalue W(i) is the j-th eigenvalue in block k.
+*
+* WORK (workspace) DOUBLE PRECISION array, dimension (4*N)
+*
+* IWORK (workspace) INTEGER array, dimension (3*N)
+*
+* DOL (input) INTEGER
+* DOU (input) INTEGER
+* If the user wants to work on only a selected part of the
+* representation tree, he can specify an index range DOL:DOU.
+* Otherwise, the setting DOL=1, DOU=N should be applied.
+* Note that DOL and DOU refer to the order in which the eigenvalues
+* are stored in W.
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+* > 0: some or all of the eigenvalues failed to converge or
+* were not computed:
+* =1 or 3: Bisection failed to converge for some
+* eigenvalues; these eigenvalues are flagged by a
+* negative block number. The effect is that the
+* eigenvalues may not be as accurate as the
+* absolute and relative tolerances. This is
+* generally caused by unexpectedly inaccurate
+* arithmetic.
+* =2 or 3: RANGE='I' only: Not all of the eigenvalues
+* IL:IU were found.
+* Effect: M < IU+1-IL
+* Cause: non-monotonic arithmetic, causing the
+* Sturm sequence to be non-monotonic.
+* Cure: recalculate, using RANGE='A', and pick
+* out eigenvalues IL:IU. In some cases,
+* increasing the PARAMETER "FUDGE" may
+* make things work.
+* = 4: RANGE='I', and the Gershgorin interval
+* initially used was too small. No eigenvalues
+* were computed.
+* Probable cause: your machine has sloppy
+* floating-point arithmetic.
+* Cure: Increase the PARAMETER "FUDGE",
+* recompile, and try again.
+*
+* Internal Parameters
+* ===================
+*
+* FUDGE DOUBLE PRECISION, default = 2 originally, increased to 10.
+* A "fudge factor" to widen the Gershgorin intervals. Ideally,
+* a value of 1 should work, but on machines with sloppy
+* arithmetic, this needs to be larger. The default for
+* publicly released versions should be large enough to handle
+* the worst machine around. Note that this has no effect
+* on accuracy of the solution.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, ONE, TWO, HALF, FUDGE
+ PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0,
+ $ TWO = 2.0D0, HALF = ONE/TWO,
+ $ FUDGE = 10.0D0 )
+
+* ..
+* .. Local Scalars ..
+ LOGICAL NCNVRG, TOOFEW
+ INTEGER I, IB, IBEGIN, IDISCL, IDISCU, IE, IEND, IINFO,
+ $ IM, IN, IOFF, IORDER, IOUT, IRANGE, ITMAX,
+ $ ITMP1, ITMP2, IW, IWOFF, J, JBLK, JDISC, JE,
+ $ JEE, NB, NWL, NWU
+ DOUBLE PRECISION ATOLI, EPS, GL, GU, RTOLI, SPDIAM, 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, 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
+ 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.3 .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.1).OR.
+ $ ((IRANGE.EQ.2).AND.(D(1).GT.VL).AND.(D(1).LE.VU)).OR.
+ $ ((IRANGE.EQ.3).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
+ 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
+ ATOLI = FUDGE*TWO*UFLOW + FUDGE*TWO*PIVMIN
+
+ IF( IRANGE.EQ.3 ) 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.2 ) THEN
+ WL = VL
+ WU = VU
+
+ ELSEIF( IRANGE.EQ.1 ) 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( IRANGE.EQ.1 ) THEN
+ IF( (IEND.LT.DOL).OR.(IBEGIN.GT.DOU) ) THEN
+* the local block contains none of eigenvalues that matter
+* to this processor
+ NWU = NWU + IN
+ DO 30 J = 1, IN
+ M = M + 1
+ IBLOCK( M ) = JBLK
+ 30 CONTINUE
+ GO TO 70
+ END IF
+ END IF
+
+ 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.1 .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
+ 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
+ SPDIAM = GU - GL
+ 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.3 ) 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.1 .AND. M.NE.N ).OR.
+ $ ( IRANGE.EQ.3 .AND. M.NE.IU-IL+1 ) ) THEN
+ TOOFEW = .TRUE.
+ END IF
+
+* If ORDER='B',(IBLOCK = 2), do nothing the eigenvalues are already sorted
+* by block.
+* If ORDER='E',(IBLOCK = 1), 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
+ 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 DLARRD2
+*
+ END
diff --git a/SRC/dlarre2.f b/SRC/dlarre2.f
new file mode 100644
index 0000000..269835a
--- /dev/null
+++ b/SRC/dlarre2.f
@@ -0,0 +1,764 @@
+ SUBROUTINE DLARRE2( RANGE, N, VL, VU, IL, IU, D, E, E2,
+ $ RTOL1, RTOL2, SPLTOL, NSPLIT, ISPLIT,
+ $ M, DOL, DOU,
+ $ W, WERR, WGAP, IBLOCK, INDEXW, GERS, PIVMIN,
+ $ WORK, IWORK, INFO )
+*
+* -- ScaLAPACK auxiliary routine (version 2.0) --
+* Univ. of Tennessee, Univ. of California Berkeley, Univ of Colorado Denver
+* July 4, 2010
+*
+* .. Scalar Arguments ..
+ CHARACTER RANGE
+ INTEGER DOL, DOU, 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( * )
+*
+* Purpose
+* =======
+*
+* To find the desired eigenvalues of a given real symmetric
+* tridiagonal matrix T, DLARRE2 sets, via DLARRA,
+* "small" off-diagonal elements to zero. For each block T_i, it finds
+* (a) a suitable shift at one end of the block's spectrum,
+* (b) the root RRR, 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 returned to
+* DSTEGR2 to compute the eigenvectors T.
+*
+* DLARRE2 is more suitable for parallel computation than the
+* original LAPACK code for computing the root RRR and its eigenvalues.
+* When computing eigenvalues in parallel and the input tridiagonal
+* matrix splits into blocks, DLARRE2
+* can skip over blocks which contain none of the eigenvalues from
+* DOL to DOU for which the processor responsible. In extreme cases (such
+* as large matrices consisting of many blocks of small size, e.g. 2x2,
+* the gain can be substantial.
+*
+* Arguments
+* =========
+*
+* RANGE (input) CHARACTER
+* = 'A': ("All") all eigenvalues will be found.
+* = 'V': ("Value") all eigenvalues in the half-open interval
+* (VL, VU] will be found.
+* = 'I': ("Index") the IL-th through IU-th eigenvalues (of the
+* entire matrix) will be found.
+*
+* N (input) INTEGER
+* The order of the matrix. N > 0.
+*
+* VL (input/output) DOUBLE PRECISION
+* VU (input/output) DOUBLE PRECISION
+* If RANGE='V', the lower and upper bounds for the eigenvalues.
+* Eigenvalues less than or equal to VL, or greater than VU,
+* will not be returned. VL < VU.
+* If RANGE='I' or ='A', DLARRE2 computes bounds on the desired
+* part of the spectrum.
+*
+* IL (input) INTEGER
+* IU (input) INTEGER
+* If RANGE='I', the indices (in ascending order) of the
+* smallest and largest eigenvalues to be returned.
+* 1 <= IL <= IU <= N.
+*
+* D (input/output) DOUBLE PRECISION array, dimension (N)
+* On entry, the N diagonal elements of the tridiagonal
+* matrix T.
+* On exit, the N diagonal elements of the diagonal
+* matrices D_i.
+*
+* E (input/output) DOUBLE PRECISION array, dimension (N)
+* On entry, the first (N-1) entries contain the subdiagonal
+* elements of the tridiagonal matrix T; E(N) need not be set.
+* On exit, E contains the subdiagonal elements of the unit
+* bidiagonal matrices L_i. The entries E( ISPLIT( I ) ),
+* 1 <= I <= NSPLIT, contain the base points sigma_i on output.
+*
+* E2 (input/output) DOUBLE PRECISION array, dimension (N)
+* On entry, the first (N-1) entries contain the SQUARES of the
+* subdiagonal elements of the tridiagonal matrix T;
+* E2(N) need not be set.
+* On exit, the entries E2( ISPLIT( I ) ),
+* 1 <= I <= NSPLIT, have been set to zero
+*
+* RTOL1 (input) DOUBLE PRECISION
+* RTOL2 (input) DOUBLE PRECISION
+* Parameters for bisection.
+* An interval [LEFT,RIGHT] has converged if
+* RIGHT-LEFT.LT.MAX( RTOL1*GAP, RTOL2*MAX(|LEFT|,|RIGHT|) )
+*
+* SPLTOL (input) DOUBLE PRECISION
+* The threshold for splitting.
+*
+* NSPLIT (output) INTEGER
+* The number of blocks T splits into. 1 <= NSPLIT <= N.
+*
+* ISPLIT (output) INTEGER array, dimension (N)
+* The splitting points, at which T breaks up into blocks.
+* The first block consists of rows/columns 1 to ISPLIT(1),
+* the second of rows/columns ISPLIT(1)+1 through ISPLIT(2),
+* etc., and the NSPLIT-th consists of rows/columns
+* ISPLIT(NSPLIT-1)+1 through ISPLIT(NSPLIT)=N.
+*
+* M (output) INTEGER
+* The total number of eigenvalues (of all L_i D_i L_i^T)
+* found.
+*
+* DOL (input) INTEGER
+* DOU (input) INTEGER
+* If the user wants to work on only a selected part of the
+* representation tree, he can specify an index range DOL:DOU.
+* Otherwise, the setting DOL=1, DOU=N should be applied.
+* Note that DOL and DOU refer to the order in which the eigenvalues
+* are stored in W.
+*
+* W (output) DOUBLE PRECISION array, dimension (N)
+* The first M elements contain the eigenvalues. The
+* eigenvalues of each of the blocks, L_i D_i L_i^T, are
+* sorted in ascending order ( DLARRE2 may use the
+* remaining N-M elements as workspace).
+* Note that immediately after exiting this routine, only
+* the eigenvalues from position DOL:DOU in W might be
+* reliable on this processor
+* when the eigenvalue computation is done in parallel.
+*
+* WERR (output) DOUBLE PRECISION array, dimension (N)
+* The error bound on the corresponding eigenvalue in W.
+* Note that immediately after exiting this routine, only
+* the uncertainties from position DOL:DOU in WERR might be
+* reliable on this processor
+* when the eigenvalue computation is done in parallel.
+*
+* WGAP (output) DOUBLE PRECISION array, dimension (N)
+* The separation from the right neighbor eigenvalue in W.
+* The gap is only with respect to the eigenvalues of the same block
+* as each block has its own representation tree.
+* Exception: at the right end of a block we store the left gap
+* Note that immediately after exiting this routine, only
+* the gaps from position DOL:DOU in WGAP might be
+* reliable on this processor
+* when the eigenvalue computation is done in parallel.
+*
+* IBLOCK (output) INTEGER array, dimension (N)
+* The indices of the blocks (submatrices) associated with the
+* corresponding eigenvalues in W; IBLOCK(i)=1 if eigenvalue
+* W(i) belongs to the first block from the top, =2 if W(i)
+* belongs to the second block, etc.
+*
+* INDEXW (output) INTEGER array, dimension (N)
+* The indices of the eigenvalues within each block (submatrix);
+* for example, INDEXW(i)= 10 and IBLOCK(i)=2 imply that the
+* i-th eigenvalue W(i) is the 10-th eigenvalue in block 2
+*
+* GERS (output) DOUBLE PRECISION array, dimension (2*N)
+* The N Gerschgorin intervals (the i-th Gerschgorin interval
+* is (GERS(2*i-1), GERS(2*i)).
+*
+* PIVMIN (output) DOUBLE PRECISION
+* The minimum pivot in the sturm sequence for T.
+*
+* WORK (workspace) DOUBLE PRECISION array, dimension (6*N)
+* Workspace.
+*
+* IWORK (workspace) INTEGER array, dimension (5*N)
+* Workspace.
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* > 0: A problem occured in DLARRE2.
+* < 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.
+*
+* =====================================================================
+*
+* .. 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
+ PARAMETER ( MAXTRY = 6 )
+* ..
+* .. Local Scalars ..
+ LOGICAL FORCEB, NOREP, RNDPRT, 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
+
+* Dis-/Enable a small random perturbation of the root representation
+ RNDPRT = .TRUE.
+*
+* 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
+ END IF
+
+ M = 0
+
+* Get machine constants
+ SAFMIN = DLAMCH( 'S' )
+ EPS = DLAMCH( 'P' )
+
+* Set parameters
+ RTL = SQRT(EPS)
+ BSRTOL = 1.0D-1
+
+* Treat case of 1x1 matrix for quick return
+ IF( N.EQ.1 ) THEN
+ IF( (IRANGE.EQ.1).OR.
+ $ ((IRANGE.EQ.2).AND.(D(1).GT.VL).AND.(D(1).LE.VU)).OR.
+ $ ((IRANGE.EQ.3).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
+ FORCEB = .FALSE.
+
+ IF( (IRANGE.EQ.1) .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 = 3, 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.1).OR.( (IRANGE.EQ.2).AND.
+ $ ( D( IBEGIN ).GT.VL ).AND.( D( IBEGIN ).LE.VU ) )
+ $ .OR. ( (IRANGE.EQ.3).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.1).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
+ ELSE
+* MB = number of eigenvalues to compute
+ MB = IN
+ WEND = WBEGIN + MB - 1
+ INDL = 1
+ INDU = IN
+ ENDIF
+
+ IF( (WEND.LT.DOL).OR.(WBEGIN.GT.DOU) ) THEN
+* if this subblock contains no desired eigenvalues,
+* skip the computation of this representation tree
+ IBEGIN = IEND + 1
+ WBEGIN = WEND + 1
+ M = M + INDU - INDL + 1
+ GO TO 170
+ END IF
+
+* 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))
+ IF(( (IRANGE.EQ.1) .AND. (.NOT. FORCEB) ).OR.USEDQD) THEN
+* Case of DQDS
+* 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 DLARRE2 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.1 ) .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.1 ) .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.1 ) .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
+ TAU = SPDIAM*EPS*N + TWO*PIVMIN
+ TAU = MAX(TAU,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(NOREP) THEN
+* Note that in the case of IRANGE=1, we use the Gerschgorin
+* shift which makes the matrix definite. So we should end up
+* here really only in the case of IRANGE = 2,3
+ 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(RNDPRT .AND. 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 DLARRE2
+*
+ END
diff --git a/SRC/dlarre2a.f b/SRC/dlarre2a.f
new file mode 100644
index 0000000..f58cb81
--- /dev/null
+++ b/SRC/dlarre2a.f
@@ -0,0 +1,774 @@
+ SUBROUTINE DLARRE2A( RANGE, N, VL, VU, IL, IU, D, E, E2,
+ $ RTOL1, RTOL2, SPLTOL, NSPLIT, ISPLIT,
+ $ M, DOL, DOU, NEEDIL, NEEDIU,
+ $ W, WERR, WGAP, IBLOCK, INDEXW, GERS,
+ $ SDIAM, PIVMIN, WORK, IWORK, MINRGP, INFO )
+*
+* -- ScaLAPACK auxiliary routine (version 2.0) --
+* Univ. of Tennessee, Univ. of California Berkeley, Univ of Colorado Denver
+* July 4, 2010
+*
+ IMPLICIT NONE
+*
+* .. Scalar Arguments ..
+ CHARACTER RANGE
+ INTEGER DOL, DOU, IL, INFO, IU, M, N, NSPLIT,
+ $ NEEDIL, NEEDIU
+ DOUBLE PRECISION MINRGP, PIVMIN, RTOL1, RTOL2, SPLTOL, VL, VU
+* ..
+* .. Array Arguments ..
+ INTEGER IBLOCK( * ), ISPLIT( * ), IWORK( * ),
+ $ INDEXW( * )
+ DOUBLE PRECISION D( * ), E( * ), E2( * ), GERS( * ),
+ $ SDIAM( * ), W( * ),WERR( * ),
+ $ WGAP( * ), WORK( * )
+*
+* Purpose
+* =======
+*
+* To find the desired eigenvalues of a given real symmetric
+* tridiagonal matrix T, DLARRE2 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.
+*
+* NOTE:
+* The algorithm obtains a crude picture of all the wanted eigenvalues
+* (as selected by RANGE). However, to reduce work and improve scalability,
+* only the eigenvalues DOL to DOU are refined. Furthermore, if the matrix
+* splits into blocks, RRRs for blocks that do not contain eigenvalues
+* from DOL to DOU are skipped.
+* The DQDS algorithm (subroutine DLASQ2) is not used, unlike in
+* the sequential case. Instead, eigenvalues are computed in parallel to some
+* figures using bisection.
+
+*
+* Arguments
+* =========
+*
+* RANGE (input) CHARACTER
+* = 'A': ("All") all eigenvalues will be found.
+* = 'V': ("Value") all eigenvalues in the half-open interval
+* (VL, VU] will be found.
+* = 'I': ("Index") the IL-th through IU-th eigenvalues (of the
+* entire matrix) will be found.
+*
+* N (input) INTEGER
+* The order of the matrix. N > 0.
+*
+* VL (input/output) DOUBLE PRECISION
+* VU (input/output) DOUBLE PRECISION
+* If RANGE='V', the lower and upper bounds for the eigenvalues.
+* Eigenvalues less than or equal to VL, or greater than VU,
+* will not be returned. VL < VU.
+* If RANGE='I' or ='A', DLARRE2A computes bounds on the desired
+* part of the spectrum.
+*
+* IL (input) INTEGER
+* IU (input) INTEGER
+* If RANGE='I', the indices (in ascending order) of the
+* smallest and largest eigenvalues to be returned.
+* 1 <= IL <= IU <= N.
+*
+* D (input/output) DOUBLE PRECISION array, dimension (N)
+* On entry, the N diagonal elements of the tridiagonal
+* matrix T.
+* On exit, the N diagonal elements of the diagonal
+* matrices D_i.
+*
+* E (input/output) DOUBLE PRECISION array, dimension (N)
+* On entry, the first (N-1) entries contain the subdiagonal
+* elements of the tridiagonal matrix T; E(N) need not be set.
+* On exit, E contains the subdiagonal elements of the unit
+* bidiagonal matrices L_i. The entries E( ISPLIT( I ) ),
+* 1 <= I <= NSPLIT, contain the base points sigma_i on output.
+*
+* E2 (input/output) DOUBLE PRECISION array, dimension (N)
+* On entry, the first (N-1) entries contain the SQUARES of the
+* subdiagonal elements of the tridiagonal matrix T;
+* E2(N) need not be set.
+* On exit, the entries E2( ISPLIT( I ) ),
+* 1 <= I <= NSPLIT, have been set to zero
+*
+* RTOL1 (input) DOUBLE PRECISION
+* RTOL2 (input) DOUBLE PRECISION
+* Parameters for bisection.
+* An interval [LEFT,RIGHT] has converged if
+* RIGHT-LEFT.LT.MAX( RTOL1*GAP, RTOL2*MAX(|LEFT|,|RIGHT|) )
+*
+* SPLTOL (input) DOUBLE PRECISION
+* The threshold for splitting.
+*
+* NSPLIT (output) INTEGER
+* The number of blocks T splits into. 1 <= NSPLIT <= N.
+*
+* ISPLIT (output) INTEGER array, dimension (N)
+* The splitting points, at which T breaks up into blocks.
+* The first block consists of rows/columns 1 to ISPLIT(1),
+* the second of rows/columns ISPLIT(1)+1 through ISPLIT(2),
+* etc., and the NSPLIT-th consists of rows/columns
+* ISPLIT(NSPLIT-1)+1 through ISPLIT(NSPLIT)=N.
+*
+* M (output) INTEGER
+* The total number of eigenvalues (of all L_i D_i L_i^T)
+* found.
+*
+* DOL (input) INTEGER
+* DOU (input) INTEGER
+* If the user wants to work on only a selected part of the
+* representation tree, he can specify an index range DOL:DOU.
+* Otherwise, the setting DOL=1, DOU=N should be applied.
+* Note that DOL and DOU refer to the order in which the eigenvalues
+* are stored in W.
+*
+* NEEDIL (output) INTEGER
+* NEEDIU (output) INTEGER
+* The indices of the leftmost and rightmost eigenvalues
+* of the root node RRR which are
+* needed to accurately compute the relevant part of the
+* representation tree.
+*
+* W (output) DOUBLE PRECISION array, dimension (N)
+* The first M elements contain the eigenvalues. The
+* eigenvalues of each of the blocks, L_i D_i L_i^T, are
+* sorted in ascending order ( DLARRE2A may use the
+* remaining N-M elements as workspace).
+* Note that immediately after exiting this routine, only
+* the eigenvalues from position DOL:DOU in W are
+* reliable on this processor
+* because the eigenvalue computation is done in parallel.
+*
+* WERR (output) DOUBLE PRECISION array, dimension (N)
+* The error bound on the corresponding eigenvalue in W.
+* Note that immediately after exiting this routine, only
+* the uncertainties from position DOL:DOU in WERR are
+* reliable on this processor
+* because the eigenvalue computation is done in parallel.
+*
+* WGAP (output) DOUBLE PRECISION array, dimension (N)
+* The separation from the right neighbor eigenvalue in W.
+* The gap is only with respect to the eigenvalues of the same block
+* as each block has its own representation tree.
+* Exception: at the right end of a block we store the left gap
+* Note that immediately after exiting this routine, only
+* the gaps from position DOL:DOU in WGAP are
+* reliable on this processor
+* because the eigenvalue computation is done in parallel.
+*
+* IBLOCK (output) INTEGER array, dimension (N)
+* The indices of the blocks (submatrices) associated with the
+* corresponding eigenvalues in W; IBLOCK(i)=1 if eigenvalue
+* W(i) belongs to the first block from the top, =2 if W(i)
+* belongs to the second block, etc.
+*
+* INDEXW (output) INTEGER array, dimension (N)
+* The indices of the eigenvalues within each block (submatrix);
+* for example, INDEXW(i)= 10 and IBLOCK(i)=2 imply that the
+* i-th eigenvalue W(i) is the 10-th eigenvalue in block 2
+*
+* GERS (output) DOUBLE PRECISION array, dimension (2*N)
+* The N Gerschgorin intervals (the i-th Gerschgorin interval
+* is (GERS(2*i-1), GERS(2*i)).
+*
+* PIVMIN (output) DOUBLE PRECISION
+* The minimum pivot in the sturm sequence for T.
+*
+* WORK (workspace) DOUBLE PRECISION array, dimension (6*N)
+* Workspace.
+*
+* IWORK (workspace) INTEGER array, dimension (5*N)
+* Workspace.
+*
+* MINRGP (input) DOUBLE PRECISION
+* The minimum relativ gap threshold to decide whether an eigenvalue
+* or a cluster boundary is reached.
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* > 0: A problem occured in DLARRE2A.
+* < 0: One of the called subroutines signaled an internal problem.
+* Needs inspection of the corresponding parameter IINFO
+* for further information.
+*
+* =-1: Problem in DLARRD2.
+* = 2: No base representation could be found in MAXTRY iterations.
+* Increasing MAXTRY and recompilation might be a remedy.
+* =-3: Problem in DLARRB2 when computing the refined root
+* representation
+* =-4: Problem in DLARRB2 when preforming bisection on the
+* desired part of the spectrum.
+* = -9 Problem: M < DOU-DOL+1, that is the code found fewer
+* eigenvalues than it was supposed to
+*
+*
+* =====================================================================
+*
+* .. 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
+ PARAMETER ( MAXTRY = 6 )
+* ..
+* .. Local Scalars ..
+ LOGICAL NOREP, RNDPRT, USEDQD
+ INTEGER CNT, CNT1, CNT2, I, IBEGIN, IDUM, IEND, IINFO,
+ $ IN, INDL, INDU, IRANGE, J, JBLK, MB, MM,
+ $ MYINDL, MYINDU, MYWBEG, MYWEND, WBEGIN, WEND
+ DOUBLE PRECISION AVGAP, BSRTOL, CLWDTH, DMAX, DPIVOT, EABS,
+ $ EMAX, EOLD, EPS, GL, GU, ISLEFT, ISRGHT,
+ $ LGPVMN, LGSPDM, RTL, S1, S2, SAFMIN, SGNDEF,
+ $ SIGMA, SPDIAM, TAU, TMP, TMP1, TMP2
+
+
+* ..
+* .. Local Arrays ..
+ INTEGER ISEED( 4 )
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ DOUBLE PRECISION DLAMCH
+ EXTERNAL DLAMCH, LSAME
+
+* ..
+* .. External Subroutines ..
+ EXTERNAL DCOPY, DLARNV, DLARRA, DLARRB2,
+ $ DLARRC, DLARRD2
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX, MIN
+
+* ..
+* .. Executable Statements ..
+*
+
+ INFO = 0
+
+* Dis-/Enable a small random perturbation of the root representation
+ RNDPRT = .TRUE.
+*
+* 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
+ END IF
+
+ M = 0
+
+* Get machine constants
+ SAFMIN = DLAMCH( 'S' )
+ EPS = DLAMCH( 'P' )
+
+* Set parameters
+ RTL = SQRT(EPS)
+ BSRTOL = 1.0D-1
+
+* Treat case of 1x1 matrix for quick return
+ IF( N.EQ.1 ) THEN
+ IF( (IRANGE.EQ.1).OR.
+ $ ((IRANGE.EQ.2).AND.(D(1).GT.VL).AND.(D(1).LE.VU)).OR.
+ $ ((IRANGE.EQ.3).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.
+ DO 1 I =1,N
+ WERR(I) = ZERO
+ 1 CONTINUE
+ DO 2 I =1,N
+ WGAP(I) = ZERO
+ 2 CONTINUE
+
+* 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
+ EABS = ABS( E(I) )
+ IF( EABS .GE. EMAX ) THEN
+ EMAX = EABS
+ END IF
+ TMP = EABS + EOLD
+ EOLD = EABS
+ TMP1 = D(I) - TMP
+ TMP2 = D(I) + TMP
+ GL = MIN( GL, TMP1 )
+ GU = MAX( GU, TMP2 )
+ GERS( 2*I-1) = TMP1
+ GERS( 2*I ) = TMP2
+ 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 )
+
+ IF( IRANGE.EQ.1 ) THEN
+* Set interval [VL,VU] that contains all eigenvalues
+ VL = GL
+ VU = GU
+ ENDIF
+
+* We call DLARRD2 to find crude approximations to the eigenvalues
+* in the desired range. In case IRANGE = 3, 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))
+* DLARRD2 needs a WORK of size 4*N, IWORK of size 3*N
+ CALL DLARRD2( RANGE, 'B', N, VL, VU, IL, IU, GERS,
+ $ BSRTOL, D, E, E2, PIVMIN, NSPLIT, ISPLIT,
+ $ MM, W, WERR, VL, VU, IBLOCK, INDEXW,
+ $ WORK, IWORK, DOL, DOU, 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
+
+
+***
+* 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.1).OR.( (IRANGE.EQ.2).AND.
+ $ ( D( IBEGIN ).GT.VL ).AND.( D( IBEGIN ).LE.VU ) )
+ $ .OR. ( (IRANGE.EQ.3).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
+
+ IF( ( IRANGE.EQ.1 ) .OR.
+ $ ((IRANGE.EQ.3).AND.(IL.EQ.1.AND.IU.EQ.N)) ) THEN
+* MB = number of eigenvalues to compute
+ MB = IN
+ WEND = WBEGIN + MB - 1
+ INDL = 1
+ INDU = IN
+ ELSE
+* 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
+ ENDIF
+*
+ WEND = WBEGIN + MB - 1
+* Find local index of the first and last desired evalue.
+ INDL = INDEXW(WBEGIN)
+ INDU = INDEXW( WEND )
+ ENDIF
+*
+ IF( (WEND.LT.DOL).OR.(WBEGIN.GT.DOU) ) THEN
+* if this subblock contains no desired eigenvalues,
+* skip the computation of this representation tree
+ IBEGIN = IEND + 1
+ WBEGIN = WEND + 1
+ M = M + MB
+ GO TO 170
+ END IF
+*
+ IF(.NOT. ( IRANGE.EQ.1 ) ) THEN
+
+* At this point, the sequential code decides
+* whether dqds or bisection is more efficient.
+* Note: in the parallel code, we do not use dqds.
+* However, we do not change the shift strategy
+* if USEDQD is TRUE, then the same shift is used as for
+* the sequential code when it uses dqds.
+*
+ USEDQD = ( MB .GT. FAC*IN )
+*
+* 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 )))
+ ENDIF
+
+*
+* 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
+* Save local spectral diameter for later use
+ SDIAM(JBLK) = SPDIAM
+
+* 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))
+ IF( ( IRANGE.EQ.1 ).OR.USEDQD ) THEN
+* Case of DQDS shift
+* 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"
+ IF( IRANGE.EQ.1 ) 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
+* DLARRD2 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.2) THEN
+ CALL DLARRC( 'T', IN, S1, S2, D(IBEGIN),
+ $ E(IBEGIN), PIVMIN, CNT, CNT1, CNT2, IINFO)
+ ENDIF
+
+ IF(MB.LE.2) THEN
+ SIGMA = GL
+ SGNDEF = ONE
+ ELSEIF( CNT1 - INDL .GE. INDU - CNT2 ) THEN
+ IF( IRANGE.EQ.1 ) THEN
+ SIGMA = MAX(ISLEFT,GL)
+ ELSEIF( USEDQD ) THEN
+* use Gerschgorin bound as shift to get pos def matrix
+ 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.1 ) 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
+ TAU = SPDIAM*EPS*N + TWO*PIVMIN
+ TAU = MAX(TAU,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(NOREP) THEN
+* Note that in the case of IRANGE=1, we use the Gerschgorin
+* shift which makes the matrix definite. So we should end up
+* here really only in the case of IRANGE = 2,3
+ 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(RNDPRT .AND. 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(2*I-1))
+ E(IBEGIN+I-1) = E(IBEGIN+I-1)*(ONE+EPS*PERT*WORK(2*I))
+ 125 CONTINUE
+ D(IEND) = D(IEND)*(ONE+EPS*PERT*WORK(2*IN-1))
+*
+ ENDIF
+*
+* Compute the required eigenvalues of L D L' by bisection
+* Shift the eigenvalue approximations
+* according to the shift of their representation.
+ DO 134 J=WBEGIN,WEND
+ W(J) = W(J) - SIGMA
+ WERR(J) = WERR(J) + ABS(W(J)) * EPS
+ 134 CONTINUE
+* call DLARRB2 to reduce eigenvalue error of the approximations
+* from DLARRD2
+ DO 135 I = IBEGIN, IEND-1
+ WORK( I ) = D( I ) * E( I )**2
+ 135 CONTINUE
+* use bisection to find EV from INDL to INDU
+ INDL = INDEXW( WBEGIN )
+ INDU = INDEXW( WEND )
+*
+* Indicate that the current block contains eigenvalues that
+* are potentially needed later.
+*
+ NEEDIL = MIN(NEEDIL,WBEGIN)
+ NEEDIU = MAX(NEEDIU,WEND)
+*
+* For the parallel distributed case, only compute
+* those eigenvalues that have to be computed as indicated by DOL, DOU
+*
+ MYWBEG = MAX(WBEGIN,DOL)
+ MYWEND = MIN(WEND,DOU)
+*
+ IF(MYWBEG.GT.WBEGIN) THEN
+* This is the leftmost block containing wanted eigenvalues
+* as well as unwanted ones. To save on communication,
+* check if NEEDIL can be increased even further:
+* on the left end, only the eigenvalues of the cluster
+* including MYWBEG are needed
+ DO 136 I = WBEGIN, MYWBEG-1
+ IF ( WGAP(I).GE.MINRGP*ABS(W(I)) ) THEN
+ NEEDIL = MAX(I+1,NEEDIL)
+ ENDIF
+ 136 CONTINUE
+ ENDIF
+ IF(MYWEND.LT.WEND) THEN
+* This is the rightmost block containing wanted eigenvalues
+* as well as unwanted ones. To save on communication,
+* Check if NEEDIU can be decreased even further.
+ DO 137 I = MYWEND,WEND-1
+ IF ( WGAP(I).GE.MINRGP*ABS(W(I)) ) THEN
+ NEEDIU = MIN(I,NEEDIU)
+ GOTO 138
+ ENDIF
+ 137 CONTINUE
+ 138 CONTINUE
+ ENDIF
+*
+* Only compute eigenvalues from MYINDL to MYINDU
+* instead of INDL to INDU
+*
+ MYINDL = INDEXW( MYWBEG )
+ MYINDU = INDEXW( MYWEND )
+*
+ LGPVMN = LOG( PIVMIN )
+ LGSPDM = LOG( SPDIAM + PIVMIN )
+
+ CALL DLARRB2(IN, D(IBEGIN), WORK(IBEGIN),
+ $ MYINDL, MYINDU, RTOL1, RTOL2, MYINDL-1,
+ $ W(MYWBEG), WGAP(MYWBEG), WERR(MYWBEG),
+ $ WORK( 2*N+1 ), IWORK, PIVMIN,
+ $ LGPVMN, LGSPDM, IN, IINFO )
+ IF( IINFO .NE. 0 ) THEN
+ INFO = -4
+ RETURN
+ END IF
+* DLARRB2 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 140 I = INDL, INDU
+ M = M + 1
+ IBLOCK(M) = JBLK
+ INDEXW(M) = I
+ 140 CONTINUE
+*
+* proceed with next block
+ IBEGIN = IEND + 1
+ WBEGIN = WEND + 1
+ 170 CONTINUE
+*
+ IF (M.LT.DOU-DOL+1) THEN
+ INFO = -9
+ ENDIF
+
+
+ RETURN
+*
+* end of DLARRE2A
+*
+ END
diff --git a/SRC/dlarrf2.f b/SRC/dlarrf2.f
new file mode 100644
index 0000000..307c67c
--- /dev/null
+++ b/SRC/dlarrf2.f
@@ -0,0 +1,354 @@
+ SUBROUTINE DLARRF2( N, D, L, LD, CLSTRT, CLEND,
+ $ CLMID1, CLMID2, W, WGAP, WERR, TRYMID,
+ $ SPDIAM, CLGAPL, CLGAPR, PIVMIN, SIGMA,
+ $ DPLUS, LPLUS, WORK, INFO )
+*
+* -- ScaLAPACK computational routine (version 2.0) --
+* Univ. of Tennessee, Univ. of California Berkeley, Univ of Colorado Denver
+* July 4, 2010
+*
+ IMPLICIT NONE
+*
+* .. Scalar Arguments ..
+ INTEGER CLSTRT, CLEND, CLMID1, CLMID2, INFO, N
+ DOUBLE PRECISION CLGAPL, CLGAPR, PIVMIN, SIGMA, SPDIAM
+ LOGICAL TRYMID
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION D( * ), DPLUS( * ), L( * ), LD( * ),
+ $ LPLUS( * ), W( * ), WGAP( * ), WERR( * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* Given the initial representation L D L^T and its cluster of close
+* eigenvalues (in a relative measure), W( CLSTRT ), W( CLSTRT+1 ), ...
+* W( CLEND ), DLARRF2 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.
+*
+* This is an enhanced version of DLARRF that also tries shifts in
+* the middle of the cluster, should there be a large gap, in order to
+* break large clusters into at least two pieces.
+*
+* Arguments
+* =========
+*
+* N (input) INTEGER
+* The order of the matrix (subblock, if the matrix splitted).
+*
+* D (input) DOUBLE PRECISION array, dimension (N)
+* The N diagonal elements of the diagonal matrix D.
+*
+* L (input) DOUBLE PRECISION array, dimension (N-1)
+* The (N-1) subdiagonal elements of the unit bidiagonal
+* matrix L.
+*
+* LD (input) DOUBLE PRECISION array, dimension (N-1)
+* The (N-1) elements L(i)*D(i).
+*
+* CLSTRT (input) INTEGER
+* The index of the first eigenvalue in the cluster.
+*
+* CLEND (input) INTEGER
+* The index of the last eigenvalue in the cluster.
+*
+* CLMID1,2(input) INTEGER
+* The index of a middle eigenvalue pair with large gap
+*
+* W (input) DOUBLE PRECISION array, dimension >= (CLEND-CLSTRT+1)
+* The eigenvalue APPROXIMATIONS of L D L^T in ascending order.
+* W( CLSTRT ) through W( CLEND ) form the cluster of relatively
+* close eigenalues.
+*
+* WGAP (input/output) DOUBLE PRECISION array, dimension >= (CLEND-CLSTRT+1)
+* The separation from the right neighbor eigenvalue in W.
+*
+* WERR (input) DOUBLE PRECISION array, dimension >= (CLEND-CLSTRT+1)
+* WERR contain the semiwidth of the uncertainty
+* interval of the corresponding eigenvalue APPROXIMATION in W
+*
+* SPDIAM (input) estimate of the spectral diameter obtained from the
+* Gerschgorin intervals
+*
+* CLGAPL, CLGAPR (input) absolute gap on each end of the cluster.
+* Set by the calling routine to protect against shifts too close
+* to eigenvalues outside the cluster.
+*
+* PIVMIN (input) DOUBLE PRECISION
+* The minimum pivot allowed in the sturm sequence.
+*
+* SIGMA (output) DOUBLE PRECISION
+* The shift used to form L(+) D(+) L(+)^T.
+*
+* DPLUS (output) DOUBLE PRECISION array, dimension (N)
+* The N diagonal elements of the diagonal matrix D(+).
+*
+* LPLUS (output) DOUBLE PRECISION array, dimension (N-1)
+* The first (N-1) elements of LPLUS contain the subdiagonal
+* elements of the unit bidiagonal matrix L(+).
+*
+* WORK (workspace) DOUBLE PRECISION array, dimension (2*N)
+* Workspace.
+*
+* Further Details
+* ===============
+*
+* Based on contributions by
+* Beresford Parlett, University of California, Berkeley, USA
+* Jim Demmel, University of California, Berkeley, USA
+* Inderjit Dhillon, University of Texas, Austin, USA
+* Osni Marques, LBNL/NERSC, USA
+* Christof Voemel, University of California, Berkeley, USA
+*
+* =====================================================================
+*
+* .. Parameters ..
+ 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, NOFAIL, SAWNAN1, SAWNAN2, TRYRRR1
+ INTEGER BI,I,J,KTRY,KTRYMAX,SLEFT,SRIGHT,SMID,SHIFT
+ PARAMETER ( KTRYMAX = 1, SMID =0, SLEFT = 1, SRIGHT = 2 )
+
+* DSTQDS loops will be blocked to detect NaNs earlier if they occur
+ INTEGER BLKLEN
+ PARAMETER ( BLKLEN = 512 )
+
+
+ DOUBLE PRECISION AVGAP, BESTSHIFT, CLWDTH, EPS, FACT, FAIL,
+ $ FAIL2, GROWTHBOUND, LDELTA, LDMAX, LEASTGROWTH,
+ $ LSIGMA, MAX1, MAX2, MINGAP, MSIGMA1, MSIGMA2,
+ $ OLDP, PROD, RDELTA, RDMAX, RRR1, RRR2, RSIGMA,
+ $ S, 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
+
+* Decide whether the code should accept the best among all
+* representations despite large element growth or signal INFO=1
+ NOFAIL = .TRUE.
+*
+
+* Compute the average gap length of the cluster
+ CLWDTH = 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 )
+ MSIGMA1 = W( CLMID1 ) + WERR( CLMID1 )
+ MSIGMA2 = W( CLMID2 ) - WERR( CLMID2 )
+
+* 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' )
+ LEASTGROWTH = ONE / S
+ FAIL = DBLE(N-1)*MINGAP/(SPDIAM*EPS)
+ FAIL2 = DBLE(N-1)*MINGAP/(SPDIAM*SQRT(EPS))
+ GROWTHBOUND = MAXGROWTH1*SPDIAM
+
+*
+* Set default best shift
+*
+ BESTSHIFT = LSIGMA
+
+
+ IF(.NOT.TRYMID) GOTO 4
+*
+* Try shifts in the middle
+*
+ SHIFT = SMID
+
+ DO 3 J=1,2
+ SAWNAN1 = .FALSE.
+ IF(J.EQ.1) THEN
+* Try left middle point
+ SIGMA = MSIGMA1
+ ELSE
+* Try left middle point
+ SIGMA = MSIGMA2
+ ENDIF
+
+ S = -SIGMA
+ DPLUS( 1 ) = D( 1 ) + S
+ MAX1 = ABS( DPLUS( 1 ) )
+ DO 2 BI = 1, N-1, BLKLEN
+ DO 1 I = BI, MIN( BI+BLKLEN-1, N-1)
+ LPLUS( I ) = LD( I ) / DPLUS( I )
+ S = S*LPLUS( I )*L( I ) - SIGMA
+ DPLUS( I+1 ) = D( I+1 ) + S
+ MAX1 = MAX( MAX1,ABS(DPLUS(I+1)) )
+ 1 CONTINUE
+ SAWNAN1=SAWNAN1 .OR. DISNAN(MAX1)
+ IF (SAWNAN1) GOTO 3
+ 2 CONTINUE
+
+ IF( .NOT.SAWNAN1 ) THEN
+ IF( MAX1.LE.GROWTHBOUND ) THEN
+ GOTO 100
+ ELSE IF( MAX1.LE.LEASTGROWTH ) THEN
+ LEASTGROWTH = MAX1
+ BESTSHIFT = SIGMA
+ ENDIF
+ ENDIF
+ 3 CONTINUE
+
+
+ 4 CONTINUE
+*
+* Shifts in the middle not tried or not succeeded
+* Find best shift on the outside of the cluster
+*
+* while (KTRY <= KTRYMAX)
+ KTRY = 0
+*
+*
+*
+ 5 CONTINUE
+
+* Compute element growth when shifting to both ends of the cluster
+* accept shift if there is no element growth at one of the two ends
+
+* Left end
+ SAWNAN1 = .FALSE.
+ S = -LSIGMA
+ DPLUS( 1 ) = D( 1 ) + S
+ MAX1 = ABS( DPLUS( 1 ) )
+ DO 12 BI = 1, N-1, BLKLEN
+ DO 11 I = BI, MIN( BI+BLKLEN-1, N-1)
+ LPLUS( I ) = LD( I ) / DPLUS( I )
+ S = S*LPLUS( I )*L( I ) - LSIGMA
+ DPLUS( I+1 ) = D( I+1 ) + S
+ MAX1 = MAX( MAX1,ABS(DPLUS(I+1)) )
+ 11 CONTINUE
+ SAWNAN1=SAWNAN1 .OR. DISNAN(MAX1)
+ IF (SAWNAN1) GOTO 13
+ 12 CONTINUE
+ IF( .NOT.SAWNAN1 ) THEN
+ IF( MAX1.LE.GROWTHBOUND ) THEN
+ SIGMA = LSIGMA
+ SHIFT = SLEFT
+ GOTO 100
+ ELSE IF( MAX1.LE.LEASTGROWTH ) THEN
+ LEASTGROWTH = MAX1
+ BESTSHIFT = LSIGMA
+ ENDIF
+ ENDIF
+ 13 CONTINUE
+
+* Right end
+ SAWNAN2 = .FALSE.
+ S = -RSIGMA
+ WORK( 1 ) = D( 1 ) + S
+ MAX2 = ABS( WORK( 1 ) )
+ DO 22 BI = 1, N-1, BLKLEN
+ DO 21 I = BI, MIN( BI+BLKLEN-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
+ MAX2 = MAX( MAX2,ABS(WORK(I+1)) )
+ 21 CONTINUE
+ SAWNAN2=SAWNAN2 .OR. DISNAN(MAX2)
+ IF (SAWNAN2) GOTO 23
+ 22 CONTINUE
+ IF( .NOT.SAWNAN2 ) THEN
+ IF( MAX2.LE.GROWTHBOUND ) THEN
+ SIGMA = RSIGMA
+ SHIFT = SRIGHT
+ GOTO 100
+ ELSE IF( MAX2.LE.LEASTGROWTH ) THEN
+ LEASTGROWTH = MAX2
+ BESTSHIFT = RSIGMA
+ ENDIF
+ ENDIF
+ 23 CONTINUE
+
+* If we are at this point, both shifts led to too much element growth
+
+ 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
+* Ensure that we do not back off too much of the initial shifts
+ LDELTA = MIN(LDMAX,LDELTA)
+ RDELTA = MIN(RDMAX,RDELTA)
+ KTRY = KTRY + 1
+ GOTO 5
+ ELSE
+* None of the representations investigated satisfied our
+* criteria. Take the best one we found.
+ IF((LEASTGROWTH.LT.FAIL).OR.NOFAIL) THEN
+ LSIGMA = BESTSHIFT
+ SAWNAN1 = .FALSE.
+ S = -LSIGMA
+ DPLUS( 1 ) = D( 1 ) + S
+ 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
+ ENDIF
+ 6 CONTINUE
+ SIGMA = LSIGMA
+ SHIFT = SLEFT
+ GOTO 100
+ ELSE
+ INFO = 1
+ RETURN
+ ENDIF
+ END IF
+
+ 100 CONTINUE
+ IF (SHIFT.EQ.SLEFT .OR. SHIFT.EQ.SMID ) 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 DLARRF2
+*
+ END
diff --git a/SRC/dlarrv2.f b/SRC/dlarrv2.f
new file mode 100644
index 0000000..bb54830
--- /dev/null
+++ b/SRC/dlarrv2.f
@@ -0,0 +1,1166 @@
+ SUBROUTINE DLARRV2( N, VL, VU, D, L, PIVMIN,
+ $ ISPLIT, M, DOL, DOU, NEEDIL, NEEDIU,
+ $ MINRGP, RTOL1, RTOL2, W, WERR, WGAP,
+ $ IBLOCK, INDEXW, GERS, SDIAM,
+ $ Z, LDZ, ISUPPZ,
+ $ WORK, IWORK, VSTART, FINISH,
+ $ MAXCLS, NDEPTH, PARITY, ZOFFSET, INFO )
+
+* -- ScaLAPACK auxiliary routine (version 2.0) --
+* Univ. of Tennessee, Univ. of California Berkeley, Univ of Colorado Denver
+* July 4, 2010
+*
+ IMPLICIT NONE
+*
+* .. Scalar Arguments ..
+ INTEGER DOL, DOU, INFO, LDZ, M, N, MAXCLS,
+ $ NDEPTH, NEEDIL, NEEDIU, PARITY, ZOFFSET
+ DOUBLE PRECISION MINRGP, PIVMIN, RTOL1, RTOL2, VL, VU
+ LOGICAL VSTART, FINISH
+* ..
+* .. Array Arguments ..
+ INTEGER IBLOCK( * ), INDEXW( * ), ISPLIT( * ),
+ $ ISUPPZ( * ), IWORK( * )
+ DOUBLE PRECISION D( * ), GERS( * ), L( * ), SDIAM( * ),
+ $ W( * ), WERR( * ),
+ $ WGAP( * ), WORK( * )
+ DOUBLE PRECISION Z( LDZ, * )
+*
+* Purpose
+* =======
+*
+* DLARRV2 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 DLARRE2A
+* or by precious calls to DLARRV2.
+*
+* The major difference between the parallel and the sequential construction
+* of the representation tree is that in the parallel case, not all eigenvalues
+* of a given cluster might be computed locally. Other processors might "own"
+* and refine part of an eigenvalue cluster. This is crucial for scalability.
+* Thus there might be communication necessary before the current level of the
+* representation tree can be parsed.
+*
+* Please note:
+* 1. The calling sequence has two additional INTEGER parameters,
+* DOL and DOU, that should satisfy M>=DOU>=DOL>=1.
+* These parameters are only relevant for the case JOBZ = 'V'.
+* DLARRV2 ONLY computes the eigenVECTORS
+* corresponding to eigenvalues DOL through DOU in W. (That is,
+* instead of computing the eigenvectors belonging to W(1)
+* through W(M), only the eigenvectors belonging to eigenvalues
+* W(DOL) through W(DOU) are computed. In this case, only the
+* eigenvalues DOL:DOU are guaranteed to be accurately refined
+* to all figures by Rayleigh-Quotient iteration.
+*
+* 2. The additional arguments VSTART, FINISH, NDEPTH, PARITY, ZOFFSET
+* are included as a thread-safe implementation equivalent to SAVE variables.
+* These variables store details about the local representation tree which is
+* computed layerwise. For scalability reasons, eigenvalues belonging to the
+* locally relevant representation tree might be computed on other processors.
+* These need to be communicated before the inspection of the RRRs can proceed
+* on any given layer.
+* Note that only when the variable FINISH is true, the computation has ended
+* All eigenpairs between DOL and DOU have been computed. M is set = DOU - DOL + 1.
+*
+* 3. DLARRV2 needs more workspace in Z than the sequential DLARRV.
+* It is used to store the conformal embedding of the local representation tree.
+*
+* Arguments
+* =========
+*
+* N (input) INTEGER
+* The order of the matrix. N >= 0.
+*
+* VL (input) DOUBLE PRECISION
+* VU (input) DOUBLE PRECISION
+* Lower and upper bounds of the interval that contains the desired
+* eigenvalues. VL < VU. Needed to compute gaps on the left or right
+* end of the extremal eigenvalues in the desired RANGE.
+* VU is currently not used but kept as parameter in case needed.
+*
+* D (input/output) DOUBLE PRECISION array, dimension (N)
+* On entry, the N diagonal elements of the diagonal matrix D.
+* On exit, D is overwritten.
+*
+* L (input/output) DOUBLE PRECISION array, dimension (N)
+* On entry, the (N-1) subdiagonal elements of the unit
+* bidiagonal matrix L are in elements 1 to N-1 of L
+* (if the matrix is not splitted.) At the end of each block
+* is stored the corresponding shift as given by DLARRE.
+* On exit, L is overwritten.
+*
+* PIVMIN (in) DOUBLE PRECISION
+* The minimum pivot allowed in the sturm sequence.
+*
+* ISPLIT (input) INTEGER array, dimension (N)
+* The splitting points, at which T breaks up into blocks.
+* The first block consists of rows/columns 1 to
+* ISPLIT( 1 ), the second of rows/columns ISPLIT( 1 )+1
+* through ISPLIT( 2 ), etc.
+*
+* M (input) INTEGER
+* The total number of input eigenvalues. 0 <= M <= N.
+*
+* DOL (input) INTEGER
+* DOU (input) INTEGER
+* If the user wants to compute only selected eigenvectors from all
+* the eigenvalues supplied, he can specify an index range DOL:DOU.
+* Or else the setting DOL=1, DOU=M should be applied.
+* Note that DOL and DOU refer to the order in which the eigenvalues
+* are stored in W.
+* If the user wants to compute only selected eigenpairs, then
+* the columns DOL-1 to DOU+1 of the eigenvector space Z contain the
+* computed eigenvectors. All other columns of Z are set to zero.
+* If DOL > 1, then Z(:,DOL-1-ZOFFSET) is used.
+* If DOU < M, then Z(:,DOU+1-ZOFFSET) is used.
+*
+*
+* NEEDIL (input/output) INTEGER
+* NEEDIU (input/output) INTEGER
+* Describe which are the left and right outermost eigenvalues
+* that still need to be included in the computation. These indices
+* indicate whether eigenvalues from other processors are needed to
+* correctly compute the conformally embedded representation tree.
+* When DOL<=NEEDIL<=NEEDIU<=DOU, all required eigenvalues are local
+* to the processor and no communication is required to compute its
+* part of the representation tree.
+*
+* MINRGP (input) DOUBLE PRECISION
+* The minimum relativ gap threshold to decide whether an eigenvalue
+* or a cluster boundary is reached.
+*
+* RTOL1 (input) DOUBLE PRECISION
+* RTOL2 (input) DOUBLE PRECISION
+* Parameters for bisection.
+* An interval [LEFT,RIGHT] has converged if
+* RIGHT-LEFT.LT.MAX( RTOL1*GAP, RTOL2*MAX(|LEFT|,|RIGHT|) )
+*
+* W (input/output) DOUBLE PRECISION array, dimension (N)
+* The first M elements of W contain the APPROXIMATE eigenvalues for
+* which eigenvectors are to be computed. The eigenvalues
+* should be grouped by split-off block and ordered from
+* smallest to largest within the block. (The output array
+* W from DSTEGR2A is expected here.) Furthermore, they are with
+* respect to the shift of the corresponding root representation
+* for their block. On exit,
+* W holds those UNshifted eigenvalues
+* for which eigenvectors have already been computed.
+*
+* WERR (input/output) DOUBLE PRECISION array, dimension (N)
+* The first M elements contain the semiwidth of the uncertainty
+* interval of the corresponding eigenvalue in W
+*
+* WGAP (input/output) DOUBLE PRECISION array, dimension (N)
+* The separation from the right neighbor eigenvalue in W.
+*
+* IBLOCK (input) INTEGER array, dimension (N)
+* The indices of the blocks (submatrices) associated with the
+* corresponding eigenvalues in W; IBLOCK(i)=1 if eigenvalue
+* W(i) belongs to the first block from the top, =2 if W(i)
+* belongs to the second block, etc.
+*
+* INDEXW (input) INTEGER array, dimension (N)
+* The indices of the eigenvalues within each block (submatrix);
+* for example, INDEXW(i)= 10 and IBLOCK(i)=2 imply that the
+* i-th eigenvalue W(i) is the 10-th eigenvalue in the second block.
+*
+* GERS (input) DOUBLE PRECISION array, dimension (2*N)
+* The N Gerschgorin intervals (the i-th Gerschgorin interval
+* is (GERS(2*i-1), GERS(2*i)). The Gerschgorin intervals should
+* be computed from the original UNshifted matrix.
+* Currently NOT used but kept as parameter in case it becomes
+* needed in the future.
+*
+* SDIAM (input) DOUBLE PRECISION array, dimension (N)
+* The spectral diameters for all unreduced blocks.
+*
+* Z (output) DOUBLE PRECISION array, dimension (LDZ, max(1,M) )
+* If INFO = 0, the first M columns of Z contain the
+* orthonormal eigenvectors of the matrix T
+* corresponding to the input eigenvalues, with the i-th
+* column of Z holding the eigenvector associated with W(i).
+* In the distributed version, only a subset of columns
+* is accessed, see DOL,DOU and ZOFFSET.
+*
+* LDZ (input) INTEGER
+* The leading dimension of the array Z. LDZ >= 1, and if
+* JOBZ = 'V', LDZ >= max(1,N).
+*
+* ISUPPZ (output) INTEGER array, dimension ( 2*max(1,M) )
+* The support of the eigenvectors in Z, i.e., the indices
+* indicating the nonzero elements in Z. The I-th eigenvector
+* is nonzero only in elements ISUPPZ( 2*I-1 ) through
+* ISUPPZ( 2*I ).
+*
+* WORK (workspace) DOUBLE PRECISION array, dimension (12*N)
+*
+* IWORK (workspace) INTEGER array, dimension (7*N)
+*
+* VSTART (input/output) LOGICAL
+* .TRUE. on initialization, set to .FALSE. afterwards.
+*
+* FINISH (input/output) LOGICAL
+* A flag that indicates whether all eigenpairs have been computed.
+*
+* MAXCLS (input/output) INTEGER
+* The largest cluster worked on by this processor in the
+* representation tree.
+*
+* NDEPTH (input/output) INTEGER
+* The current depth of the representation tree. Set to
+* zero on initial pass, changed when the deeper levels of
+* the representation tree are generated.
+*
+* PARITY (input/output) INTEGER
+* An internal parameter needed for the storage of the
+* clusters on the current level of the representation tree.
+*
+* ZOFFSET (input) INTEGER
+* Offset for storing the eigenpairs when Z is distributed
+* in 1D-cyclic fashion.
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+*
+* > 0: A problem occured in DLARRV2.
+* < 0: One of the called subroutines signaled an internal problem.
+* Needs inspection of the corresponding parameter IINFO
+* for further information.
+*
+* =-1: Problem in DLARRB2 when refining a child's eigenvalues.
+* =-2: Problem in DLARRF2 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 DLARRB2 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.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ INTEGER MAXITR, USE30, USE31, USE32A, USE32B
+ PARAMETER ( MAXITR = 10, USE30=30, USE31=31,
+ $ USE32A=3210, USE32B = 3211 )
+ 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 Arrays ..
+ INTEGER SPLACE( 4 )
+* ..
+* .. Local Scalars ..
+ LOGICAL DELREF, ESKIP, NEEDBS, ONLYLC, STP2II, TRYMID,
+ $ TRYRQC, USEDBS, USEDRQ
+ INTEGER I, IBEGIN, IEND, II, IINCLS, IINDC1, IINDC2,
+ $ IINDWK, IINFO, IM, IN, INDEIG, INDLD, INDLLD,
+ $ INDWRK, ISUPMN, ISUPMX, ITER, ITMP1, ITWIST, J,
+ $ JBLK, K, KK, MINIWSIZE, MINWSIZE, MYWFST,
+ $ MYWLST, NCLUS, NEGCNT, NEWCLS, NEWFST, NEWFTT,
+ $ NEWLST, NEWSIZ, OFFSET, OLDCLS, OLDFST, OLDIEN,
+ $ OLDLST, OLDNCL, P, Q, VRTREE, WBEGIN, WEND,
+ $ WINDEX, WINDMN, WINDPL, ZFROM, ZINDEX, ZTO,
+ $ ZUSEDL, ZUSEDU, ZUSEDW
+ DOUBLE PRECISION AVGAP, BSTRES, BSTW, ENUFGP, EPS, FUDGE, GAP,
+ $ GAPTOL, LAMBDA, LEFT, LGAP, LGPVMN, LGSPDM,
+ $ LOG_IN, MGAP, MINGMA, MYERR, NRMINV, NXTERR,
+ $ ORTOL, RESID, RGAP, RIGHT, RLTL30, RQCORR,
+ $ RQTOL, SAVEGP, SGNDEF, SIGMA, SPDIAM, SSIGMA,
+ $ TAU, TMP, TOL, ZTZ
+* ..
+* .. External Functions ..
+ DOUBLE PRECISION DLAMCH
+ DOUBLE PRECISION DDOT, DNRM2
+ EXTERNAL DDOT, DLAMCH, DNRM2
+* ..
+* .. External Subroutines ..
+ EXTERNAL DAXPY, DCOPY, DLAR1VA, DLARRB2,
+ $ DLARRF2, DLASET, DSCAL
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, DBLE, MAX, MIN, SQRT
+* ..
+* .. 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
+
+* IWORK(IINCLS+JBLK) holds the number of clusters on the current level
+* of the reptree for block JBLK
+ IINCLS = 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
+
+ EPS = DLAMCH( 'Precision' )
+ RQTOL = TWO * EPS
+
+ TRYRQC = .TRUE.
+* Decide which representation tree criterion to use
+* USE30 = Lapack 3.0 criterion
+* USE31 = LAPACK 3.1 criterion
+* USE32A = two criteria, determines singletons with USE31, and groups with avgap.
+* USE32B = two criteria, determines singletons with USE31, and groups with USE30.
+ VRTREE = USE32A
+*
+ LGPVMN = LOG( PIVMIN )
+
+
+ IF(VSTART) THEN
+*
+* PREPROCESSING, DONE ONLY IN THE FIRST CALL
+*
+ VSTART = .FALSE.
+*
+ MAXCLS = 1
+
+* Set delayed eigenvalue refinement
+* In order to enable more parallelism, refinement
+* must be done immediately and cannot be delayed until
+* the next representation tree level.
+ DELREF = .FALSE.
+
+ DO 1 I= 1,MINWSIZE
+ WORK( I ) = ZERO
+ 1 CONTINUE
+
+ DO 2 I= 1,MINIWSIZE
+ IWORK( I ) = 0
+ 2 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-ZOFFSET)), LDZ )
+
+* Initialize NDEPTH, the current depth of the representation tree
+ NDEPTH = 0
+* Initialize parity
+ PARITY = 1
+
+* Go through blocks, initialize data structures
+ IBEGIN = 1
+ WBEGIN = 1
+ DO 10 JBLK = 1, IBLOCK( M )
+ IEND = ISPLIT( JBLK )
+ SIGMA = L( IEND )
+ WEND = WBEGIN - 1
+ 3 CONTINUE
+ IF( WEND.LT.M ) THEN
+ IF( IBLOCK( WEND+1 ).EQ.JBLK ) THEN
+ WEND = WEND + 1
+ GO TO 3
+ END IF
+ END IF
+ IF( WEND.LT.WBEGIN ) THEN
+ IWORK( IINCLS + JBLK ) = 0
+ IBEGIN = IEND + 1
+ GO TO 10
+ ELSEIF( (WEND.LT.DOL).OR.(WBEGIN.GT.DOU) ) THEN
+ IWORK( IINCLS + JBLK ) = 0
+ IBEGIN = IEND + 1
+ WBEGIN = WEND + 1
+ GO TO 10
+ END IF
+* The number of eigenvalues in the current block
+ IM = WEND - WBEGIN + 1
+* This is for a 1x1 block
+ IF( IBEGIN.EQ.IEND ) THEN
+ IWORK( IINCLS + JBLK ) = 0
+ Z( IBEGIN, (WBEGIN-ZOFFSET) ) = 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 10
+ END IF
+ CALL DCOPY( IM, W( WBEGIN ), 1,
+ & WORK( WBEGIN ), 1 )
+* We store in W the eigenvalue approximations w.r.t. the original
+* matrix T.
+ DO 5 I=1,IM
+ W(WBEGIN+I-1) = W(WBEGIN+I-1)+SIGMA
+ 5 CONTINUE
+
+* Initialize cluster counter for this block
+ IWORK( IINCLS + JBLK ) = 1
+ IWORK( IINDC1+IBEGIN ) = 1
+ IWORK( IINDC1+IBEGIN+1 ) = IM
+*
+ IBEGIN = IEND + 1
+ WBEGIN = WEND + 1
+10 CONTINUE
+*
+ ENDIF
+
+* Init NEEDIL and NEEDIU
+ NEEDIL = DOU
+ NEEDIU = DOL
+
+* Here starts the main loop
+* Only one pass through the loop is done until no collaboration
+* with other processors is needed.
+ 40 CONTINUE
+
+ PARITY = 1 - PARITY
+
+* For each block, build next level of representation tree
+* if there are still remaining clusters
+ 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.
+ IF(M.EQ.N) THEN
+* all eigenpairs are computed
+ WEND = IEND
+ ELSE
+* count how many wanted eigenpairs are in this block
+ 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
+ ENDIF
+
+ OLDNCL = IWORK( IINCLS + JBLK )
+ IF( OLDNCL.EQ.0 ) THEN
+ IBEGIN = IEND + 1
+ WBEGIN = WEND + 1
+ GO TO 170
+ END IF
+* 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
+
+* Find local spectral diameter of the block
+ SPDIAM = SDIAM(JBLK)
+ LGSPDM = LOG( SPDIAM + PIVMIN )
+* Compute ORTOL parameter, similar to DSTEIN
+ ORTOL = SPDIAM*1.0D-3
+* Compute average gap
+ AVGAP = SPDIAM/DBLE(IN-1)
+* Compute the minimum of average gap and ORTOL parameter
+* This can used as a lower bound for acceptable separation
+* between eigenvalues
+ ENUFGP = MIN(ORTOL,AVGAP)
+
+* Any 1x1 block has been treated before
+
+* loop while( OLDNCLS.GT.0 )
+* generate the next representation tree level for the current block
+ IF( OLDNCL.GT.0 ) 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
+* NCLUS is the number of clusters for the next level of the reptree
+* reset NCLUS to count the number of child clusters
+ NCLUS = 0
+*
+ LOG_IN = LOG(DBLE(IN))
+*
+ RLTL30 = MIN( 1.0D-2, ONE / DBLE( IN ) )
+*
+ IF( PARITY.EQ.0 ) THEN
+ OLDCLS = IINDC1+IBEGIN-1
+ NEWCLS = IINDC2+IBEGIN-1
+ ELSE
+ OLDCLS = IINDC2+IBEGIN-1
+ NEWCLS = IINDC1+IBEGIN-1
+ 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-ZOFFSET) ),
+ $ 1, D( IBEGIN ), 1 )
+ CALL DCOPY( IN-1, Z( IBEGIN, (J+1-ZOFFSET) ),
+ $ 1, L( IBEGIN ),1 )
+ SIGMA = Z( IEND, (J+1-ZOFFSET) )
+* Set the corresponding entries in Z to zero
+ CALL DLASET( 'Full', IN, 2, ZERO, ZERO,
+ $ Z( IBEGIN, (J-ZOFFSET) ), 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 .AND. DELREF ) 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., th P-OFFSET
+* thru' Q-OFFSET elements of these arrays are to be used.
+C OFFSET = P-OLDFST
+ OFFSET = INDEXW( WBEGIN ) - 1
+* perform limited bisection (if necessary) to get approximate
+* eigenvalues to the precision needed.
+ CALL DLARRB2( IN, D( IBEGIN ),
+ $ WORK(INDLLD+IBEGIN-1),
+ $ P, Q, RTOL1, RTOL2, OFFSET,
+ $ WORK(WBEGIN),WGAP(WBEGIN),WERR(WBEGIN),
+ $ WORK( INDWRK ), IWORK( IINDWK ),
+ $ PIVMIN, LGPVMN, LGSPDM, 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 DLARRB2.
+* 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
+ ELSEIF( (NDEPTH.EQ.0) .OR. (.NOT.DELREF) ) THEN
+* Some of the eigenvalues might have been computed on
+* other processors
+* Recompute gaps for this cluster
+* (all eigenvalues have the same
+* representation, i.e. the same shift, so this is easy)
+ DO 54 J = OLDFST, OLDLST-1
+ MYERR = WERR(WBEGIN + J - 1)
+ NXTERR = WERR(WBEGIN + J )
+ WGAP(WBEGIN+J-1) = MAX(WGAP(WBEGIN+J-1),
+ $ ( WORK(WBEGIN+J) - NXTERR )
+ $ - ( WORK(WBEGIN+J-1) + MYERR )
+ $ )
+ 54 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 (VRTREE.EQ.USE30) THEN
+ IF(WGAP( WBEGIN + J -1).GE.
+ $ RLTL30 * ABS(WORK(WBEGIN + J -1)) ) THEN
+* the right relgap is big enough by the Lapack 3.0 criterion
+ NEWLST = J
+ ELSE
+* inside a child cluster, the relative gap is not
+* big enough.
+ GOTO 140
+ ENDIF
+ ELSE IF (VRTREE.EQ.USE31) THEN
+ IF ( WGAP( WBEGIN + J -1).GE.
+ $ MINRGP* ABS( WORK(WBEGIN + J -1) ) ) THEN
+* the right relgap is big enough by the Lapack 3.1 criterion
+* (NEWFST,..,NEWLST) is well separated from the following
+ NEWLST = J
+ ELSE
+* inside a child cluster, the relative gap is not
+* big enough.
+ GOTO 140
+ ENDIF
+ ELSE IF (VRTREE.EQ.USE32A) THEN
+ IF( (J.EQ.OLDFST).AND.( WGAP(WBEGIN+J-1).GE.
+ $ MINRGP* ABS(WORK(WBEGIN+J-1)) ) ) THEN
+* the right relgap is big enough by the Lapack 3.1 criterion
+* Found a singleton
+ NEWLST = J
+ ELSE IF( (J.GT.OLDFST).AND.(J.EQ.NEWFST).AND.
+ $ ( WGAP(WBEGIN+J-2).GE.
+ $ MINRGP* ABS(WORK(WBEGIN+J-1)) ).AND.
+ $ ( WGAP(WBEGIN+J-1).GE.
+ $ MINRGP* ABS(WORK(WBEGIN+J-1)) )
+ $ ) THEN
+* Found a singleton
+ NEWLST = J
+ ELSE IF( (J.GT.NEWFST).AND.WGAP(WBEGIN+J-1).GE.
+ $ (MINRGP*ABS(WORK(WBEGIN+J-1)) ) )
+ $ THEN
+* the right relgap is big enough by the Lapack 3.1 criterion
+ NEWLST = J
+ ELSE IF((J.GT.NEWFST).AND.(J+1.LT.OLDLST).AND.
+ $ (WGAP(WBEGIN+J-1).GE.ENUFGP))
+ $ THEN
+* the right gap is bigger than ENUFGP
+* Care needs to be taken with this criterion to make
+* sure it does not create a remaining `false' singleton
+ NEWLST = J
+ ELSE
+* inside a child cluster, the relative gap is not
+* big enough.
+ GOTO 140
+ ENDIF
+ ELSE IF (VRTREE.EQ.USE32B) THEN
+ IF( (J.EQ.OLDFST).AND.( WGAP(WBEGIN+J-1).GE.
+ $ MINRGP* ABS(WORK(WBEGIN+J-1)) ) ) THEN
+* the right relgap is big enough by the Lapack 3.1 criterion
+* Found a singleton
+ NEWLST = J
+ ELSE IF( (J.GT.OLDFST).AND.(J.EQ.NEWFST).AND.
+ $ ( WGAP(WBEGIN+J-2).GE.
+ $ MINRGP* ABS(WORK(WBEGIN+J-1)) ).AND.
+ $ ( WGAP(WBEGIN+J-1).GE.
+ $ MINRGP* ABS(WORK(WBEGIN+J-1)) )
+ $ ) THEN
+* Found a singleton
+ NEWLST = J
+ ELSE IF( (J.GT.NEWFST).AND.WGAP(WBEGIN+J-1).GE.
+ $ (MINRGP*ABS(WORK(WBEGIN+J-1)) ) )
+ $ THEN
+* the right relgap is big enough by the Lapack 3.1 criterion
+ NEWLST = J
+ ELSE IF((J.GT.NEWFST).AND.(J+1.LT.OLDLST).AND.
+ $ (WGAP( WBEGIN + J -1).GE.
+ $ RLTL30 * ABS(WORK(WBEGIN + J -1)) ))
+ $ THEN
+* the right relgap is big enough by the Lapack 3.0 criterion
+* Care needs to be taken with this criterion to make
+* sure it does not create a remaining `false' singleton
+ NEWLST = J
+ ELSE
+* inside a child cluster, the relative gap is not
+* big enough.
+ GOTO 140
+ ENDIF
+ END IF
+ END IF
+
+* Compute size of child cluster found
+ NEWSIZ = NEWLST - NEWFST + 1
+ MAXCLS = MAX( NEWSIZ, MAXCLS )
+
+* 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
+* FOR 1D-DISTRIBUTED Z, COMPUTE NEWFTT SHIFTED BY ZOFFSET
+ NEWFTT = NEWFTT - ZOFFSET
+
+ IF( NEWSIZ.GT.1) THEN
+*
+* Current child is not a singleton but a cluster.
+*
+*
+ 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
+ GOTO 139
+ ENDIF
+
+* Compute left and right cluster gap.
+*
+ 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 )
+*
+* For larger clusters, record the largest gap observed
+* somewhere near the middle of the cluster as a possible
+* alternative position for a shift when TRYMID is TRUE
+*
+ MGAP = ZERO
+ IF(NEWSIZ.GE.50) THEN
+ KK = NEWFST
+ DO 545 K =NEWFST+NEWSIZ/3,NEWLST-NEWSIZ/3
+ IF(MGAP.LT.WGAP( WBEGIN+K-1 )) THEN
+ KK = K
+ MGAP = WGAP( WBEGIN+K-1 )
+ ENDIF
+ 545 CONTINUE
+ ENDIF
+
+*
+* Record the left- and right-most eigenvalues needed
+* for the next level of the representation tree
+ NEEDIL = MIN(NEEDIL,WBEGIN+NEWFST-1)
+ NEEDIU = MAX(NEEDIU,WBEGIN+NEWLST-1)
+
+*
+* Check if middle gap is large enough to shift there
+*
+ GAP = MIN(LGAP,RGAP)
+ TRYMID = (MGAP.GT.GAP)
+
+ SPLACE(1) = NEWFST
+ SPLACE(2) = NEWLST
+ IF(TRYMID) THEN
+ SPLACE(3) = KK
+ SPLACE(4) = KK+1
+ ELSE
+ SPLACE(3) = NEWFST
+ SPLACE(4) = NEWLST
+ ENDIF
+*
+* 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,4
+ P = INDEXW( WBEGIN-1+SPLACE(K) )
+ OFFSET = INDEXW( WBEGIN ) - 1
+ CALL DLARRB2( IN, D(IBEGIN),
+ $ WORK( INDLLD+IBEGIN-1 ),P,P,
+ $ RQTOL, RQTOL, OFFSET,
+ $ WORK(WBEGIN),WGAP(WBEGIN),
+ $ WERR(WBEGIN),WORK( INDWRK ),
+ $ IWORK( IINDWK ),
+ $ PIVMIN, LGPVMN, LGSPDM, IN, IINFO )
+ 55 CONTINUE
+*
+* Compute RRR of child cluster.
+* Note that the new RRR is stored in Z
+*
+C DLARRF2 needs LWORK = 2*N
+ CALL DLARRF2( IN, D( IBEGIN ), L( IBEGIN ),
+ $ WORK(INDLD+IBEGIN-1),
+ $ SPLACE(1), SPLACE(2),
+ $ SPLACE(3), SPLACE(4), WORK(WBEGIN),
+ $ WGAP(WBEGIN), WERR(WBEGIN), TRYMID,
+ $ 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 DLARRF2
+* 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
+ 116 CONTINUE
+
+ NCLUS = NCLUS + 1
+ K = NEWCLS + 2*NCLUS
+ IWORK( K-1 ) = NEWFST
+ IWORK( K ) = NEWLST
+*
+ IF(.NOT.DELREF) THEN
+ ONLYLC = .TRUE.
+*
+ IF(ONLYLC) THEN
+ MYWFST = MAX(WBEGIN-1+NEWFST,DOL-1)
+ MYWLST = MIN(WBEGIN-1+NEWLST,DOU+1)
+ ELSE
+ MYWFST = WBEGIN-1+NEWFST
+ MYWLST = WBEGIN-1+NEWLST
+ ENDIF
+
+* Compute LLD of new RRR
+ DO 5000 K = IBEGIN, IEND-1
+ WORK( INDWRK-1+K ) =
+ $ Z(K,NEWFTT)*
+ $ (Z(K,NEWFTT+1)**2)
+ 5000 CONTINUE
+* P and Q are index of the first and last
+* eigenvalue to compute within the new cluster
+ P = INDEXW( MYWFST )
+ Q = INDEXW( MYWLST )
+* Offset for the arrays WORK, WGAP and WERR
+ OFFSET = INDEXW( WBEGIN ) - 1
+* perform limited bisection (if necessary) to get approximate
+* eigenvalues to the precision needed.
+ CALL DLARRB2( IN,
+ $ Z(IBEGIN, NEWFTT ),
+ $ WORK(INDWRK+IBEGIN-1),
+ $ P, Q, RTOL1, RTOL2, OFFSET,
+ $ WORK(WBEGIN),WGAP(WBEGIN),WERR(WBEGIN),
+ $ WORK( INDWRK+N ), IWORK( IINDWK ),
+ $ PIVMIN, LGPVMN, LGSPDM, IN, IINFO )
+ IF( IINFO.NE.0 ) THEN
+ INFO = -1
+ RETURN
+ ENDIF
+* Each time the eigenvalues in WORK get refined, we store
+* the newly found approximation with all shifts applied in W
+ DO 5003 K=NEWFST,NEWLST
+ W(WBEGIN+K-1) = WORK(WBEGIN+K-1)+SSIGMA
+ 5003 CONTINUE
+ ENDIF
+*
+ ELSE
+ INFO = -2
+ RETURN
+ ENDIF
+ ELSE
+*
+* Compute eigenvector of singleton
+*
+ ITER = 0
+*
+ TOL = FOUR * LOG_IN * EPS
+*
+ K = NEWFST
+ WINDEX = WBEGIN + K - 1
+ ZINDEX = WINDEX - ZOFFSET
+ WINDMN = MAX(WINDEX - 1,1)
+ WINDPL = MIN(WINDEX + 1,M)
+ LAMBDA = WORK( WINDEX )
+* 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 )
+ IF( K .EQ. 1) THEN
+ LGAP = EPS*MAX(ABS(LEFT),ABS(RIGHT))
+ ELSE
+ LGAP = WGAP(WINDMN)
+ ENDIF
+ IF( K .EQ. IM) THEN
+ 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
+ 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.
+ SAVEGP = 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
+* Reset ITWIST
+ ITWIST = 0
+ 120 CONTINUE
+* Check if bisection should be used to refine eigenvalue
+ IF(NEEDBS) THEN
+* Take the bisection as new iterate
+ USEDBS = .TRUE.
+* Temporary copy of twist index needed
+ ITMP1 = ITWIST
+ OFFSET = INDEXW( WBEGIN ) - 1
+ CALL DLARRB2( IN, D(IBEGIN),
+ $ WORK(INDLLD+IBEGIN-1),INDEIG,INDEIG,
+ $ ZERO, TWO*EPS, OFFSET,
+ $ WORK(WBEGIN),WGAP(WBEGIN),
+ $ WERR(WBEGIN),WORK( INDWRK ),
+ $ IWORK( IINDWK ),
+ $ PIVMIN, LGPVMN, LGSPDM, 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
+ ITWIST = 0
+ ENDIF
+* Given LAMBDA, compute the eigenvector.
+ CALL DLAR1VA( IN, 1, IN, LAMBDA, D(IBEGIN),
+ $ L( IBEGIN ), WORK(INDLD+IBEGIN-1),
+ $ WORK(INDLLD+IBEGIN-1),
+ $ PIVMIN, GAPTOL, Z( IBEGIN, ZINDEX),
+ $ .NOT.USEDBS, NEGCNT, ZTZ, MINGMA,
+ $ ITWIST, 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
+*
+* 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
+ ELSE
+* The current LAMBDA is on the right of the true
+* eigenvalue
+ RIGHT = LAMBDA
+ 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
+ CALL DLAR1VA( IN, 1, IN, LAMBDA,
+ $ D( IBEGIN ), L( IBEGIN ),
+ $ WORK(INDLD+IBEGIN-1),
+ $ WORK(INDLLD+IBEGIN-1),
+ $ PIVMIN, GAPTOL,
+ $ Z( IBEGIN, ZINDEX ),
+ $ .NOT.USEDBS, NEGCNT, ZTZ, MINGMA,
+ $ ITWIST,
+ $ 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, ZINDEX ) = ZERO
+ 122 CONTINUE
+ ENDIF
+ IF(ISUPMX.GT.ZTO) THEN
+ DO 123 II = ZTO+1,ISUPMX
+ Z( II, ZINDEX ) = ZERO
+ 123 CONTINUE
+ ENDIF
+ CALL DSCAL( ZTO-ZFROM+1, NRMINV,
+ $ Z( ZFROM, ZINDEX ), 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( SAVEGP,
+ $ W( WINDPL )-WERR( WINDPL )
+ $ - W( WINDEX )-WERR( WINDEX) )
+ ENDIF
+ ENDIF
+ ENDIF
+* here ends the code for the current child
+*
+ 139 CONTINUE
+* Proceed to any remaining child nodes
+ NEWFST = J + 1
+ 140 CONTINUE
+ 150 CONTINUE
+* Store number of clusters
+ IWORK( IINCLS + JBLK ) = NCLUS
+*
+ END IF
+ IBEGIN = IEND + 1
+ WBEGIN = WEND + 1
+ 170 CONTINUE
+*
+* Check if everything is done: no clusters left for
+* this processor in any block
+*
+ FINISH = .TRUE.
+ DO 180 JBLK = 1, IBLOCK( M )
+ FINISH = FINISH .AND. (IWORK(IINCLS + JBLK).EQ.0)
+ 180 CONTINUE
+
+ IF(.NOT.FINISH) THEN
+ NDEPTH = NDEPTH + 1
+ IF((NEEDIL.GE.DOL).AND.(NEEDIU.LE.DOU)) THEN
+* Once this processor's part of the
+* representation tree consists exclusively of eigenvalues
+* between DOL and DOU, it can work independently from all
+* others.
+ GOTO 40
+ ENDIF
+ ENDIF
+*
+
+ RETURN
+*
+* End of DLARRV2
+*
+ END
diff --git a/SRC/dpttrsv.f b/SRC/dpttrsv.f
index 1ba7bec..618b7ca 100644
--- a/SRC/dpttrsv.f
+++ b/SRC/dpttrsv.f
@@ -1,6 +1,9 @@
SUBROUTINE DPTTRSV( TRANS, N, NRHS, D, E, B, LDB,
$ INFO )
*
+* -- ScaLAPACK auxiliary routine (version 2.0) --
+* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver
+*
* Written by Andrew J. Cleary, University of Tennessee.
* November, 1996.
* Modified from DPTTRS:
diff --git a/SRC/dstegr2.f b/SRC/dstegr2.f
new file mode 100644
index 0000000..ee4b7fc
--- /dev/null
+++ b/SRC/dstegr2.f
@@ -0,0 +1,522 @@
+ SUBROUTINE DSTEGR2( JOBZ, RANGE, N, D, E, VL, VU, IL, IU,
+ $ M, W, Z, LDZ, NZC, ISUPPZ, WORK, LWORK, IWORK,
+ $ LIWORK, DOL, DOU, ZOFFSET, INFO )
+*
+* -- ScaLAPACK auxiliary routine (version 2.0) --
+* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver
+* July 4, 2010
+*
+* .. Scalar Arguments ..
+ CHARACTER JOBZ, RANGE
+ INTEGER DOL, DOU, IL, INFO, IU,
+ $ LDZ, NZC, LIWORK, LWORK, M, N, ZOFFSET
+ DOUBLE PRECISION VL, VU
+
+* ..
+* .. Array Arguments ..
+ INTEGER ISUPPZ( * ), IWORK( * )
+ DOUBLE PRECISION D( * ), E( * ), W( * ), WORK( * )
+ DOUBLE PRECISION Z( LDZ, * )
+* ..
+*
+* Purpose
+* =======
+*
+* DSTEGR2 computes selected eigenvalues and, optionally, eigenvectors
+* of a real symmetric tridiagonal matrix T. It is invoked in the
+* ScaLAPACK MRRR driver PDSYEVR and the corresponding Hermitian
+* version either when only eigenvalues are to be computed, or when only
+* a single processor is used (the sequential-like case).
+*
+* DSTEGR2 has been adapted from LAPACK's DSTEGR. Please note the
+* following crucial changes.
+*
+* 1. The calling sequence has two additional INTEGER parameters,
+* DOL and DOU, that should satisfy M>=DOU>=DOL>=1.
+* DSTEGR2 ONLY computes the eigenpairs
+* corresponding to eigenvalues DOL through DOU in W. (That is,
+* instead of computing the eigenpairs belonging to W(1)
+* through W(M), only the eigenvectors belonging to eigenvalues
+* W(DOL) through W(DOU) are computed. In this case, only the
+* eigenvalues DOL:DOU are guaranteed to be fully accurate.
+*
+* 2. M is NOT the number of eigenvalues specified by RANGE, but is
+* M = DOU - DOL + 1. This concerns the case where only eigenvalues
+* are computed, but on more than one processor. Thus, in this case
+* M refers to the number of eigenvalues computed on this processor.
+*
+* 3. The arrays W and Z might not contain all the wanted eigenpairs
+* locally, instead this information is distributed over other
+* processors.
+*
+* Arguments
+* =========
+*
+* JOBZ (input) CHARACTER*1
+* = 'N': Compute eigenvalues only;
+* = 'V': Compute eigenvalues and eigenvectors.
+*
+* RANGE (input) CHARACTER*1
+* = 'A': all eigenvalues will be found.
+* = 'V': all eigenvalues in the half-open interval (VL,VU]
+* will be found.
+* = 'I': the IL-th through IU-th eigenvalues will be found.
+*
+* N (input) INTEGER
+* The order of the matrix. N >= 0.
+*
+* D (input/output) DOUBLE PRECISION array, dimension (N)
+* On entry, the N diagonal elements of the tridiagonal matrix
+* T. On exit, D is overwritten.
+*
+* E (input/output) DOUBLE PRECISION array, dimension (N)
+* On entry, the (N-1) subdiagonal elements of the tridiagonal
+* matrix T in elements 1 to N-1 of E. E(N) need not be set on
+* input, but is used internally as workspace.
+* On exit, E is overwritten.
+*
+* VL (input) DOUBLE PRECISION
+* VU (input) DOUBLE PRECISION
+* If RANGE='V', the lower and upper bounds of the interval to
+* be searched for eigenvalues. VL < VU.
+* Not referenced if RANGE = 'A' or 'I'.
+*
+* IL (input) INTEGER
+* IU (input) INTEGER
+* If RANGE='I', the indices (in ascending order) of the
+* smallest and largest eigenvalues to be returned.
+* 1 <= IL <= IU <= N, if N > 0.
+* Not referenced if RANGE = 'A' or 'V'.
+*
+* M (output) INTEGER
+* Globally summed over all processors, M equals
+* the total number of eigenvalues found. 0 <= M <= N.
+* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.
+* The local output equals M = DOU - DOL + 1.
+*
+* W (output) DOUBLE PRECISION array, dimension (N)
+* The first M elements contain the selected eigenvalues in
+* ascending order. Note that immediately after exiting this
+* routine, only the eigenvalues from
+* position DOL:DOU are to reliable on this processor
+* because the eigenvalue computation is done in parallel.
+* Other processors will hold reliable information on other
+* parts of the W array. This information is communicated in
+* the ScaLAPACK driver.
+*
+* Z (output) DOUBLE PRECISION array, dimension (LDZ, max(1,M) )
+* If JOBZ = 'V', and if INFO = 0, then the first M columns of Z
+* contain some of the orthonormal eigenvectors of the matrix T
+* corresponding to the selected eigenvalues, with the i-th
+* column of Z holding the eigenvector associated with W(i).
+* If JOBZ = 'N', then Z is not referenced.
+* Note: the user must ensure that at least max(1,M) columns are
+* supplied in the array Z; if RANGE = 'V', the exact value of M
+* is not known in advance and can be computed with a workspace
+* query by setting NZC = -1, see below.
+*
+* LDZ (input) INTEGER
+* The leading dimension of the array Z. LDZ >= 1, and if
+* JOBZ = 'V', then LDZ >= max(1,N).
+*
+* NZC (input) INTEGER
+* The number of eigenvectors to be held in the array Z.
+* If RANGE = 'A', then NZC >= max(1,N).
+* If RANGE = 'V', then NZC >= the number of eigenvalues in (VL,VU].
+* If RANGE = 'I', then NZC >= IU-IL+1.
+* If NZC = -1, then a workspace query is assumed; the
+* routine calculates the number of columns of the array Z that
+* are needed to hold the eigenvectors.
+* This value is returned as the first entry of the Z array, and
+* no error message related to NZC is issued.
+*
+* ISUPPZ (output) INTEGER ARRAY, dimension ( 2*max(1,M) )
+* The support of the eigenvectors in Z, i.e., the indices
+* indicating the nonzero elements in Z. The i-th computed eigenvector
+* is nonzero only in elements ISUPPZ( 2*i-1 ) through
+* ISUPPZ( 2*i ). This is relevant in the case when the matrix
+* is split. ISUPPZ is only set if N>2.
+*
+* WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK)
+* On exit, if INFO = 0, WORK(1) returns the optimal
+* (and minimal) LWORK.
+*
+* LWORK (input) INTEGER
+* The dimension of the array WORK. LWORK >= max(1,18*N)
+* if JOBZ = 'V', and LWORK >= max(1,12*N) if JOBZ = 'N'.
+* If LWORK = -1, then a workspace query is assumed; the routine
+* only calculates the optimal size of the WORK array, returns
+* this value as the first entry of the WORK array, and no error
+* message related to LWORK is issued.
+*
+* IWORK (workspace/output) INTEGER array, dimension (LIWORK)
+* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.
+*
+* LIWORK (input) INTEGER
+* The dimension of the array IWORK. LIWORK >= max(1,10*N)
+* if the eigenvectors are desired, and LIWORK >= max(1,8*N)
+* if only the eigenvalues are to be computed.
+* If LIWORK = -1, then a workspace query is assumed; the
+* routine only calculates the optimal size of the IWORK array,
+* returns this value as the first entry of the IWORK array, and
+* no error message related to LIWORK is issued.
+*
+* DOL (input) INTEGER
+* DOU (input) INTEGER
+* From the eigenvalues W(1:M), only eigenvectors
+* Z(:,DOL) to Z(:,DOU) are computed.
+* If DOL > 1, then Z(:,DOL-1-ZOFFSET) is used and overwritten.
+* If DOU < M, then Z(:,DOU+1-ZOFFSET) is used and overwritten.
+*
+* ZOFFSET (input) INTEGER
+* Offset for storing the eigenpairs when Z is distributed
+* in 1D-cyclic fashion
+*
+* INFO (output) INTEGER
+* On exit, INFO
+* = 0: successful exit
+* other:if INFO = -i, the i-th argument had an illegal value
+* if INFO = 10X, internal error in DLARRE2,
+* if INFO = 20X, internal error in DLARRV.
+* Here, the digit X = ABS( IINFO ) < 10, where IINFO is
+* the nonzero error code returned by DLARRE2 or
+* DLARRV, respectively.
+*
+* =====================================================================
+*
+* .. 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, IIL, IINDBL, IINDW, IINDWK, IINFO, IINSPL,
+ $ IIU, INDE2, INDERR, INDGP, INDGRS, INDWRK,
+ $ ITMP, ITMP2, J, JJ, LIWMIN, LWMIN, NSPLIT,
+ $ NZCMIN
+ DOUBLE PRECISION BIGNUM, EPS, PIVMIN, RMAX, RMIN, RTOL1, RTOL2,
+ $ SAFMIN, SCALE, SMLNUM, THRESH, TMP, TNRM, WL,
+ $ WU
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ DOUBLE PRECISION DLAMCH, DLANST
+ EXTERNAL LSAME, DLAMCH, DLANST
+* ..
+* .. External Subroutines ..
+ EXTERNAL DCOPY, DLAE2, DLAEV2, DLARRC, DLARRE2,
+ $ DLARRV, DLASRT, DSCAL, DSWAP
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC DBLE, 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 )
+
+* DSTEGR2 needs WORK of size 6*N, IWORK of size 3*N.
+* In addition, DLARRE2 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
+
+ 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 DLARRE2.
+ 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
+ IIL = 1
+ IIU = N
+ ELSE IF( WANTZ .AND. VALEIG ) THEN
+ CALL DLARRC( 'T', N, VL, VU, D, E, SAFMIN,
+ $ NZCMIN, ITMP, ITMP2, INFO )
+ IIL = ITMP+1
+ IIU = ITMP2
+ 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 ( WANTZ ) THEN
+ IF ( DOL.LT.1 .OR. DOL.GT.NZCMIN ) THEN
+ INFO = -20
+ ENDIF
+ IF ( DOU.LT.1 .OR. DOU.GT.NZCMIN .OR. DOU.LT.DOL) THEN
+ INFO = -21
+ ENDIF
+ ENDIF
+
+ IF( INFO.NE.0 ) THEN
+*
+C Disable sequential error handler
+C for parallel case
+C CALL XERBLA( 'DSTEGR2', -INFO )
+*
+ RETURN
+ ELSE IF( LQUERY .OR. ZQUERY ) 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( WL.LT.D( 1 ) .AND. WU.GE.D( 1 ) ) THEN
+ M = 1
+ W( 1 ) = D( 1 )
+ END IF
+ END IF
+ IF( WANTZ )
+ $ Z( 1, 1 ) = ONE
+ RETURN
+ END IF
+*
+ INDGRS = 1
+ INDERR = 2*N + 1
+ INDGP = 3*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.
+*
+ 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 DLARRE2
+* 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.
+*
+ IINFO = -1
+* Set the splitting criterion
+ IF (IINFO.EQ.0) THEN
+ THRESH = EPS
+ ELSE
+ THRESH = -EPS
+ 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
+* DLARRE2 computes the eigenvalues to full precision.
+ RTOL1 = FOUR * EPS
+ RTOL2 = FOUR * EPS
+ ELSE
+* DLARRE2 computes the eigenvalues to less than full precision.
+* DLARRV will refine the eigenvalue approximations, and we can
+* need less accurate initial bisection in DLARRE2.
+* Note: these settings do only affect the subset case and DLARRE2
+ RTOL1 = SQRT(EPS)
+ RTOL2 = MAX( SQRT(EPS)*5.0D-3, FOUR * EPS )
+ ENDIF
+ CALL DLARRE2( RANGE, N, WL, WU, IIL, IIU, D, E,
+ $ WORK(INDE2), RTOL1, RTOL2, THRESH, NSPLIT,
+ $ IWORK( IINSPL ), M, DOL, DOU,
+ $ W, WORK( INDERR ),
+ $ WORK( INDGP ), IWORK( IINDBL ),
+ $ IWORK( IINDW ), WORK( INDGRS ), PIVMIN,
+ $ WORK( INDWRK ), IWORK( IINDWK ), IINFO )
+ IF( IINFO.NE.0 ) THEN
+ INFO = 100 + ABS( IINFO )
+ RETURN
+ END IF
+* Note that if RANGE .NE. 'V', DLARRE2 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,
+ $ DOL, DOU, 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 = 200 + ABS( IINFO )
+ RETURN
+ END IF
+ ELSE
+* DLARRE2 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 DLARRE2 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 matrix was scaled, then rescale eigenvalues appropriately.
+*
+ IF( SCALE.NE.ONE ) THEN
+ CALL DSCAL( M, ONE / SCALE, W, 1 )
+ END IF
+*
+* Correct M if needed
+*
+ IF ( WANTZ ) THEN
+ IF( DOL.NE.1 .OR. DOU.NE.M ) THEN
+ M = DOU - DOL +1
+ ENDIF
+ ENDIF
+*
+* If eigenvalues are not in increasing order, then sort them,
+* possibly along with eigenvectors.
+*
+ IF( NSPLIT.GT.1 ) THEN
+ IF( .NOT. WANTZ ) THEN
+ CALL DLASRT( 'I', DOU - DOL +1, W(DOL), IINFO )
+ IF( IINFO.NE.0 ) THEN
+ INFO = 3
+ RETURN
+ END IF
+ ELSE
+ DO 60 J = DOL, DOU - 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-ZOFFSET ),
+ $ 1, Z( 1, J-ZOFFSET ), 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 DSTEGR2
+*
+ END
diff --git a/SRC/dstegr2a.f b/SRC/dstegr2a.f
new file mode 100644
index 0000000..52d5515
--- /dev/null
+++ b/SRC/dstegr2a.f
@@ -0,0 +1,465 @@
+ SUBROUTINE DSTEGR2A( JOBZ, RANGE, N, D, E, VL, VU, IL, IU,
+ $ M, W, Z, LDZ, NZC, WORK, LWORK, IWORK,
+ $ LIWORK, DOL, DOU, NEEDIL, NEEDIU,
+ $ INDERR, NSPLIT, PIVMIN, SCALE, WL, WU,
+ $ INFO )
+*
+* -- ScaLAPACK auxiliary routine (version 2.0) --
+* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver
+* July 4, 2010
+*
+ IMPLICIT NONE
+*
+* .. Scalar Arguments ..
+ CHARACTER JOBZ, RANGE
+ INTEGER DOL, DOU, IL, INDERR, INFO, IU, LDZ, LIWORK,
+ $ LWORK, M, N, NEEDIL, NEEDIU, NSPLIT, NZC
+ DOUBLE PRECISION PIVMIN, SCALE, VL, VU, WL, WU
+
+* ..
+* .. Array Arguments ..
+ INTEGER IWORK( * )
+ DOUBLE PRECISION D( * ), E( * ), W( * ), WORK( * )
+ DOUBLE PRECISION Z( LDZ, * )
+* ..
+*
+* Purpose
+* =======
+*
+* DSTEGR2A computes selected eigenvalues and initial representations.
+* needed for eigenvector computations in DSTEGR2B. It is invoked in the
+* ScaLAPACK MRRR driver PDSYEVR and the corresponding Hermitian
+* version when both eigenvalues and eigenvectors are computed in parallel.
+* on multiple processors. For this case, DSTEGR2A implements the FIRST
+* part of the MRRR algorithm, parallel eigenvalue computation and finding
+* the root RRR. At the end of DSTEGR2A,
+* other processors might have a part of the spectrum that is needed to
+* continue the computation locally. Once this eigenvalue information has
+* been received by the processor, the computation can then proceed by calling
+* the SECOND part of the parallel MRRR algorithm, DSTEGR2B.
+*
+* Please note:
+* 1. The calling sequence has two additional INTEGER parameters,
+* (compared to LAPACK's DSTEGR), these are
+* DOL and DOU and should satisfy M>=DOU>=DOL>=1.
+* These parameters are only relevant for the case JOBZ = 'V'.
+*
+* Globally invoked over all processors, DSTEGR2A computes
+* ALL the eigenVALUES specified by RANGE.
+* RANGE= 'A': all eigenvalues will be found.
+* = 'V': all eigenvalues in (VL,VU] will be found.
+* = 'I': the IL-th through IU-th eigenvalues will be found.
+*
+* DSTEGR2A LOCALLY only computes the eigenvalues
+* corresponding to eigenvalues DOL through DOU in W. (That is,
+* instead of computing the eigenvectors belonging to W(1)
+* through W(M), only the eigenvectors belonging to eigenvalues
+* W(DOL) through W(DOU) are computed. In this case, only the
+* eigenvalues DOL:DOU are guaranteed to be fully accurate.
+*
+* 2. M is NOT the number of eigenvalues specified by RANGE, but it is
+* M = DOU - DOL + 1. Instead, M refers to the number of eigenvalues computed on
+* this processor.
+*
+* 3. While no eigenvectors are computed in DSTEGR2A itself (this is
+* done later in DSTEGR2B), the interface
+* If JOBZ = 'V' then, depending on RANGE and DOL, DOU, DSTEGR2A
+* might need more workspace in Z then the original DSTEGR.
+* In particular, the arrays W and Z might not contain all the wanted eigenpairs
+* locally, instead this information is distributed over other
+* processors.
+*
+* Arguments
+* =========
+*
+* JOBZ (input) CHARACTER*1
+* = 'N': Compute eigenvalues only;
+* = 'V': Compute eigenvalues and eigenvectors.
+*
+* RANGE (input) CHARACTER*1
+* = 'A': all eigenvalues will be found.
+* = 'V': all eigenvalues in the half-open interval (VL,VU]
+* will be found.
+* = 'I': the IL-th through IU-th eigenvalues will be found.
+*
+* N (input) INTEGER
+* The order of the matrix. N >= 0.
+*
+* D (input/output) DOUBLE PRECISION array, dimension (N)
+* On entry, the N diagonal elements of the tridiagonal matrix
+* T. On exit, D is overwritten.
+*
+* E (input/output) DOUBLE PRECISION array, dimension (N)
+* On entry, the (N-1) subdiagonal elements of the tridiagonal
+* matrix T in elements 1 to N-1 of E. E(N) need not be set on
+* input, but is used internally as workspace.
+* On exit, E is overwritten.
+*
+* VL (input) DOUBLE PRECISION
+* VU (input) DOUBLE PRECISION
+* If RANGE='V', the lower and upper bounds of the interval to
+* be searched for eigenvalues. VL < VU.
+* Not referenced if RANGE = 'A' or 'I'.
+*
+* IL (input) INTEGER
+* IU (input) INTEGER
+* If RANGE='I', the indices (in ascending order) of the
+* smallest and largest eigenvalues to be returned.
+* 1 <= IL <= IU <= N, if N > 0.
+* Not referenced if RANGE = 'A' or 'V'.
+*
+* M (output) INTEGER
+* Globally summed over all processors, M equals
+* the total number of eigenvalues found. 0 <= M <= N.
+* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.
+* The local output equals M = DOU - DOL + 1.
+*
+* W (output) DOUBLE PRECISION array, dimension (N)
+* The first M elements contain approximations to the selected
+* eigenvalues in ascending order. Note that immediately after
+* exiting this routine, only the eigenvalues from
+* position DOL:DOU are to reliable on this processor
+* because the eigenvalue computation is done in parallel.
+* The other entries outside DOL:DOU are very crude preliminary
+* approximations. Other processors hold reliable information on
+* these other parts of the W array.
+* This information is communicated in the ScaLAPACK driver.
+*
+* Z (output) DOUBLE PRECISION array, dimension (LDZ, max(1,M) )
+* DSTEGR2A does not compute eigenvectors, this is done
+* in DSTEGR2B. The argument Z as well as all related
+* other arguments only appear to keep the interface consistent
+* and to signal to the user that this subroutine is meant to
+* be used when eigenvectors are computed.
+*
+* LDZ (input) INTEGER
+* The leading dimension of the array Z. LDZ >= 1, and if
+* JOBZ = 'V', then LDZ >= max(1,N).
+*
+* NZC (input) INTEGER
+* The number of eigenvectors to be held in the array Z.
+* If RANGE = 'A', then NZC >= max(1,N).
+* If RANGE = 'V', then NZC >= the number of eigenvalues in (VL,VU].
+* If RANGE = 'I', then NZC >= IU-IL+1.
+* If NZC = -1, then a workspace query is assumed; the
+* routine calculates the number of columns of the array Z that
+* are needed to hold the eigenvectors.
+* This value is returned as the first entry of the Z array, and
+* no error message related to NZC is issued.
+*
+* WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK)
+* On exit, if INFO = 0, WORK(1) returns the optimal
+* (and minimal) LWORK.
+*
+* LWORK (input) INTEGER
+* The dimension of the array WORK. LWORK >= max(1,18*N)
+* if JOBZ = 'V', and LWORK >= max(1,12*N) if JOBZ = 'N'.
+* If LWORK = -1, then a workspace query is assumed; the routine
+* only calculates the optimal size of the WORK array, returns
+* this value as the first entry of the WORK array, and no error
+* message related to LWORK is issued.
+*
+* IWORK (workspace/output) INTEGER array, dimension (LIWORK)
+* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.
+*
+* LIWORK (input) INTEGER
+* The dimension of the array IWORK. LIWORK >= max(1,10*N)
+* if the eigenvectors are desired, and LIWORK >= max(1,8*N)
+* if only the eigenvalues are to be computed.
+* If LIWORK = -1, then a workspace query is assumed; the
+* routine only calculates the optimal size of the IWORK array,
+* returns this value as the first entry of the IWORK array, and
+* no error message related to LIWORK is issued.
+*
+* DOL (input) INTEGER
+* DOU (input) INTEGER
+* From all the eigenvalues W(1:M), only eigenvalues
+* W(DOL:DOU) are computed.
+*
+* NEEDIL (output) INTEGER
+* NEEDIU (output) INTEGER
+* The indices of the leftmost and rightmost eigenvalues
+* needed to accurately compute the relevant part of the
+* representation tree. This information can be used to
+* find out which processors have the relevant eigenvalue
+* information needed so that it can be communicated.
+*
+* INDERR (output) INTEGER
+* INDERR points to the place in the work space where
+* the eigenvalue uncertainties (errors) are stored.
+*
+* NSPLIT (output) INTEGER
+* The number of blocks T splits into. 1 <= NSPLIT <= N.
+*
+* PIVMIN (output) DOUBLE PRECISION
+* The minimum pivot in the sturm sequence for T.
+*
+* SCALE (output) DOUBLE PRECISION
+* The scaling factor for the tridiagonal T.
+*
+* WL (output) DOUBLE PRECISION
+* WU (output) DOUBLE PRECISION
+* The interval (WL, WU] contains all the wanted eigenvalues.
+* It is either given by the user or computed in DLARRE2A.
+*
+* INFO (output) INTEGER
+* On exit, INFO
+* = 0: successful exit
+* other:if INFO = -i, the i-th argument had an illegal value
+* if INFO = 10X, internal error in DLARRE2A,
+* Here, the digit X = ABS( IINFO ) < 10, where IINFO is
+* the nonzero error code returned by DLARRE2A.
+*
+* =====================================================================
+*
+* .. 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 IIL, IINDBL, IINDW, IINDWK, IINFO, IINSPL, IIU,
+ $ INDE2, INDGP, INDGRS, INDSDM, INDWRK, ITMP,
+ $ ITMP2, J, LIWMIN, LWMIN, NZCMIN
+ DOUBLE PRECISION BIGNUM, EPS, RMAX, RMIN, RTOL1, RTOL2, SAFMIN,
+ $ SMLNUM, THRESH, TNRM
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ DOUBLE PRECISION DLAMCH, DLANST
+ EXTERNAL LSAME, DLAMCH, DLANST
+* ..
+* .. External Subroutines ..
+ EXTERNAL DLARRC, DLARRE2A, DSCAL
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC DBLE, 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 )
+
+* DSTEGR2A needs WORK of size 6*N, IWORK of size 3*N.
+* In addition, DLARRE2A needs WORK of size 6*N, IWORK of size 5*N.
+* Furthermore, DLARRV2 needs WORK of size 12*N, IWORK of size 7*N.
+* Workspace is kept consistent with DSTEGR2B even though
+* DLARRV2 is not called here.
+ 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
+
+ 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 DLARRE2A.
+ 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
+ IIL = 1
+ IIU = N
+ ELSE IF( WANTZ .AND. VALEIG ) THEN
+ CALL DLARRC( 'T', N, VL, VU, D, E, SAFMIN,
+ $ NZCMIN, ITMP, ITMP2, INFO )
+ IIL = ITMP+1
+ IIU = ITMP2
+ 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 ( WANTZ ) THEN
+ IF ( DOL.LT.1 .OR. DOL.GT.NZCMIN ) THEN
+ INFO = -20
+ ENDIF
+ IF ( DOU.LT.1 .OR. DOU.GT.NZCMIN .OR. DOU.LT.DOL) THEN
+ INFO = -21
+ ENDIF
+ ENDIF
+
+ IF( INFO.NE.0 ) THEN
+*
+C Disable sequential error handler
+C for parallel case
+C CALL XERBLA( 'DSTEGR2A', -INFO )
+*
+ RETURN
+ ELSE IF( LQUERY .OR. ZQUERY ) THEN
+ RETURN
+ END IF
+
+* Initialize NEEDIL and NEEDIU, these values are changed in DLARRE2A
+ NEEDIL = DOU
+ NEEDIU = DOL
+*
+* 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( WL.LT.D( 1 ) .AND. WU.GE.D( 1 ) ) THEN
+ M = 1
+ W( 1 ) = D( 1 )
+ END IF
+ END IF
+ IF( WANTZ )
+ $ Z( 1, 1 ) = ONE
+ RETURN
+ END IF
+*
+ INDGRS = 1
+ INDERR = 2*N + 1
+ INDGP = 3*N + 1
+ INDSDM = 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.
+*
+ 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 DLARRA in DLARRE2A
+* A negative THRESH forces the old splitting criterion based on the
+* size of the off-diagonal.
+ THRESH = -EPS
+ IINFO = 0
+
+* 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
+* DLARRE2A computes the eigenvalues to full precision.
+ RTOL1 = FOUR * EPS
+ RTOL2 = FOUR * EPS
+ ELSE
+* DLARRE2A computes the eigenvalues to less than full precision.
+* DLARRV2 will refine the eigenvalue approximations, and we can
+* need less accurate initial bisection in DLARRE2A.
+ RTOL1 = FOUR*SQRT(EPS)
+ RTOL2 = MAX( SQRT(EPS)*5.0D-3, FOUR * EPS )
+ ENDIF
+ CALL DLARRE2A( RANGE, N, WL, WU, IIL, IIU, D, E,
+ $ WORK(INDE2), RTOL1, RTOL2, THRESH, NSPLIT,
+ $ IWORK( IINSPL ), M, DOL, DOU, NEEDIL, NEEDIU,
+ $ W, WORK( INDERR ),
+ $ WORK( INDGP ), IWORK( IINDBL ),
+ $ IWORK( IINDW ), WORK( INDGRS ),
+ $ WORK( INDSDM ), PIVMIN,
+ $ WORK( INDWRK ), IWORK( IINDWK ),
+ $ MINRGP, IINFO )
+ IF( IINFO.NE.0 ) THEN
+ INFO = 100 + ABS( IINFO )
+ RETURN
+ END IF
+* Note that if RANGE .NE. 'V', DLARRE2A computes bounds on the desired
+* part of the spectrum. All desired eigenvalues are contained in
+* (WL,WU]
+
+
+ RETURN
+*
+* End of DSTEGR2A
+*
+ END
diff --git a/SRC/dstegr2b.f b/SRC/dstegr2b.f
new file mode 100644
index 0000000..1095dee
--- /dev/null
+++ b/SRC/dstegr2b.f
@@ -0,0 +1,345 @@
+ SUBROUTINE DSTEGR2B( JOBZ, N, D, E,
+ $ M, W, Z, LDZ, NZC, ISUPPZ, WORK, LWORK, IWORK,
+ $ LIWORK, DOL, DOU, NEEDIL, NEEDIU,
+ $ INDWLC, PIVMIN, SCALE, WL, WU,
+ $ VSTART, FINISH, MAXCLS,
+ $ NDEPTH, PARITY, ZOFFSET, INFO )
+*
+* -- ScaLAPACK auxiliary routine (version 2.0) --
+* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver
+* July 4, 2010
+*
+ IMPLICIT NONE
+*
+* .. Scalar Arguments ..
+ CHARACTER JOBZ
+ INTEGER DOL, DOU, INDWLC, INFO, LDZ, LIWORK, LWORK, M,
+ $ MAXCLS, N, NDEPTH, NEEDIL, NEEDIU, NZC, PARITY,
+ $ ZOFFSET
+
+ DOUBLE PRECISION PIVMIN, SCALE, WL, WU
+ LOGICAL VSTART, FINISH
+
+* ..
+* .. Array Arguments ..
+ INTEGER ISUPPZ( * ), IWORK( * )
+ DOUBLE PRECISION D( * ), E( * ), W( * ), WORK( * )
+ DOUBLE PRECISION Z( LDZ, * )
+* ..
+*
+* Purpose
+* =======
+*
+* DSTEGR2B should only be called after a call to DSTEGR2A.
+* From eigenvalues and initial representations computed by DSTEGR2A,
+* DSTEGR2B computes the selected eigenvalues and eigenvectors
+* of the real symmetric tridiagonal matrix in parallel
+* on multiple processors. It is potentially invoked multiple times
+* on a given processor because the locally relevant representation tree
+* might depend on spectral information that is "owned" by other processors
+* and might need to be communicated.
+*
+* Please note:
+* 1. The calling sequence has two additional INTEGER parameters,
+* DOL and DOU, that should satisfy M>=DOU>=DOL>=1.
+* These parameters are only relevant for the case JOBZ = 'V'.
+* DSTEGR2B ONLY computes the eigenVECTORS
+* corresponding to eigenvalues DOL through DOU in W. (That is,
+* instead of computing the eigenvectors belonging to W(1)
+* through W(M), only the eigenvectors belonging to eigenvalues
+* W(DOL) through W(DOU) are computed. In this case, only the
+* eigenvalues DOL:DOU are guaranteed to be accurately refined
+* to all figures by Rayleigh-Quotient iteration.
+*
+* 2. The additional arguments VSTART, FINISH, NDEPTH, PARITY, ZOFFSET
+* are included as a thread-safe implementation equivalent to SAVE variables.
+* These variables store details about the local representation tree which is
+* computed layerwise. For scalability reasons, eigenvalues belonging to the
+* locally relevant representation tree might be computed on other processors.
+* These need to be communicated before the inspection of the RRRs can proceed
+* on any given layer.
+* Note that only when the variable FINISH is true, the computation has ended
+* All eigenpairs between DOL and DOU have been computed. M is set = DOU - DOL + 1.
+*
+* 3. DSTEGR2B needs more workspace in Z than the sequential DSTEGR.
+* It is used to store the conformal embedding of the local representation tree.
+*
+* Arguments
+* =========
+*
+* JOBZ (input) CHARACTER*1
+* = 'N': Compute eigenvalues only;
+* = 'V': Compute eigenvalues and eigenvectors.
+*
+* N (input) INTEGER
+* The order of the matrix. N >= 0.
+*
+* D (input/output) DOUBLE PRECISION array, dimension (N)
+* On entry, the N diagonal elements of the tridiagonal matrix
+* T. On exit, D is overwritten.
+*
+* E (input/output) DOUBLE PRECISION array, dimension (N)
+* On entry, the (N-1) subdiagonal elements of the tridiagonal
+* matrix T in elements 1 to N-1 of E. E(N) need not be set on
+* input, but is used internally as workspace.
+* On exit, E is overwritten.
+*
+* M (input) INTEGER
+* The total number of eigenvalues found
+* in DSTEGR2A. 0 <= M <= N.
+*
+* W (input) DOUBLE PRECISION array, dimension (N)
+* The first M elements contain approximations to the selected
+* eigenvalues in ascending order. Note that only the eigenvalues from
+* the locally relevant part of the representation tree, that is
+* all the clusters that include eigenvalues from DOL:DOU, are reliable
+* on this processor. (It does not need to know about any others anyway.)
+*
+* Z (output) DOUBLE PRECISION array, dimension (LDZ, max(1,M) )
+* If JOBZ = 'V', and if INFO = 0, then
+* a subset of 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).
+* See DOL, DOU for more information.
+*
+* LDZ (input) INTEGER
+* The leading dimension of the array Z. LDZ >= 1, and if
+* JOBZ = 'V', then LDZ >= max(1,N).
+*
+* NZC (input) INTEGER
+* The number of eigenvectors to be held in the array Z.
+*
+* ISUPPZ (output) INTEGER ARRAY, dimension ( 2*max(1,M) )
+* The support of the eigenvectors in Z, i.e., the indices
+* indicating the nonzero elements in Z. The i-th computed eigenvector
+* is nonzero only in elements ISUPPZ( 2*i-1 ) through
+* ISUPPZ( 2*i ). This is relevant in the case when the matrix
+* is split. ISUPPZ is only set if N>2.
+*
+* WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK)
+* On exit, if INFO = 0, WORK(1) returns the optimal
+* (and minimal) LWORK.
+*
+* LWORK (input) INTEGER
+* The dimension of the array WORK. LWORK >= max(1,18*N)
+* if JOBZ = 'V', and LWORK >= max(1,12*N) if JOBZ = 'N'.
+* If LWORK = -1, then a workspace query is assumed; the routine
+* only calculates the optimal size of the WORK array, returns
+* this value as the first entry of the WORK array, and no error
+* message related to LWORK is issued.
+*
+* IWORK (workspace/output) INTEGER array, dimension (LIWORK)
+* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.
+*
+* LIWORK (input) INTEGER
+* The dimension of the array IWORK. LIWORK >= max(1,10*N)
+* if the eigenvectors are desired, and LIWORK >= max(1,8*N)
+* if only the eigenvalues are to be computed.
+* If LIWORK = -1, then a workspace query is assumed; the
+* routine only calculates the optimal size of the IWORK array,
+* returns this value as the first entry of the IWORK array, and
+* no error message related to LIWORK is issued.
+*
+* DOL (input) INTEGER
+* DOU (input) INTEGER
+* From the eigenvalues W(1:M), only eigenvectors
+* Z(:,DOL) to Z(:,DOU) are computed.
+* If DOL > 1, then Z(:,DOL-1-ZOFFSET) is used and overwritten.
+* If DOU < M, then Z(:,DOU+1-ZOFFSET) is used and overwritten.
+*
+* NEEDIL (input/output) INTEGER
+* NEEDIU (input/output) INTEGER
+* Describes which are the left and right outermost eigenvalues
+* still to be computed. Initially computed by DLARRE2A,
+* modified in the course of the algorithm.
+*
+* INDWLC (output) DOUBLE PRECISION
+* Pointer into the workspace, location where the local
+* eigenvalue representations are stored. ("Local eigenvalues"
+* are those relative to the individual shifts of the RRRs.)
+*
+* PIVMIN (input) DOUBLE PRECISION
+* The minimum pivot in the sturm sequence for T.
+*
+* SCALE (input) DOUBLE PRECISION
+* The scaling factor for T. Used for unscaling the eigenvalues
+* at the very end of the algorithm.
+*
+* WL (input) DOUBLE PRECISION
+* WU (input) DOUBLE PRECISION
+* The interval (WL, WU] contains all the wanted eigenvalues.
+*
+* VSTART (input/output) LOGICAL
+* .TRUE. on initialization, set to .FALSE. afterwards.
+*
+* FINISH (input/output) LOGICAL
+* indicates whether all eigenpairs have been computed
+*
+* MAXCLS (input/output) INTEGER
+* The largest cluster worked on by this processor in the
+* representation tree.
+*
+* NDEPTH (input/output) INTEGER
+* The current depth of the representation tree. Set to
+* zero on initial pass, changed when the deeper levels of
+* the representation tree are generated.
+*
+* PARITY (input/output) INTEGER
+* An internal parameter needed for the storage of the
+* clusters on the current level of the representation tree.
+*
+* ZOFFSET (input) INTEGER
+* Offset for storing the eigenpairs when Z is distributed
+* in 1D-cyclic fashion
+*
+* INFO (output) INTEGER
+* On exit, INFO
+* = 0: successful exit
+* other:if INFO = -i, the i-th argument had an illegal value
+* if INFO = 20X, internal error in DLARRV2.
+* Here, the digit X = ABS( IINFO ) < 10, where IINFO is
+* the nonzero error code returned by DLARRV2.
+*
+* .. Parameters ..
+ DOUBLE PRECISION ONE, FOUR, MINRGP
+ PARAMETER ( ONE = 1.0D0,
+ $ FOUR = 4.0D0,
+ $ MINRGP = 1.0D-3 )
+* ..
+* .. Local Scalars ..
+ LOGICAL LQUERY, WANTZ, ZQUERY
+ INTEGER IINDBL, IINDW, IINDWK, IINFO, IINSPL, INDERR,
+ $ INDGP, INDGRS, INDSDM, INDWRK, ITMP, J, LIWMIN,
+ $ LWMIN
+ DOUBLE PRECISION EPS, RTOL1, RTOL2
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ DOUBLE PRECISION DLAMCH, DLANST
+ EXTERNAL LSAME, DLAMCH, DLANST
+* ..
+* .. External Subroutines ..
+ EXTERNAL DLARRV2, DSCAL
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC DBLE, MAX, MIN, SQRT
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ WANTZ = LSAME( JOBZ, 'V' )
+*
+ LQUERY = ( ( LWORK.EQ.-1 ).OR.( LIWORK.EQ.-1 ) )
+ ZQUERY = ( NZC.EQ.-1 )
+
+* DSTEGR2B needs WORK of size 6*N, IWORK of size 3*N.
+* In addition, DLARRE2A needed WORK of size 6*N, IWORK of size 5*N.
+* Workspace is kept consistent even though DLARRE2A is not called here.
+* Furthermore, DLARRV2 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
+*
+ INFO = 0
+*
+* Get machine constants.
+*
+ EPS = DLAMCH( 'Precision' )
+*
+ IF( (N.EQ.0).OR.(N.EQ.1) ) THEN
+ FINISH = .TRUE.
+ RETURN
+ ENDIF
+
+ IF(ZQUERY.OR.LQUERY)
+ $ RETURN
+*
+ INDGRS = 1
+ INDERR = 2*N + 1
+ INDGP = 3*N + 1
+ INDSDM = 4*N + 1
+ INDWRK = 6*N + 1
+ INDWLC = INDWRK
+*
+ IINSPL = 1
+ IINDBL = N + 1
+ IINDW = 2*N + 1
+ IINDWK = 3*N + 1
+
+* Set the tolerance parameters for bisection
+ RTOL1 = FOUR*SQRT(EPS)
+ RTOL2 = MAX( SQRT(EPS)*5.0D-3, FOUR * EPS )
+
+
+ IF( WANTZ ) THEN
+*
+* Compute the desired eigenvectors corresponding to the computed
+* eigenvalues
+*
+ CALL DLARRV2( N, WL, WU, D, E,
+ $ PIVMIN, IWORK( IINSPL ), M,
+ $ DOL, DOU, NEEDIL, NEEDIU, MINRGP, RTOL1, RTOL2,
+ $ W, WORK( INDERR ), WORK( INDGP ), IWORK( IINDBL ),
+ $ IWORK( IINDW ), WORK( INDGRS ),
+ $ WORK( INDSDM ), Z, LDZ,
+ $ ISUPPZ, WORK( INDWRK ), IWORK( IINDWK ),
+ $ VSTART, FINISH,
+ $ MAXCLS, NDEPTH, PARITY, ZOFFSET, IINFO )
+ IF( IINFO.NE.0 ) THEN
+ INFO = 200 + ABS( IINFO )
+ RETURN
+ END IF
+*
+ ELSE
+* DLARRE2A computed eigenvalues of the (shifted) root representation
+* DLARRV2 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 DLARRE2A to obtain the
+* eigenvalues of the original matrix.
+ DO 30 J = 1, M
+ ITMP = IWORK( IINDBL+J-1 )
+ W( J ) = W( J ) + E( IWORK( IINSPL+ITMP-1 ) )
+ 30 CONTINUE
+*
+ FINISH = .TRUE.
+*
+ END IF
+*
+
+ IF(FINISH) THEN
+* All eigenpairs have been computed
+
+*
+* If matrix was scaled, then rescale eigenvalues appropriately.
+*
+ IF( SCALE.NE.ONE ) THEN
+ CALL DSCAL( M, ONE / SCALE, W, 1 )
+ END IF
+*
+* Correct M if needed
+*
+ IF ( WANTZ ) THEN
+ IF( DOL.NE.1 .OR. DOU.NE.M ) THEN
+ M = DOU - DOL +1
+ ENDIF
+ ENDIF
+*
+* No sorting of eigenpairs is done here, done later in the
+* calling subroutine
+*
+ WORK( 1 ) = LWMIN
+ IWORK( 1 ) = LIWMIN
+ ENDIF
+
+ RETURN
+*
+* End of DSTEGR2B
+*
+ END
diff --git a/SRC/lamov.h b/SRC/lamov.h
new file mode 100644
index 0000000..d2c45d3
--- /dev/null
+++ b/SRC/lamov.h
@@ -0,0 +1,104 @@
+//
+// lamov.h
+//
+// Written by Lee Killough 04/19/2012
+//
+
+#include "pblas.h"
+#include <ctype.h>
+
+extern void xerbla_(const char *, const F_INTG_FCT *, size_t);
+
+void LACPY(const char *UPLO,
+ const F_INTG_FCT *M,
+ const F_INTG_FCT *N,
+ const TYPE *A,
+ const F_INTG_FCT *LDA,
+ TYPE *B,
+ const F_INTG_FCT *LDB);
+
+void LAMOV(const char *UPLO,
+ const F_INTG_FCT *M,
+ const F_INTG_FCT *N,
+ const TYPE *A,
+ const F_INTG_FCT *LDA,
+ TYPE *B,
+ const F_INTG_FCT *LDB)
+{
+ const F_INTG_FCT m = *M;
+ const F_INTG_FCT n = *N;
+ const F_INTG_FCT lda = *LDA;
+ const F_INTG_FCT ldb = *LDB;
+
+ if (B + m-1 + ldb*(n-1) < A || A + m-1 + lda*(n-1) < B)
+ {
+ LACPY(UPLO, M, N, A, LDA, B, LDB);
+ }
+ else if (lda != ldb)
+ {
+ TYPE *tmp = malloc(sizeof(*A) * m * n);
+ if (!tmp)
+ {
+ F_INTG_FCT info = -1;
+ const char func[] = FUNC;
+ xerbla_(func, &info, sizeof func);
+ }
+ else
+ {
+ LACPY(UPLO, M, N, A, LDA, tmp, &m);
+ LACPY(UPLO, M, N, tmp, &m, B, LDB);
+ free(tmp);
+ }
+ }
+ else
+ {
+ F_INTG_FCT i, j;
+ switch (toupper(*UPLO))
+ {
+ case 'U':
+ if (A > B)
+ {
+ for (j=0; j<n; j++)
+ for (i=0; i<j && i<m; i++)
+ B[i+ldb*j] = A[i+lda*j];
+ }
+ else
+ {
+ for (j=n; --j>=0;)
+ for (i=j<m ? j : m; --i>=0;)
+ B[i+ldb*j] = A[i+lda*j];
+ }
+ break;
+
+ case 'L':
+ if (A > B)
+ {
+ for (j=0; j<n; j++)
+ for (i=j; i<m; i++)
+ B[i+ldb*j] = A[i+lda*j];
+ }
+ else
+ {
+ for (j=m<n ? m : n; --j>=0;)
+ for (i=m; --i>=j;)
+ B[i+ldb*j] = A[i+lda*j];
+ }
+ break;
+
+ default:
+ if (A > B)
+ {
+ for (j=0; j<n; j++)
+ for (i=0; i<m; i++)
+ B[i+ldb*j] = A[i+lda*j];
+ }
+ else
+ {
+ for (j=n; --j>=0;)
+ for (i=m; --i>=0;)
+ B[i+ldb*j] = A[i+lda*j];
+ }
+ break;
+ }
+ }
+}
diff --git a/SRC/pblas.h b/SRC/pblas.h
index 6675085..b86c0da 100644
--- a/SRC/pblas.h
+++ b/SRC/pblas.h
@@ -227,6 +227,16 @@ typedef char * F_CHAR;
#define zcombamax_ ZCOMBAMAX
#define scombnrm2_ SCOMBNRM2
#define dcombnrm2_ DCOMBNRM2
+
+#define dlamov_ DLAMOV
+#define slamov_ SLAMOV
+#define clamov_ CLAMOV
+#define zlamov_ ZLAMOV
+#define dlacpy_ DLACPY
+#define slacpy_ SLACPY
+#define clacpy_ CLACPY
+#define zlacpy_ ZLACPY
+#define xerbla_ XERBLA
/* BLACS */
#define blacs_abort_ BLACS_ABORT
#define blacs_gridinfo_ BLACS_GRIDINFO
@@ -543,6 +553,7 @@ typedef char * F_CHAR;
#define pscasum_ PSCASUM
#define pcamax_ PCAMAX
#define pcrot_ PCROT
+#define crot_ CROT
#define pzswap_ PZSWAP
#define pzscal_ PZSCAL
@@ -555,6 +566,7 @@ typedef char * F_CHAR;
#define pdzasum_ PDZASUM
#define pzamax_ PZAMAX
#define pzrot_ PZROT
+#define zrot_ ZROT
/* Level-2 PBLAS */
#define pcgemv_ PCGEMV
#define pcgeru_ PCGERU
@@ -654,6 +666,16 @@ typedef char * F_CHAR;
#define zcombamax_ zcombamax
#define scombnrm2_ scombnrm2
#define dcombnrm2_ dcombnrm2
+
+#define dlamov_ dlamov
+#define slamov_ slamov
+#define clamov_ clamov
+#define zlamov_ zlamov
+#define dlacpy_ dlacpy
+#define slacpy_ slacpy
+#define clacpy_ clacpy
+#define zlacpy_ zlacpy
+#define xerbla_ xerbla
/* BLACS */
#define blacs_abort_ blacs_abort
#define blacs_gridinfo_ blacs_gridinfo
diff --git a/SRC/pcdbtrf.f b/SRC/pcdbtrf.f
index 47856cb..cee598d 100644
--- a/SRC/pcdbtrf.f
+++ b/SRC/pcdbtrf.f
@@ -1,12 +1,9 @@
SUBROUTINE PCDBTRF( N, BWL, BWU, A, JA, DESCA, AF, LAF, WORK,
$ LWORK, INFO )
*
-*
-*
-* -- ScaLAPACK routine (version 1.7) --
-* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
-* and University of California, Berkeley.
-* May 25, 2001
+* -- ScaLAPACK routine (version 2.0.2) --
+* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver
+* May 1 2012
*
* .. Scalar Arguments ..
INTEGER BWL, BWU, INFO, JA, LAF, LWORK, N
@@ -380,7 +377,7 @@
* ..
* .. External Subroutines ..
EXTERNAL BLACS_GET, BLACS_GRIDEXIT, BLACS_GRIDINFO,
- $ CAXPY, CGEMM, CGERV2D, CGESD2D, CLACPY,
+ $ CAXPY, CGEMM, CGERV2D, CGESD2D, CLAMOV,
$ CLATCPY, CPBTRF, CPOTRF, CSYRK, CTBTRS, CTRMM,
$ CTRRV2D, CTRSD2D, CTRSM, CTRTRS, DESC_CONVERT,
$ GLOBCHK, PXERBLA, RESHAPE
@@ -743,7 +740,7 @@
$ A(( OFST+(BWL+BWU+1)+(ODD_SIZE-BWL)*LLDA )),
$ LLDA-1, AF( ODD_SIZE*BWU+2*MBW2+1+MAX_BW-BWL ),
$ MAX_BW )
- CALL CLACPY( 'L', BWU, BWU, A( ( OFST+1+ODD_SIZE*LLDA ) ),
+ CALL CLAMOV( 'L', BWU, BWU, A( ( OFST+1+ODD_SIZE*LLDA ) ),
$ LLDA-1,
$ AF( WORK_U+ODD_SIZE*BWL+2*MBW2+1+MAX_BW-BWU ),
$ MAX_BW )
@@ -772,7 +769,7 @@
*
* Move the resulting block back to its location in main storage.
*
- CALL CLACPY( 'L', BWU, BWU,
+ CALL CLAMOV( 'L', BWU, BWU,
$ AF( WORK_U+ODD_SIZE*BWL+2*MBW2+1+MAX_BW-BWU ),
$ MAX_BW, A(( OFST+1+ODD_SIZE*LLDA )), LLDA-1 )
*
@@ -952,7 +949,7 @@
* Copy last diagonal block into AF storage for subsequent
* operations.
*
- CALL CLACPY( 'N', MAX_BW, MAX_BW,
+ CALL CLAMOV( 'N', MAX_BW, MAX_BW,
$ A( OFST+ODD_SIZE*LLDA+BWU+1 ),
$ LLDA-1, AF( ODD_SIZE*BWU+MBW2+1 ),
$ MAX_BW )
@@ -1040,11 +1037,11 @@
* Move block into place that it will be expected to be for
* calcs.
*
- CALL CLACPY( 'N', MAX_BW, MAX_BW, AF( ODD_SIZE*BWU+1 ),
+ CALL CLAMOV( 'N', MAX_BW, MAX_BW, AF( ODD_SIZE*BWU+1 ),
$ MAX_BW, AF( WORK_U+ODD_SIZE*BWL+2*MBW2+1 ),
$ MAX_BW )
*
- CALL CLACPY( 'N', MAX_BW, MAX_BW, AF( WORK_U+ODD_SIZE*BWL+1 ),
+ CALL CLAMOV( 'N', MAX_BW, MAX_BW, AF( WORK_U+ODD_SIZE*BWL+1 ),
$ MAX_BW, AF( ODD_SIZE*BWU+2*MBW2+1 ), MAX_BW )
*
ELSE
diff --git a/SRC/pcdbtrsv.f b/SRC/pcdbtrsv.f
index f4639bf..fbb0dda 100644
--- a/SRC/pcdbtrsv.f
+++ b/SRC/pcdbtrsv.f
@@ -1,12 +1,9 @@
SUBROUTINE PCDBTRSV( UPLO, TRANS, N, BWL, BWU, NRHS, A, JA, DESCA,
$ B, IB, DESCB, AF, LAF, WORK, LWORK, INFO )
*
-*
-*
-* -- ScaLAPACK routine (version 1.7) --
-* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
-* and University of California, Berkeley.
-* November 15, 1997
+* -- ScaLAPACK routine (version 2.0.2) --
+* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver
+* May 1 2012
*
* .. Scalar Arguments ..
CHARACTER TRANS, UPLO
@@ -403,7 +400,7 @@
* ..
* .. External Subroutines ..
EXTERNAL BLACS_GET, BLACS_GRIDEXIT, BLACS_GRIDINFO,
- $ CGEMM, CGERV2D, CGESD2D, CLACPY, CMATADD,
+ $ CGEMM, CGERV2D, CGESD2D, CLAMOV, CMATADD,
$ CTBTRS, CTRMM, CTRTRS, DESC_CONVERT, GLOBCHK,
$ PXERBLA, RESHAPE
* ..
@@ -787,7 +784,7 @@
* First copy and multiply it into temporary storage,
* then use it on RHS
*
- CALL CLACPY( 'N', BWL, NRHS,
+ CALL CLAMOV( 'N', BWL, NRHS,
$ B( PART_OFFSET+ODD_SIZE-BWL+1), LLDB,
$ WORK( 1 ), MAX_BW )
*
@@ -1138,7 +1135,7 @@
* First copy and multiply it into temporary storage,
* then use it on RHS
*
- CALL CLACPY( 'N', BWL, NRHS, B( PART_OFFSET+ODD_SIZE+1), LLDB,
+ CALL CLAMOV( 'N', BWL, NRHS, B( PART_OFFSET+ODD_SIZE+1), LLDB,
$ WORK( 1+MAX_BW-BWL ), MAX_BW )
*
CALL CTRMM( 'L', 'U', 'C', 'N', BWL, NRHS, -CONE,
@@ -1191,7 +1188,7 @@
* First copy and multiply it into temporary storage,
* then use it on RHS
*
- CALL CLACPY( 'N', BWU, NRHS,
+ CALL CLAMOV( 'N', BWU, NRHS,
$ B( PART_OFFSET+ODD_SIZE-BWU+1), LLDB,
$ WORK( 1 ), MAX_BW )
*
@@ -1544,7 +1541,7 @@
* First copy and multiply it into temporary storage,
* then use it on RHS
*
- CALL CLACPY( 'N', BWU, NRHS, B( PART_OFFSET+ODD_SIZE+1), LLDB,
+ CALL CLAMOV( 'N', BWU, NRHS, B( PART_OFFSET+ODD_SIZE+1), LLDB,
$ WORK( 1+MAX_BW-BWU ), MAX_BW+BWL )
*
CALL CTRMM( 'L', 'L', 'N', 'N', BWU, NRHS, -CONE,
diff --git a/SRC/pcdttrf.f b/SRC/pcdttrf.f
index cfca3b9..2443fa9 100644
--- a/SRC/pcdttrf.f
+++ b/SRC/pcdttrf.f
@@ -1,12 +1,9 @@
SUBROUTINE PCDTTRF( N, DL, D, DU, JA, DESCA, AF, LAF, WORK, LWORK,
$ INFO )
*
-*
-*
-* -- ScaLAPACK routine (version 1.7) --
-* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
-* and University of California, Berkeley.
-* May 25, 2001
+* -- ScaLAPACK routine (version 2.0.2) --
+* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver
+* May 1 2012
*
* .. Scalar Arguments ..
INTEGER INFO, JA, LAF, LWORK, N
@@ -385,7 +382,7 @@
* ..
* .. External Subroutines ..
EXTERNAL BLACS_GET, BLACS_GRIDEXIT, BLACS_GRIDINFO,
- $ CAXPY, CGEMM, CGERV2D, CGESD2D, CLACPY,
+ $ CAXPY, CGEMM, CGERV2D, CGESD2D, CLAMOV,
$ CLATCPY, CPBTRF, CPOTRF, CSYRK, CTBTRS, CTRMM,
$ CTRRV2D, CTRSD2D, CTRSM, CTRTRS, DESC_CONVERT,
$ GLOBCHK, PXERBLA, RESHAPE
diff --git a/SRC/pcdttrsv.f b/SRC/pcdttrsv.f
index ef61a98..417c14d 100644
--- a/SRC/pcdttrsv.f
+++ b/SRC/pcdttrsv.f
@@ -1,12 +1,9 @@
SUBROUTINE PCDTTRSV( UPLO, TRANS, N, NRHS, DL, D, DU, JA, DESCA,
$ B, IB, DESCB, AF, LAF, WORK, LWORK, INFO )
*
-*
-*
-* -- ScaLAPACK routine (version 1.7) --
-* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
-* and University of California, Berkeley.
-* November 15, 1997
+* -- ScaLAPACK routine (version 2.0.2) --
+* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver
+* May 1 2012
*
* .. Scalar Arguments ..
CHARACTER TRANS, UPLO
@@ -417,7 +414,7 @@
* ..
* .. External Subroutines ..
EXTERNAL BLACS_GET, BLACS_GRIDEXIT, BLACS_GRIDINFO,
- $ CGEMM, CGERV2D, CGESD2D, CLACPY, CMATADD,
+ $ CGEMM, CGERV2D, CGESD2D, CLAMOV, CMATADD,
$ CTBTRS, CTRMM, CTRTRS, DESC_CONVERT, GLOBCHK,
$ PXERBLA, RESHAPE
* ..
diff --git a/SRC/pcgbtrf.f b/SRC/pcgbtrf.f
index 6d0e68c..ce246fd 100644
--- a/SRC/pcgbtrf.f
+++ b/SRC/pcgbtrf.f
@@ -1,12 +1,9 @@
SUBROUTINE PCGBTRF( N, BWL, BWU, A, JA, DESCA, IPIV, AF, LAF,
$ WORK, LWORK, INFO )
*
-*
-*
-* -- ScaLAPACK routine (version 1.7) --
-* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
-* and University of California, Berkeley.
-* November 15, 1997
+* -- ScaLAPACK routine (version 2.0.2) --
+* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver
+* May 1 2012
*
* .. Scalar Arguments ..
INTEGER BWL, BWU, INFO, JA, LAF, LWORK, N
@@ -389,7 +386,7 @@
* ..
* .. External Subroutines ..
EXTERNAL BLACS_GRIDEXIT, BLACS_GRIDINFO, CAXPY, CGEMM,
- $ CGERV2D, CGESD2D, CLACPY, CLATCPY, CPBTRF,
+ $ CGERV2D, CGESD2D, CLAMOV, CLATCPY, CPBTRF,
$ CPOTRF, CSYRK, CTBTRS, CTRMM, CTRRV2D, CTRSD2D,
$ CTRSM, CTRTRS, DESC_CONVERT, GLOBCHK, PXERBLA,
$ RESHAPE
@@ -841,7 +838,7 @@
* DBPTR = Pointer to diagonal blocks in A
DBPTR = BW+1 + LBWU + LN*LLDA
*
- CALL CLACPY('G',BM,BN, A(DBPTR),LLDA-1,
+ CALL CLAMOV('G',BM,BN, A(DBPTR),LLDA-1,
$ AF(BBPTR + BW*LDBB),LDBB)
*
* Zero out any junk entries that were copied
@@ -857,7 +854,7 @@
* ODPTR = Pointer to offdiagonal blocks in A
*
ODPTR = LM-BM+1
- CALL CLACPY('G',BM,BW, AF(ODPTR),LM,
+ CALL CLAMOV('G',BM,BW, AF(ODPTR),LM,
$ AF(BBPTR +2*BW*LDBB),LDBB)
ENDIF
*
@@ -924,7 +921,7 @@
*
* Copy diagonal block to align whole system
*
- CALL CLACPY( 'G', BMN, BW, AF( BBPTR+BM ),
+ CALL CLAMOV( 'G', BMN, BW, AF( BBPTR+BM ),
$ LDBB, AF( BBPTR+2*BW*LDBB+BM ), LDBB )
ENDIF
*
@@ -950,7 +947,7 @@
CALL CGESD2D( ICTXT, BM, 2*BW, AF(BBPTR+BW*LDBB),
$ LDBB, 0, NEICOL )
*
- CALL CLACPY('G',BM, 2*BW, AF(BBPTR+BW*LDBB),LDBB,
+ CALL CLAMOV('G',BM, 2*BW, AF(BBPTR+BW*LDBB),LDBB,
$ AF(BBPTR+BMN),LDBB)
*
DO 31 J=BBPTR+2*BW*LDBB, BBPTR+3*BW*LDBB-1, LDBB
@@ -966,7 +963,7 @@
*
* Copy diagonal block to align whole system
*
- CALL CLACPY( 'G', BM, BW, AF( BBPTR+BMN ),
+ CALL CLAMOV( 'G', BM, BW, AF( BBPTR+BMN ),
$ LDBB, AF( BBPTR+2*BW*LDBB+BMN ), LDBB )
ENDIF
*
@@ -1029,10 +1026,10 @@
* Local copying in the block bidiagonal area
*
*
- CALL CLACPY('G',BM,BW,
+ CALL CLAMOV('G',BM,BW,
$ AF(BBPTR+BW),
$ LDBB, AF(BBPTR+BW*LDBB), LDBB)
- CALL CLACPY('G',BM,BW,
+ CALL CLAMOV('G',BM,BW,
$ AF(BBPTR+2*BW*LDBB+BW),
$ LDBB, AF(BBPTR+2*BW*LDBB), LDBB)
*
diff --git a/SRC/pcgbtrs.f b/SRC/pcgbtrs.f
index 71b8f0a..1ded078 100644
--- a/SRC/pcgbtrs.f
+++ b/SRC/pcgbtrs.f
@@ -1,12 +1,9 @@
SUBROUTINE PCGBTRS( TRANS, N, BWL, BWU, NRHS, A, JA, DESCA, IPIV,
$ B, IB, DESCB, AF, LAF, WORK, LWORK, INFO )
*
-*
-*
-* -- ScaLAPACK routine (version 1.7) --
-* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
-* and University of California, Berkeley.
-* August 7, 2001
+* -- ScaLAPACK routine (version 2.0.2) --
+* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver
+* May 1 2012
*
* .. Scalar Arguments ..
CHARACTER TRANS
@@ -737,7 +734,7 @@
*
LDW = NB+BWU + 2*BW+BWU
*
- CALL CLACPY( 'G', LM, NRHS, B(1), LLDB, WORK( WPTR ), LDW )
+ CALL CLAMOV( 'G', LM, NRHS, B(1), LLDB, WORK( WPTR ), LDW )
*
* Zero out rest of work
*
@@ -882,7 +879,7 @@
BMN = BW
ENDIF
*
- CALL CLACPY( 'G', BM, NRHS, WORK(LN+1), LDW,
+ CALL CLAMOV( 'G', BM, NRHS, WORK(LN+1), LDW,
$ WORK(NB+BWU+BMN+1), LDW )
*
CALL CGERV2D( ICTXT, BMN, NRHS, WORK( NB+BWU+1 ),
@@ -1029,7 +1026,7 @@
*
* Move RHS to make room for received solutions
*
- CALL CLACPY( 'G', BW, NRHS, WORK(NB+BWU+1),
+ CALL CLAMOV( 'G', BW, NRHS, WORK(NB+BWU+1),
$ LDW, WORK(NB+BWU+BW+1), LDW )
*
CALL CGERV2D( ICTXT, 2*BW, NRHS, WORK( LN+1 ),
@@ -1060,7 +1057,7 @@
*
* Copy new solution into expected place
*
- CALL CLACPY( 'G', BW, NRHS, WORK(NB+BWU+1+BW),
+ CALL CLAMOV( 'G', BW, NRHS, WORK(NB+BWU+1+BW),
$ LDW, WORK(LN+BW+1), LDW )
*
ELSE
@@ -1077,7 +1074,7 @@
*
* Shift solutions into expected positions
*
- CALL CLACPY( 'G', BNN+BN-BW, NRHS, WORK(NB+BWU+1+BW),
+ CALL CLAMOV( 'G', BNN+BN-BW, NRHS, WORK(NB+BWU+1+BW),
$ LDW, WORK(LN+1), LDW )
*
*
@@ -1155,7 +1152,7 @@
*
*
*
- CALL CLACPY( 'G', ODD_SIZE, NRHS, WORK( 1 ), LDW,
+ CALL CLAMOV( 'G', ODD_SIZE, NRHS, WORK( 1 ), LDW,
$ B( 1 ), LLDB )
*
* Free BLACS space used to hold standard-form grid.
diff --git a/SRC/pcgecon.f b/SRC/pcgecon.f
index 8b84f14..82b157c 100644
--- a/SRC/pcgecon.f
+++ b/SRC/pcgecon.f
@@ -154,7 +154,7 @@
* LRWORK (local or global input) INTEGER
* The dimension of the array RWORK.
* LRWORK is local input and must be at least
-* LRWORK >= 2*LOCc(N+MOD(JA-1,NB_A)).
+* LRWORK >= MAX( 1, 2*LOCc(N+MOD(JA-1,NB_A)) ).
*
* If LRWORK = -1, then LRWORK is global input and a workspace
* query is assumed; the routine only calculates the minimum
@@ -246,7 +246,7 @@
$ DESCA( NB_ )*
$ MAX( 1, ICEIL( NPCOL-1, NPROW ) ) ) )
WORK( 1 ) = REAL( LWMIN )
- LRWMIN = 2*NQMOD
+ LRWMIN = MAX( 1, 2*NQMOD )
RWORK( 1 ) = REAL( LRWMIN )
LQUERY = ( LWORK.EQ.-1 .OR. LRWORK.EQ.-1 )
*
diff --git a/SRC/pcgels.f b/SRC/pcgels.f
index 9ae7cf0..494c10a 100644
--- a/SRC/pcgels.f
+++ b/SRC/pcgels.f
@@ -280,7 +280,11 @@
INFO = -( 800 + CTXT_ )
ELSE
CALL CHK1MAT( M, 2, N, 3, IA, JA, DESCA, 8, INFO )
- CALL CHK1MAT( N, 3, NRHS, 4, IB, JB, DESCB, 12, INFO )
+ IF ( M .GE. N ) THEN
+ CALL CHK1MAT( M, 2, NRHS, 4, IB, JB, DESCB, 12, INFO )
+ ELSE
+ CALL CHK1MAT( N, 3, NRHS, 4, IB, JB, DESCB, 12, INFO )
+ ENDIF
IF( INFO.EQ.0 ) THEN
IROFFA = MOD( IA-1, DESCA( MB_ ) )
ICOFFA = MOD( JA-1, DESCA( NB_ ) )
diff --git a/SRC/pcheev.f b/SRC/pcheev.f
index 93b1bfd..f64067d 100644
--- a/SRC/pcheev.f
+++ b/SRC/pcheev.f
@@ -20,7 +20,7 @@
* =======
*
* PCHEEV computes selected eigenvalues and, optionally, eigenvectors
-* of a real symmetric matrix A by calling the recommended sequence
+* of a real Hermitian matrix A by calling the recommended sequence
* of ScaLAPACK routines.
*
* In its present form, PCHEEV assumes a homogeneous system and makes
@@ -91,7 +91,7 @@
*
* UPLO (global input) CHARACTER*1
* Specifies whether the upper or lower triangular part of the
-* symmetric matrix A is stored:
+* Hermitian matrix A is stored:
* = 'U': Upper triangular
* = 'L': Lower triangular
*
@@ -102,11 +102,11 @@
* global dimension (N, N), local dimension ( LLD_A,
* LOCc(JA+N-1) )
*
-* On entry, the symmetric matrix A. If UPLO = 'U', only the
+* On entry, the Hermitian matrix A. If UPLO = 'U', only the
* upper triangular part of A is used to define the elements of
-* the symmetric matrix. If UPLO = 'L', only the lower
+* the Hermitian matrix. If UPLO = 'L', only the lower
* triangular part of A is used to define the elements of the
-* symmetric matrix.
+* Hermitian matrix.
*
* On exit, the lower triangle (if UPLO='L') or the upper
* triangle (if UPLO='U') of A, including the diagonal, is
@@ -126,8 +126,7 @@
* correct error reporting.
*
* W (global output) REAL array, dimension (N)
-* On normal exit, the first M entries contain the selected
-* eigenvalues in ascending order.
+* If INFO=0, the eigenvalues in ascending order.
*
* Z (local output) COMPLEX array,
* global dimension (N, N),
@@ -354,6 +353,9 @@
RSRC_Z = DESCZ( RSRC_ )
IROFFZ = MOD( IZ-1, MB_A )
IZROW = INDXG2P( 1, NB_A, MYROW, RSRC_Z, NPROW )
+ ELSE
+ IROFFZ = 0
+ IZROW = 0
END IF
*
* COMPLEX work space for PCHETRD
@@ -524,7 +526,7 @@
CALL PCLASCL( UPLO, ONE, SIGMA, N, N, A, IA, JA, DESCA, IINFO )
END IF
*
-* Reduce symmetric matrix to tridiagonal form.
+* Reduce Hermitian matrix to tridiagonal form.
*
CALL PCHETRD( UPLO, N, A, IA, JA, DESCA, RWORK( INDRD ),
$ RWORK( INDRE ), WORK( INDTAU ), WORK( INDWORK ),
diff --git a/SRC/pcheevr.f b/SRC/pcheevr.f
new file mode 100644
index 0000000..b04a2e5
--- /dev/null
+++ b/SRC/pcheevr.f
@@ -0,0 +1,1219 @@
+ SUBROUTINE PCHEEVR( JOBZ, RANGE, UPLO, N, A, IA, JA,
+ $ DESCA, VL, VU, IL, IU, M, NZ, W, Z, IZ,
+ $ JZ, DESCZ,
+ $ WORK, LWORK, RWORK, LRWORK, IWORK, LIWORK,
+ $ INFO )
+
+ IMPLICIT NONE
+*
+* -- ScaLAPACK routine (version 2.0.2) --
+* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver
+* May 1 2012
+*
+* .. Scalar Arguments ..
+ CHARACTER JOBZ, RANGE, UPLO
+
+ INTEGER IA, IL, INFO, IU, IZ, JA, JZ, LIWORK, LRWORK,
+ $ LWORK, M, N, NZ
+ REAL VL, VU
+* ..
+* .. Array Arguments ..
+ INTEGER DESCA( * ), DESCZ( * ), IWORK( * )
+ REAL W( * ), RWORK( * )
+ COMPLEX A( * ), WORK( * ), Z( * )
+* ..
+*
+* Purpose
+* =======
+*
+* PCHEEVR computes selected eigenvalues and, optionally, eigenvectors
+* of a complex Hermitian matrix A distributed in 2D blockcyclic format
+* by calling the recommended sequence of ScaLAPACK routines.
+*
+* First, the matrix A is reduced to real symmetric tridiagonal form.
+* Then, the eigenproblem is solved using the parallel MRRR algorithm.
+* Last, if eigenvectors have been computed, a backtransformation is done.
+*
+* Upon successful completion, each processor stores a copy of all computed
+* eigenvalues in W. The eigenvector matrix Z is stored in
+* 2D blockcyclic format distributed over all processors.
+*
+* For constructive feedback and comments, please contact cvoemel at lbl.gov
+* C. Voemel
+*
+*
+* Arguments
+* =========
+*
+* JOBZ (global input) CHARACTER*1
+* Specifies whether or not to compute the eigenvectors:
+* = 'N': Compute eigenvalues only.
+* = 'V': Compute eigenvalues and eigenvectors.
+*
+* RANGE (global input) CHARACTER*1
+* = 'A': all eigenvalues will be found.
+* = 'V': all eigenvalues in the interval [VL,VU] will be found.
+* = 'I': the IL-th through IU-th eigenvalues will be found.
+*
+* UPLO (global input) CHARACTER*1
+* Specifies whether the upper or lower triangular part of the
+* symmetric matrix A is stored:
+* = 'U': Upper triangular
+* = 'L': Lower triangular
+*
+* N (global input) INTEGER
+* The number of rows and columns of the matrix A. N >= 0
+*
+* A (local input/workspace) 2D block cyclic COMPLEX array,
+* global dimension (N, N),
+* local dimension ( LLD_A, LOCc(JA+N-1) )
+* (see Notes below for more detailed explanation of 2d arrays)
+*
+* On entry, the symmetric matrix A. If UPLO = 'U', only the
+* upper triangular part of A is used to define the elements of
+* the symmetric matrix. If UPLO = 'L', only the lower
+* triangular part of A is used to define the elements of the
+* symmetric matrix.
+*
+* On exit, the lower triangle (if UPLO='L') or the upper
+* triangle (if UPLO='U') of A, including the diagonal, is
+* destroyed.
+*
+* IA (global input) INTEGER
+* A's global row index, which points to the beginning of the
+* submatrix which is to be operated on.
+* It should be set to 1 when operating on a full matrix.
+*
+* JA (global input) INTEGER
+* A's global column index, which points to the beginning of
+* the submatrix which is to be operated on.
+* It should be set to 1 when operating on a full matrix.
+*
+* DESCA (global and local input) INTEGER array of dimension DLEN_.
+* (The ScaLAPACK descriptor length is DLEN_ = 9.)
+* The array descriptor for the distributed matrix A.
+* The descriptor stores details about the 2D block-cyclic
+* storage, see the notes below.
+* If DESCA is incorrect, PCHEEVR cannot work correctly.
+* Also note the array alignment requirements specified below
+*
+* VL (global input) REAL
+* If RANGE='V', the lower bound of the interval to be searched
+* for eigenvalues. Not referenced if RANGE = 'A' or 'I'.
+*
+* VU (global input) REAL
+* If RANGE='V', the upper bound of the interval to be searched
+* for eigenvalues. Not referenced if RANGE = 'A' or 'I'.
+*
+* IL (global input) INTEGER
+* If RANGE='I', the index (from smallest to largest) of the
+* smallest eigenvalue to be returned. IL >= 1.
+* Not referenced if RANGE = 'A'.
+*
+* IU (global input) INTEGER
+* If RANGE='I', the index (from smallest to largest) of the
+* largest eigenvalue to be returned. min(IL,N) <= IU <= N.
+* Not referenced if RANGE = 'A'.
+*
+* M (global output) INTEGER
+* Total number of eigenvalues found. 0 <= M <= N.
+*
+* NZ (global output) INTEGER
+* Total number of eigenvectors computed. 0 <= NZ <= M.
+* The number of columns of Z that are filled.
+* If JOBZ .NE. 'V', NZ is not referenced.
+* If JOBZ .EQ. 'V', NZ = M
+*
+* W (global output) REAL array, dimension (N)
+* On normal exit, the first M entries contain the selected
+* eigenvalues in ascending order.
+*
+* Z (local output) COMPLEX array,
+* global dimension (N, N),
+* local dimension ( LLD_Z, LOCc(JZ+N-1) )
+* If JOBZ = 'V', then on normal exit the first M columns of Z
+* contain the orthonormal eigenvectors of the matrix
+* corresponding to the selected eigenvalues.
+* If JOBZ = 'N', then Z is not referenced.
+*
+* IZ (global input) INTEGER
+* Z's global row index, which points to the beginning of the
+* submatrix which is to be operated on.
+* It should be set to 1 when operating on a full matrix.
+*
+* JZ (global input) INTEGER
+* Z's global column index, which points to the beginning of
+* the submatrix which is to be operated on.
+* It should be set to 1 when operating on a full matrix.
+*
+* DESCZ (global and local input) INTEGER array of dimension DLEN_.
+* The array descriptor for the distributed matrix Z.
+* DESCZ( CTXT_ ) must equal DESCA( CTXT_ )
+*
+* WORK (local workspace/output) COMPLEX array,
+* dimension (LWORK)
+* WORK(1) returns workspace adequate workspace to allow
+* optimal performance.
+*
+* LWORK (local input) INTEGER
+* Size of WORK array, must be at least 3.
+* If only eigenvalues are requested:
+* LWORK >= N + MAX( NB * ( NP00 + 1 ), NB * 3 )
+* If eigenvectors are requested:
+* LWORK >= N + ( NP00 + MQ00 + NB ) * NB
+* For definitions of NP00 & MQ00, see LRWORK.
+*
+* For optimal performance, greater workspace is needed, i.e.
+* LWORK >= MAX( LWORK, NHETRD_LWORK )
+* Where LWORK is as defined above, and
+* NHETRD_LWORK = N + 2*( ANB+1 )*( 4*NPS+2 ) +
+* ( NPS + 1 ) * NPS
+*
+* ICTXT = DESCA( CTXT_ )
+* ANB = PJLAENV( ICTXT, 3, 'PCHETTRD', 'L', 0, 0, 0, 0 )
+* SQNPC = SQRT( REAL( NPROW * NPCOL ) )
+* NPS = MAX( NUMROC( N, 1, 0, 0, SQNPC ), 2*ANB )
+*
+* If LWORK = -1, then LWORK is global input and a workspace
+* query is assumed; the routine only calculates the
+* optimal size for all work arrays. Each of these
+* values is returned in the first entry of the corresponding
+* work array, and no error message is issued by PXERBLA.
+* NOTE THAT FOR OPTIMAL PERFORMANCE, LWOPT IS RETURNED
+* (THE OPTIMUM WORKSPACE) RATHER THAN THE MINIMUM NECESSARY
+* WORKSPACE LWMIN WHEN A WORKSPACE QUERY IS ISSUED.
+* FOR VERY SMALL MATRICES, LWOPT >> LWMIN.
+*
+* RWORK (local workspace/output) REAL array,
+* dimension (LRWORK)
+* On return, RWORK(1) contains the optimal amount of
+* workspace required for efficient execution.
+* if JOBZ='N' RWORK(1) = optimal amount of workspace
+* required to compute the eigenvalues.
+* if JOBZ='V' RWORK(1) = optimal amount of workspace
+* required to compute eigenvalues and eigenvectors.
+*
+* LRWORK (local input) INTEGER
+* Size of RWORK, must be at least 3.
+* See below for definitions of variables used to define LRWORK.
+* If no eigenvectors are requested (JOBZ = 'N') then
+* LRWORK >= 2 + 5 * N + MAX( 12 * N, NB * ( NP00 + 1 ) )
+* If eigenvectors are requested (JOBZ = 'V' ) then
+* the amount of workspace required is:
+* LRWORK >= 2 + 5 * N + MAX( 18*N, NP00 * MQ00 + 2 * NB * NB ) +
+* (2 + ICEIL( NEIG, NPROW*NPCOL))*N
+*
+* Variable definitions:
+* NEIG = number of eigenvectors requested
+* NB = DESCA( MB_ ) = DESCA( NB_ ) =
+* DESCZ( MB_ ) = DESCZ( NB_ )
+* NN = MAX( N, NB, 2 )
+* DESCA( RSRC_ ) = DESCA( NB_ ) = DESCZ( RSRC_ ) =
+* DESCZ( CSRC_ ) = 0
+* NP00 = NUMROC( NN, NB, 0, 0, NPROW )
+* MQ00 = NUMROC( MAX( NEIG, NB, 2 ), NB, 0, 0, NPCOL )
+* ICEIL( X, Y ) is a ScaLAPACK function returning
+* ceiling(X/Y)
+*
+* If LRWORK = -1, then LRWORK is global input and a workspace
+* query is assumed; the routine only calculates the size
+* required for optimal performance for all work arrays. Each of
+* these values is returned in the first entry of the
+* corresponding work arrays, and no error message is issued by
+* PXERBLA.
+*
+* IWORK (local workspace) INTEGER array
+* On return, IWORK(1) contains the amount of integer workspace
+* required.
+*
+* LIWORK (local input) INTEGER
+* size of IWORK
+*
+* Let NNP = MAX( N, NPROW*NPCOL + 1, 4 ). Then:
+* LIWORK >= 12*NNP + 2*N when the eigenvectors are desired
+* LIWORK >= 10*NNP + 2*N when only the eigenvalues have to be computed
+*
+* If LIWORK = -1, then LIWORK is global input and a workspace
+* query is assumed; the routine only calculates the minimum
+* and optimal size for all work arrays. Each of these
+* values is returned in the first entry of the corresponding
+* work array, and no error message is issued by PXERBLA.
+*
+* INFO (global output) INTEGER
+* = 0: successful exit
+* < 0: If the i-th argument is an array and the j-entry had
+* an illegal value, then INFO = -(i*100+j), if the i-th
+* argument is a scalar and had an illegal value, then
+* INFO = -i.
+*
+* Notes
+* =====
+*
+* Each global data object is described by an associated description
+* vector. This vector stores the information required to establish
+* the mapping between an object element and its corresponding process
+* and memory location.
+*
+* Let A be a generic term for any 2D block cyclicly distributed array.
+* Such a global array has an associated description vector DESCA.
+* In the following comments, the character _ should be read as
+* "of the global array".
+*
+* NOTATION STORED IN EXPLANATION
+* --------------- -------------- --------------------------------------
+* DTYPE_A(global) DESCA( DTYPE_ )The descriptor type. In this case,
+* DTYPE_A = 1.
+* CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating
+* the BLACS process grid A is distribu-
+* ted over. The context itself is glo-
+* bal, but the handle (the integer
+* value) may vary.
+* M_A (global) DESCA( M_ ) The number of rows in the global
+* array A.
+* N_A (global) DESCA( N_ ) The number of columns in the global
+* array A.
+* MB_A (global) DESCA( MB_ ) The blocking factor used to distribute
+* the rows of the array.
+* NB_A (global) DESCA( NB_ ) The blocking factor used to distribute
+* the columns of the array.
+* RSRC_A (global) DESCA( RSRC_ ) The process row over which the first
+* row of the array A is distributed.
+* CSRC_A (global) DESCA( CSRC_ ) The process column over which the
+* first column of the array A is
+* distributed.
+* LLD_A (local) DESCA( LLD_ ) The leading dimension of the local
+* array. LLD_A >= MAX(1,LOCr(M_A)).
+*
+* Let K be the number of rows or columns of a distributed matrix,
+* and assume that its process grid has dimension p x q.
+* LOCr( K ) denotes the number of elements of K that a process
+* would receive if K were distributed over the p processes of its
+* process column.
+* Similarly, LOCc( K ) denotes the number of elements of K that a
+* process would receive if K were distributed over the q processes of
+* its process row.
+* The values of LOCr() and LOCc() may be determined via a call to the
+* ScaLAPACK tool function, NUMROC:
+* LOCr( M ) = NUMROC( M, MB_A, MYROW, RSRC_A, NPROW ),
+* LOCc( N ) = NUMROC( N, NB_A, MYCOL, CSRC_A, NPCOL ).
+* An upper bound for these quantities may be computed by:
+* LOCr( M ) <= ceil( ceil(M/MB_A)/NPROW )*MB_A
+* LOCc( N ) <= ceil( ceil(N/NB_A)/NPCOL )*NB_A
+*
+* PCHEEVR assumes IEEE 754 standard compliant arithmetic.
+*
+* Alignment requirements
+* ======================
+*
+* The distributed submatrices A(IA:*, JA:*) and Z(IZ:IZ+M-1,JZ:JZ+N-1)
+* must satisfy the following alignment properties:
+*
+* 1.Identical (quadratic) dimension:
+* DESCA(M_) = DESCZ(M_) = DESCA(N_) = DESCZ(N_)
+* 2.Quadratic conformal blocking:
+* DESCA(MB_) = DESCA(NB_) = DESCZ(MB_) = DESCZ(NB_)
+* DESCA(RSRC_) = DESCZ(RSRC_)
+* 3.MOD( IA-1, MB_A ) = MOD( IZ-1, MB_Z ) = 0
+* 4.IAROW = IZROW
+*
+*
+* .. Parameters ..
+ INTEGER CTXT_, M_, N_,
+ $ MB_, NB_, RSRC_, CSRC_
+ PARAMETER ( CTXT_ = 2, M_ = 3, N_ = 4, MB_ = 5, NB_ = 6,
+ $ RSRC_ = 7, CSRC_ = 8 )
+ REAL ZERO
+ PARAMETER ( ZERO = 0.0E0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL ALLEIG, COLBRT, DOBCST, FINISH, FIRST, INDEIG,
+ $ LOWER, LQUERY, VALEIG, VSTART, WANTZ
+ INTEGER ANB, DOL, DOU, DSTCOL, DSTROW, EIGCNT, FRSTCL,
+ $ I, IAROW, ICTXT, IIL, IINDERR, IINDWLC, IINFO,
+ $ IIU, IM, INDD, INDD2, INDE, INDE2, INDERR,
+ $ INDILU, INDRTAU, INDRW, INDRWORK, INDTAU,
+ $ INDWLC, INDWORK, IPIL, IPIU, IPROC, IZROW,
+ $ LASTCL, LENGTHI, LENGTHI2, LIWMIN, LLRWORK,
+ $ LLWORK, LRWMIN, LRWOPT, LWMIN, LWOPT, MAXCLS,
+ $ MQ00, MYCOL, MYIL, MYIU, MYPROC, MYROW, MZ, NB,
+ $ NDEPTH, NEEDIL, NEEDIU, NHETRD_LWOPT, NNP,
+ $ NP00, NPCOL, NPROCS, NPROW, NPS, NSPLIT,
+ $ OFFSET, PARITY, RLENGTHI, RLENGTHI2, RSTARTI,
+ $ SIZE1, SIZE2, SQNPC, SRCCOL, SRCROW, STARTI,
+ $ ZOFFSET
+
+ REAL PIVMIN, SAFMIN, SCALE, VLL, VUU, WL,
+ $ WU
+*
+* .. Local Arrays ..
+ INTEGER IDUM1( 4 ), IDUM2( 4 )
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ INTEGER ICEIL, INDXG2P, NUMROC, PJLAENV
+ REAL PSLAMCH
+ EXTERNAL ICEIL, INDXG2P, LSAME, NUMROC, PJLAENV,
+ $ PSLAMCH
+* ..
+* .. External Subroutines ..
+ EXTERNAL BLACS_GRIDINFO, CHK1MAT, IGEBR2D, IGEBS2D,
+ $ IGERV2D, IGESD2D, IGSUM2D, PCELGET, PCHENTRD,
+ $ PCHK1MAT, PCHK2MAT, PCLAEVSWP, PCUNMTR,
+ $ PSLARED1D, PXERBLA, SCOPY, SGEBR2D, SGEBS2D,
+ $ SGERV2D, SGESD2D, SLARRC, SLASRT2,
+ $ SSTEGR2A, SSTEGR2B, SSTEGR2
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, CMPLX, ICHAR, INT, MAX, MIN, MOD, REAL,
+ $ SQRT
+* ..
+* .. Executable Statements ..
+*
+
+ INFO = 0
+
+***********************************************************************
+*
+* Decode character arguments to find out what the code should do
+*
+***********************************************************************
+ WANTZ = LSAME( JOBZ, 'V' )
+ LOWER = LSAME( UPLO, 'L' )
+ ALLEIG = LSAME( RANGE, 'A' )
+ VALEIG = LSAME( RANGE, 'V' )
+ INDEIG = LSAME( RANGE, 'I' )
+ LQUERY = ( LWORK.EQ.-1 .OR. LRWORK.EQ.-1 .OR. LIWORK.EQ.-1 )
+
+***********************************************************************
+*
+* GET MACHINE PARAMETERS
+*
+***********************************************************************
+ ICTXT = DESCA( CTXT_ )
+ SAFMIN = PSLAMCH( ICTXT, 'Safe minimum' )
+
+***********************************************************************
+*
+* Set up pointers into the (complex) WORK array
+*
+***********************************************************************
+ INDTAU = 1
+ INDWORK = INDTAU + N
+ LLWORK = LWORK - INDWORK + 1
+
+***********************************************************************
+*
+* Set up pointers into the RWORK array
+*
+***********************************************************************
+ INDRTAU = 1
+ INDD = INDRTAU + N
+ INDE = INDD + N + 1
+ INDD2 = INDE + N + 1
+ INDE2 = INDD2 + N
+ INDRWORK = INDE2 + N
+ LLRWORK = LRWORK - INDRWORK + 1
+
+***********************************************************************
+*
+* BLACS PROCESSOR GRID SETUP
+*
+***********************************************************************
+ CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL )
+
+
+ NPROCS = NPROW * NPCOL
+ MYPROC = MYROW * NPCOL + MYCOL
+ IF( NPROW.EQ.-1 ) THEN
+ INFO = -( 800+CTXT_ )
+ ELSE IF( WANTZ ) THEN
+ IF( ICTXT.NE.DESCZ( CTXT_ ) ) THEN
+ INFO = -( 2100+CTXT_ )
+ END IF
+ END IF
+
+***********************************************************************
+*
+* COMPUTE REAL WORKSPACE
+*
+***********************************************************************
+ IF ( ALLEIG ) THEN
+ MZ = N
+ ELSE IF ( INDEIG ) THEN
+ MZ = IU - IL + 1
+ ELSE
+* Take upper bound for VALEIG case
+ MZ = N
+ END IF
+*
+ NB = DESCA( NB_ )
+ NP00 = NUMROC( N, NB, 0, 0, NPROW )
+ MQ00 = NUMROC( MZ, NB, 0, 0, NPCOL )
+ IF ( WANTZ ) THEN
+ INDRW = INDRWORK + MAX(18*N, NP00*MQ00 + 2*NB*NB)
+ LRWMIN = INDRW - 1 + (ICEIL(MZ, NPROCS) + 2)*N
+ LWMIN = N + MAX((NP00 + MQ00 + NB) * NB, 3 * NB)
+ ELSE
+ INDRW = INDRWORK + 12*N
+ LRWMIN = INDRW - 1
+ LWMIN = N + MAX( NB*( NP00 + 1 ), 3 * NB )
+ END IF
+
+* The code that validates the input requires 3 workspace entries
+ LRWMIN = MAX(3, LRWMIN)
+ LRWOPT = LRWMIN
+ LWMIN = MAX(3, LWMIN)
+ LWOPT = LWMIN
+*
+ ANB = PJLAENV( ICTXT, 3, 'PCHETTRD', 'L', 0, 0, 0, 0 )
+ SQNPC = INT( SQRT( REAL( NPROCS ) ) )
+ NPS = MAX( NUMROC( N, 1, 0, 0, SQNPC ), 2*ANB )
+ NHETRD_LWOPT = 2*( ANB+1 )*( 4*NPS+2 ) + ( NPS+4 )*NPS
+ LWOPT = MAX( LWOPT, N+NHETRD_LWOPT )
+*
+ SIZE1 = INDRW - INDRWORK
+
+***********************************************************************
+*
+* COMPUTE INTEGER WORKSPACE
+*
+***********************************************************************
+ NNP = MAX( N, NPROCS+1, 4 )
+ IF ( WANTZ ) THEN
+ LIWMIN = 12*NNP + 2*N
+ ELSE
+ LIWMIN = 10*NNP + 2*N
+ END IF
+
+***********************************************************************
+*
+* Set up pointers into the IWORK array
+*
+***********************************************************************
+* Pointer to eigenpair distribution over processors
+ INDILU = LIWMIN - 2*NPROCS + 1
+ SIZE2 = INDILU - 2*N
+
+
+***********************************************************************
+*
+* Test the input arguments.
+*
+***********************************************************************
+ IF( INFO.EQ.0 ) THEN
+ CALL CHK1MAT( N, 4, N, 4, IA, JA, DESCA, 8, INFO )
+ IF( WANTZ )
+ $ CALL CHK1MAT( N, 4, N, 4, IZ, JZ, DESCZ, 21, INFO )
+*
+ IF( INFO.EQ.0 ) THEN
+ 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( MOD( IA-1, DESCA( MB_ ) ).NE.0 ) THEN
+ INFO = -6
+ ELSE IF( VALEIG .AND. N.GT.0 .AND. VU.LE.VL ) THEN
+ INFO = -10
+ ELSE IF( INDEIG .AND. ( IL.LT.1 .OR. IL.GT.MAX( 1, N ) ) )
+ $ THEN
+ INFO = -11
+ ELSE IF( INDEIG .AND. ( IU.LT.MIN( N, IL ) .OR. IU.GT.N ))
+ $ THEN
+ INFO = -12
+ ELSE IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN
+ INFO = -21
+ ELSE IF( LRWORK.LT.LRWMIN .AND. .NOT.LQUERY ) THEN
+ INFO = -23
+ ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN
+ INFO = -25
+ ELSE IF( DESCA( MB_ ).NE.DESCA( NB_ ) ) THEN
+ INFO = -( 800+NB_ )
+ END IF
+ IF( WANTZ ) THEN
+ IAROW = INDXG2P( 1, DESCA( NB_ ), MYROW,
+ $ DESCA( RSRC_ ), NPROW )
+ IZROW = INDXG2P( 1, DESCA( NB_ ), MYROW,
+ $ DESCZ( RSRC_ ), NPROW )
+ IF( IAROW.NE.IZROW ) THEN
+ INFO = -19
+ ELSE IF( MOD( IA-1, DESCA( MB_ ) ).NE.
+ $ MOD( IZ-1, DESCZ( MB_ ) ) ) THEN
+ INFO = -19
+ ELSE IF( DESCA( M_ ).NE.DESCZ( M_ ) ) THEN
+ INFO = -( 2100+M_ )
+ ELSE IF( DESCA( N_ ).NE.DESCZ( N_ ) ) THEN
+ INFO = -( 2100+N_ )
+ ELSE IF( DESCA( MB_ ).NE.DESCZ( MB_ ) ) THEN
+ INFO = -( 2100+MB_ )
+ ELSE IF( DESCA( NB_ ).NE.DESCZ( NB_ ) ) THEN
+ INFO = -( 2100+NB_ )
+ ELSE IF( DESCA( RSRC_ ).NE.DESCZ( RSRC_ ) ) THEN
+ INFO = -( 2100+RSRC_ )
+ ELSE IF( DESCA( CSRC_ ).NE.DESCZ( CSRC_ ) ) THEN
+ INFO = -( 2100+CSRC_ )
+ ELSE IF( ICTXT.NE.DESCZ( CTXT_ ) ) THEN
+ INFO = -( 2100+CTXT_ )
+ END IF
+ END IF
+ END IF
+ IDUM2( 1 ) = 1
+ IF( LOWER ) THEN
+ IDUM1( 2 ) = ICHAR( 'L' )
+ ELSE
+ IDUM1( 2 ) = ICHAR( 'U' )
+ END IF
+ IDUM2( 2 ) = 2
+ IF( ALLEIG ) THEN
+ IDUM1( 3 ) = ICHAR( 'A' )
+ ELSE IF( INDEIG ) THEN
+ IDUM1( 3 ) = ICHAR( 'I' )
+ ELSE
+ IDUM1( 3 ) = ICHAR( 'V' )
+ END IF
+ IDUM2( 3 ) = 3
+ IF( LQUERY ) THEN
+ IDUM1( 4 ) = -1
+ ELSE
+ IDUM1( 4 ) = 1
+ END IF
+ IDUM2( 4 ) = 4
+ IF( WANTZ ) THEN
+ IDUM1( 1 ) = ICHAR( 'V' )
+ CALL PCHK2MAT( N, 4, N, 4, IA, JA, DESCA, 8, N, 4, N, 4,IZ,
+ $ JZ, DESCZ, 21, 4, IDUM1, IDUM2, INFO )
+ ELSE
+ IDUM1( 1 ) = ICHAR( 'N' )
+ CALL PCHK1MAT( N, 4, N, 4, IA, JA, DESCA, 8, 4, IDUM1,
+ $ IDUM2, INFO )
+ END IF
+ WORK( 1 ) = CMPLX( LWOPT )
+ RWORK( 1 ) = REAL( LRWOPT )
+ IWORK( 1 ) = LIWMIN
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL PXERBLA( ICTXT, 'PCHEEVR', -INFO )
+ RETURN
+ ELSE IF( LQUERY ) THEN
+ RETURN
+ END IF
+
+***********************************************************************
+*
+* Quick return if possible
+*
+***********************************************************************
+ IF( N.EQ.0 ) THEN
+ IF( WANTZ ) THEN
+ NZ = 0
+ END IF
+ M = 0
+ WORK( 1 ) = CMPLX( LWOPT )
+ RWORK( 1 ) = REAL( LRWOPT )
+ IWORK( 1 ) = LIWMIN
+ RETURN
+ END IF
+
+ IF( VALEIG ) THEN
+ VLL = VL
+ VUU = VU
+ ELSE
+ VLL = ZERO
+ VUU = ZERO
+ END IF
+*
+* No scaling done here, leave this to MRRR kernel.
+* Scale tridiagonal rather than full matrix.
+*
+***********************************************************************
+*
+* REDUCE MATRIX TO REAL SYMMETRIC TRIDIAGONAL FORM.
+*
+***********************************************************************
+
+
+ CALL PCHENTRD( UPLO, N, A, IA, JA, DESCA, RWORK( INDD ),
+ $ RWORK( INDE ), WORK( INDTAU ), WORK( INDWORK ),
+ $ LLWORK, RWORK( INDRWORK ), LLRWORK,IINFO )
+
+
+ IF (IINFO .NE. 0) THEN
+ CALL PXERBLA( ICTXT, 'PCHENTRD', -IINFO )
+ RETURN
+ END IF
+
+***********************************************************************
+*
+* DISTRIBUTE TRIDIAGONAL TO ALL PROCESSORS
+*
+***********************************************************************
+ OFFSET = 0
+ IF( IA.EQ.1 .AND. JA.EQ.1 .AND.
+ $ DESCA( RSRC_ ).EQ.0 .AND. DESCA( CSRC_ ).EQ.0 )
+ $ THEN
+ CALL PSLARED1D( N, IA, JA, DESCA, RWORK( INDD ),
+ $ RWORK( INDD2 ), RWORK( INDRWORK ), LLRWORK )
+*
+ CALL PSLARED1D( N, IA, JA, DESCA, RWORK( INDE ),
+ $ RWORK( INDE2 ), RWORK( INDRWORK ), LLRWORK )
+ IF( .NOT.LOWER )
+ $ OFFSET = 1
+ ELSE
+ DO 10 I = 1, N
+ CALL PCELGET( 'A', ' ', WORK( INDWORK ), A,
+ $ I+IA-1, I+JA-1, DESCA )
+ RWORK( INDD2+I-1 ) = REAL( WORK( INDWORK ) )
+ 10 CONTINUE
+ IF( LSAME( UPLO, 'U' ) ) THEN
+ DO 20 I = 1, N - 1
+ CALL PCELGET( 'A', ' ', WORK( INDWORK ), A,
+ $ I+IA-1, I+JA, DESCA )
+ RWORK( INDE2+I-1 ) = REAL( WORK( INDWORK ) )
+ 20 CONTINUE
+ ELSE
+ DO 30 I = 1, N - 1
+ CALL PCELGET( 'A', ' ', WORK( INDWORK ), A,
+ $ I+IA, I+JA-1, DESCA )
+ RWORK( INDE2+I-1 ) = REAL( WORK( INDWORK ) )
+ 30 CONTINUE
+ END IF
+ END IF
+
+
+
+
+***********************************************************************
+*
+* SET IIL, IIU
+*
+***********************************************************************
+ IF ( ALLEIG ) THEN
+ IIL = 1
+ IIU = N
+ ELSE IF ( INDEIG ) THEN
+ IIL = IL
+ IIU = IU
+ ELSE IF ( VALEIG ) THEN
+ CALL SLARRC('T', N, VLL, VUU, RWORK( INDD2 ),
+ $ RWORK( INDE2 + OFFSET ), SAFMIN, EIGCNT, IIL, IIU, INFO)
+* Refine upper bound N that was taken
+ MZ = EIGCNT
+ IIL = IIL + 1
+ ENDIF
+
+ IF(MZ.EQ.0) THEN
+ M = 0
+ IF( WANTZ ) THEN
+ NZ = 0
+ END IF
+ WORK( 1 ) = REAL( LWOPT )
+ IWORK( 1 ) = LIWMIN
+ RETURN
+ END IF
+
+ MYIL = 0
+ MYIU = 0
+ M = 0
+ IM = 0
+
+***********************************************************************
+*
+* COMPUTE WORK ASSIGNMENTS
+*
+***********************************************************************
+
+*
+* Each processor computes the work assignments for all processors
+*
+ CALL PMPIM2( IIL, IIU, NPROCS,
+ $ IWORK(INDILU), IWORK(INDILU+NPROCS) )
+*
+* Find local work assignment
+*
+ MYIL = IWORK(INDILU+MYPROC)
+ MYIU = IWORK(INDILU+NPROCS+MYPROC)
+
+
+ ZOFFSET = MAX(0, MYIL - IIL - 1)
+ FIRST = ( MYIL .EQ. IIL )
+
+
+***********************************************************************
+*
+* CALLS TO MRRR KERNEL
+*
+***********************************************************************
+ IF(.NOT.WANTZ) THEN
+*
+* Compute eigenvalues only.
+*
+ IINFO = 0
+ IF ( MYIL.GT.0 ) THEN
+ DOL = 1
+ DOU = MYIU - MYIL + 1
+ CALL SSTEGR2( JOBZ, 'I', N, RWORK( INDD2 ),
+ $ RWORK( INDE2+OFFSET ), VLL, VUU, MYIL, MYIU,
+ $ IM, W( 1 ), RWORK( INDRW ), N,
+ $ MYIU - MYIL + 1,
+ $ IWORK( 1 ), RWORK( INDRWORK ), SIZE1,
+ $ IWORK( 2*N+1 ), SIZE2,
+ $ DOL, DOU, ZOFFSET, IINFO )
+* SSTEGR2 zeroes out the entire W array, so we can't just give
+* it the part of W we need. So here we copy the W entries into
+* their correct location
+ DO 49 I = 1, IM
+ W( MYIL-IIL+I ) = W( I )
+ 49 CONTINUE
+* W( MYIL ) is at W( MYIL - IIL + 1 )
+* W( X ) is at W(X - IIL + 1 )
+ END IF
+ IF (IINFO .NE. 0) THEN
+ CALL PXERBLA( ICTXT, 'SSTEGR2', -IINFO )
+ RETURN
+ END IF
+ ELSEIF ( WANTZ .AND. NPROCS.EQ.1 ) THEN
+*
+* Compute eigenvalues and -vectors, but only on one processor
+*
+ IINFO = 0
+ IF ( MYIL.GT.0 ) THEN
+ DOL = MYIL - IIL + 1
+ DOU = MYIU - IIL + 1
+ CALL SSTEGR2( JOBZ, 'I', N, RWORK( INDD2 ),
+ $ RWORK( INDE2+OFFSET ), VLL, VUU, IIL, IIU,
+ $ IM, W( 1 ), RWORK( INDRW ), N,
+ $ N,
+ $ IWORK( 1 ), RWORK( INDRWORK ), SIZE1,
+ $ IWORK( 2*N+1 ), SIZE2, DOL, DOU,
+ $ ZOFFSET, IINFO )
+ ENDIF
+ IF (IINFO .NE. 0) THEN
+ CALL PXERBLA( ICTXT, 'SSTEGR2', -IINFO )
+ RETURN
+ END IF
+ ELSEIF ( WANTZ ) THEN
+* Compute representations in parallel.
+* Share eigenvalue computation for root between all processors
+* Then compute the eigenvectors.
+ IINFO = 0
+* Part 1. compute root representations and root eigenvalues
+ IF ( MYIL.GT.0 ) THEN
+ DOL = MYIL - IIL + 1
+ DOU = MYIU - IIL + 1
+ CALL SSTEGR2A( JOBZ, 'I', N, RWORK( INDD2 ),
+ $ RWORK( INDE2+OFFSET ), VLL, VUU, IIL, IIU,
+ $ IM, W( 1 ), RWORK( INDRW ), N,
+ $ N, RWORK( INDRWORK ), SIZE1,
+ $ IWORK( 2*N+1 ), SIZE2, DOL,
+ $ DOU, NEEDIL, NEEDIU,
+ $ INDERR, NSPLIT, PIVMIN, SCALE, WL, WU,
+ $ IINFO )
+ ENDIF
+ IF (IINFO .NE. 0) THEN
+ CALL PXERBLA( ICTXT, 'SSTEGR2A', -IINFO )
+ RETURN
+ END IF
+*
+* The second part of parallel MRRR, the representation tree
+* construction begins. Upon successful completion, the
+* eigenvectors have been computed. This is indicated by
+* the flag FINISH.
+*
+ VSTART = .TRUE.
+ FINISH = (MYIL.LE.0)
+C Part 2. Share eigenvalues and uncertainties between all processors
+ IINDERR = INDRWORK + INDERR - 1
+
+*
+
+
+*
+* There are currently two ways to communicate eigenvalue information
+* using the BLACS.
+* 1.) BROADCAST
+* 2.) POINT2POINT between collaborators (those processors working
+* jointly on a cluster.
+* For efficiency, BROADCAST has been disabled.
+* At a later stage, other more efficient communication algorithms
+* might be implemented, e. g. group or tree-based communication.
+
+ DOBCST = .FALSE.
+ IF(DOBCST) THEN
+* First gather everything on the first processor.
+* Then use BROADCAST-based communication
+ DO 45 I = 2, NPROCS
+ IF (MYPROC .EQ. (I - 1)) THEN
+ DSTROW = 0
+ DSTCOL = 0
+ STARTI = DOL
+ IWORK(1) = STARTI
+ IF(MYIL.GT.0) THEN
+ LENGTHI = MYIU - MYIL + 1
+ ELSE
+ LENGTHI = 0
+ ENDIF
+ IWORK(2) = LENGTHI
+ CALL IGESD2D( ICTXT, 2, 1, IWORK, 2,
+ $ DSTROW, DSTCOL )
+ IF (( STARTI.GE.1 ) .AND. ( LENGTHI.GE.1 )) THEN
+ LENGTHI2 = 2*LENGTHI
+* Copy eigenvalues into communication buffer
+ CALL SCOPY(LENGTHI,W( STARTI ),1,
+ $ RWORK( INDD ), 1)
+* Copy uncertainties into communication buffer
+ CALL SCOPY(LENGTHI,RWORK(IINDERR+STARTI-1),1,
+ $ RWORK( INDD+LENGTHI ), 1)
+* send buffer
+ CALL SGESD2D( ICTXT, LENGTHI2,
+ $ 1, RWORK( INDD ), LENGTHI2,
+ $ DSTROW, DSTCOL )
+ END IF
+ ELSE IF (MYPROC .EQ. 0) THEN
+ SRCROW = (I-1) / NPCOL
+ SRCCOL = MOD(I-1, NPCOL)
+ CALL IGERV2D( ICTXT, 2, 1, IWORK, 2,
+ $ SRCROW, SRCCOL )
+ STARTI = IWORK(1)
+ LENGTHI = IWORK(2)
+ IF (( STARTI.GE.1 ) .AND. ( LENGTHI.GE.1 )) THEN
+ LENGTHI2 = 2*LENGTHI
+* receive buffer
+ CALL SGERV2D( ICTXT, LENGTHI2, 1,
+ $ RWORK(INDD), LENGTHI2, SRCROW, SRCCOL )
+* copy eigenvalues from communication buffer
+ CALL SCOPY( LENGTHI, RWORK(INDD), 1,
+ $ W( STARTI ), 1)
+* copy uncertainties (errors) from communication buffer
+ CALL SCOPY(LENGTHI,RWORK(INDD+LENGTHI),1,
+ $ RWORK( IINDERR+STARTI-1 ), 1)
+ END IF
+ END IF
+ 45 CONTINUE
+ LENGTHI = IIU - IIL + 1
+ LENGTHI2 = LENGTHI * 2
+ IF (MYPROC .EQ. 0) THEN
+* Broadcast eigenvalues and errors to all processors
+ CALL SCOPY(LENGTHI,W ,1, RWORK( INDD ), 1)
+ CALL SCOPY(LENGTHI,RWORK( IINDERR ),1,
+ $ RWORK( INDD+LENGTHI ), 1)
+ CALL SGEBS2D( ICTXT, 'A', ' ', LENGTHI2, 1,
+ $ RWORK(INDD), LENGTHI2 )
+ ELSE
+ SRCROW = 0
+ SRCCOL = 0
+ CALL SGEBR2D( ICTXT, 'A', ' ', LENGTHI2, 1,
+ $ RWORK(INDD), LENGTHI2, SRCROW, SRCCOL )
+ CALL SCOPY( LENGTHI, RWORK(INDD), 1, W, 1)
+ CALL SCOPY(LENGTHI,RWORK(INDD+LENGTHI),1,
+ $ RWORK( IINDERR ), 1)
+ END IF
+ ELSE
+* Enable point2point communication between collaborators
+
+* Find collaborators of MYPROC
+ IF( (NPROCS.GT.1).AND.(MYIL.GT.0) ) THEN
+ CALL PMPCOL( MYPROC, NPROCS, IIL, NEEDIL, NEEDIU,
+ $ IWORK(INDILU), IWORK(INDILU+NPROCS),
+ $ COLBRT, FRSTCL, LASTCL )
+ ELSE
+ COLBRT = .FALSE.
+ ENDIF
+
+ IF(COLBRT) THEN
+* If the processor collaborates with others,
+* communicate information.
+ DO 47 IPROC = FRSTCL, LASTCL
+ IF (MYPROC .EQ. IPROC) THEN
+ STARTI = DOL
+ IWORK(1) = STARTI
+ LENGTHI = MYIU - MYIL + 1
+ IWORK(2) = LENGTHI
+
+ IF ((STARTI.GE.1) .AND. (LENGTHI.GE.1)) THEN
+* Copy eigenvalues into communication buffer
+ CALL SCOPY(LENGTHI,W( STARTI ),1,
+ $ RWORK(INDD), 1)
+* Copy uncertainties into communication buffer
+ CALL SCOPY(LENGTHI,
+ $ RWORK( IINDERR+STARTI-1 ),1,
+ $ RWORK(INDD+LENGTHI), 1)
+ ENDIF
+
+ DO 46 I = FRSTCL, LASTCL
+ IF(I.EQ.MYPROC) GOTO 46
+ DSTROW = I/ NPCOL
+ DSTCOL = MOD(I, NPCOL)
+ CALL IGESD2D( ICTXT, 2, 1, IWORK, 2,
+ $ DSTROW, DSTCOL )
+ IF ((STARTI.GE.1) .AND. (LENGTHI.GE.1)) THEN
+ LENGTHI2 = 2*LENGTHI
+* send buffer
+ CALL SGESD2D( ICTXT, LENGTHI2,
+ $ 1, RWORK(INDD), LENGTHI2,
+ $ DSTROW, DSTCOL )
+ END IF
+ 46 CONTINUE
+ ELSE
+ SRCROW = IPROC / NPCOL
+ SRCCOL = MOD(IPROC, NPCOL)
+ CALL IGERV2D( ICTXT, 2, 1, IWORK, 2,
+ $ SRCROW, SRCCOL )
+ RSTARTI = IWORK(1)
+ RLENGTHI = IWORK(2)
+ IF ((RSTARTI.GE.1 ) .AND. (RLENGTHI.GE.1 )) THEN
+ RLENGTHI2 = 2*RLENGTHI
+ CALL SGERV2D( ICTXT, RLENGTHI2, 1,
+ $ RWORK(INDE), RLENGTHI2,
+ $ SRCROW, SRCCOL )
+* copy eigenvalues from communication buffer
+ CALL SCOPY( RLENGTHI,RWORK(INDE), 1,
+ $ W( RSTARTI ), 1)
+* copy uncertainties (errors) from communication buffer
+ CALL SCOPY(RLENGTHI,RWORK(INDE+RLENGTHI),1,
+ $ RWORK( IINDERR+RSTARTI-1 ), 1)
+ END IF
+ END IF
+ 47 CONTINUE
+ ENDIF
+ ENDIF
+
+* Part 3. Compute representation tree and eigenvectors.
+* What follows is a loop in which the tree
+* is constructed in parallel from top to bottom,
+* on level at a time, until all eigenvectors
+* have been computed.
+*
+ 100 CONTINUE
+ IF ( MYIL.GT.0 ) THEN
+ CALL SSTEGR2B( JOBZ, N, RWORK( INDD2 ),
+ $ RWORK( INDE2+OFFSET ),
+ $ IM, W( 1 ), RWORK( INDRW ), N, N,
+ $ IWORK( 1 ), RWORK( INDRWORK ), SIZE1,
+ $ IWORK( 2*N+1 ), SIZE2, DOL,
+ $ DOU, NEEDIL, NEEDIU, INDWLC,
+ $ PIVMIN, SCALE, WL, WU,
+ $ VSTART, FINISH,
+ $ MAXCLS, NDEPTH, PARITY, ZOFFSET, IINFO )
+ IINDWLC = INDRWORK + INDWLC - 1
+ IF(.NOT.FINISH) THEN
+ IF((NEEDIL.LT.DOL).OR.(NEEDIU.GT.DOU)) THEN
+ CALL PMPCOL( MYPROC, NPROCS, IIL, NEEDIL, NEEDIU,
+ $ IWORK(INDILU), IWORK(INDILU+NPROCS),
+ $ COLBRT, FRSTCL, LASTCL )
+ ELSE
+ COLBRT = .FALSE.
+ FRSTCL = MYPROC
+ LASTCL = MYPROC
+ ENDIF
+*
+* Check if this processor collaborates, i.e.
+* communication is needed.
+*
+ IF(COLBRT) THEN
+ DO 147 IPROC = FRSTCL, LASTCL
+ IF (MYPROC .EQ. IPROC) THEN
+ STARTI = DOL
+ IWORK(1) = STARTI
+ IF(MYIL.GT.0) THEN
+ LENGTHI = MYIU - MYIL + 1
+ ELSE
+ LENGTHI = 0
+ ENDIF
+ IWORK(2) = LENGTHI
+ IF ((STARTI.GE.1).AND.(LENGTHI.GE.1)) THEN
+* Copy eigenvalues into communication buffer
+ CALL SCOPY(LENGTHI,
+ $ RWORK( IINDWLC+STARTI-1 ),1,
+ $ RWORK(INDD), 1)
+* Copy uncertainties into communication buffer
+ CALL SCOPY(LENGTHI,
+ $ RWORK( IINDERR+STARTI-1 ),1,
+ $ RWORK(INDD+LENGTHI), 1)
+ ENDIF
+
+ DO 146 I = FRSTCL, LASTCL
+ IF(I.EQ.MYPROC) GOTO 146
+ DSTROW = I/ NPCOL
+ DSTCOL = MOD(I, NPCOL)
+ CALL IGESD2D( ICTXT, 2, 1, IWORK, 2,
+ $ DSTROW, DSTCOL )
+ IF ((STARTI.GE.1).AND.(LENGTHI.GE.1)) THEN
+ LENGTHI2 = 2*LENGTHI
+* send buffer
+ CALL SGESD2D( ICTXT, LENGTHI2,
+ $ 1, RWORK(INDD), LENGTHI2,
+ $ DSTROW, DSTCOL )
+ END IF
+ 146 CONTINUE
+ ELSE
+ SRCROW = IPROC / NPCOL
+ SRCCOL = MOD(IPROC, NPCOL)
+ CALL IGERV2D( ICTXT, 2, 1, IWORK, 2,
+ $ SRCROW, SRCCOL )
+ RSTARTI = IWORK(1)
+ RLENGTHI = IWORK(2)
+ IF ((RSTARTI.GE.1).AND.(RLENGTHI.GE.1)) THEN
+ RLENGTHI2 = 2*RLENGTHI
+ CALL SGERV2D( ICTXT,RLENGTHI2, 1,
+ $ RWORK(INDE),RLENGTHI2,
+ $ SRCROW, SRCCOL )
+* copy eigenvalues from communication buffer
+ CALL SCOPY(RLENGTHI,RWORK(INDE), 1,
+ $ RWORK( IINDWLC+RSTARTI-1 ), 1)
+* copy uncertainties (errors) from communication buffer
+ CALL SCOPY(RLENGTHI,RWORK(INDE+RLENGTHI),
+ $ 1,RWORK( IINDERR+RSTARTI-1 ), 1)
+ END IF
+ END IF
+ 147 CONTINUE
+ ENDIF
+ GOTO 100
+ ENDIF
+ ENDIF
+ IF (IINFO .NE. 0) THEN
+ CALL PXERBLA( ICTXT, 'SSTEGR2B', -IINFO )
+ RETURN
+ END IF
+*
+ ENDIF
+
+*
+***********************************************************************
+*
+* MAIN PART ENDS HERE
+*
+***********************************************************************
+*
+
+***********************************************************************
+*
+* ALLGATHER: EACH PROCESSOR SENDS ITS EIGENVALUES TO THE FIRST ONE,
+* THEN THE FIRST PROCESSOR BROADCASTS ALL EIGENVALUES
+*
+***********************************************************************
+
+ DO 50 I = 2, NPROCS
+ IF (MYPROC .EQ. (I - 1)) THEN
+ DSTROW = 0
+ DSTCOL = 0
+ STARTI = MYIL - IIL + 1
+ IWORK(1) = STARTI
+ IF(MYIL.GT.0) THEN
+ LENGTHI = MYIU - MYIL + 1
+ ELSE
+ LENGTHI = 0
+ ENDIF
+ IWORK(2) = LENGTHI
+ CALL IGESD2D( ICTXT, 2, 1, IWORK, 2,
+ $ DSTROW, DSTCOL )
+ IF ((STARTI.GE.1).AND.(LENGTHI.GE.1)) THEN
+ CALL SGESD2D( ICTXT, LENGTHI,
+ $ 1, W( STARTI ), LENGTHI,
+ $ DSTROW, DSTCOL )
+ ENDIF
+ ELSE IF (MYPROC .EQ. 0) THEN
+ SRCROW = (I-1) / NPCOL
+ SRCCOL = MOD(I-1, NPCOL)
+ CALL IGERV2D( ICTXT, 2, 1, IWORK, 2,
+ $ SRCROW, SRCCOL )
+ STARTI = IWORK(1)
+ LENGTHI = IWORK(2)
+ IF ((STARTI.GE.1).AND.(LENGTHI.GE.1)) THEN
+ CALL SGERV2D( ICTXT, LENGTHI, 1,
+ $ W( STARTI ), LENGTHI, SRCROW, SRCCOL )
+ ENDIF
+ ENDIF
+ 50 CONTINUE
+
+* Accumulate M from all processors
+ M = IM
+ CALL IGSUM2D( ICTXT, 'A', ' ', 1, 1, M, 1, -1, -1 )
+
+* Broadcast eigenvalues to all processors
+ IF (MYPROC .EQ. 0) THEN
+* Send eigenvalues
+ CALL SGEBS2D( ICTXT, 'A', ' ', M, 1, W, M )
+ ELSE
+ SRCROW = 0
+ SRCCOL = 0
+ CALL SGEBR2D( ICTXT, 'A', ' ', M, 1,
+ $ W, M, SRCROW, SRCCOL )
+ END IF
+*
+* Sort the eigenvalues and keep permutation in IWORK to
+* sort the eigenvectors accordingly
+*
+ DO 160 I = 1, M
+ IWORK( NPROCS+1+I ) = I
+ 160 CONTINUE
+ CALL SLASRT2( 'I', M, W, IWORK( NPROCS+2 ), IINFO )
+ IF (IINFO.NE.0) THEN
+ CALL PXERBLA( ICTXT, 'SLASRT2', -IINFO )
+ RETURN
+ END IF
+
+***********************************************************************
+*
+* TRANSFORM Z FROM 1D WORKSPACE INTO 2D BLOCKCYCLIC STORAGE
+*
+***********************************************************************
+ IF ( WANTZ ) THEN
+ DO 170 I = 1, M
+ IWORK( M+NPROCS+1+IWORK( NPROCS+1+I ) ) = I
+ 170 CONTINUE
+* Store NVS in IWORK(1:NPROCS+1) for PCLAEVSWP
+ IWORK( 1 ) = 0
+ DO 180 I = 1, NPROCS
+* Find IL and IU for processor i-1
+* Has already been computed by PMPIM2 and stored
+ IPIL = IWORK(INDILU+I-1)
+ IPIU = IWORK(INDILU+NPROCS+I-1)
+ IF (IPIL .EQ. 0) THEN
+ IWORK( I + 1 ) = IWORK( I )
+ ELSE
+ IWORK( I + 1 ) = IWORK( I ) + IPIU - IPIL + 1
+ ENDIF
+ 180 CONTINUE
+
+ IF ( FIRST ) THEN
+ CALL PCLAEVSWP(N, RWORK( INDRW ), N, Z, IZ, JZ,
+ $ DESCZ, IWORK( 1 ), IWORK( NPROCS+M+2 ), RWORK( INDRWORK ),
+ $ SIZE1 )
+ ELSE
+ CALL PCLAEVSWP(N, RWORK( INDRW + N ), N, Z, IZ, JZ,
+ $ DESCZ, IWORK( 1 ), IWORK( NPROCS+M+2 ), RWORK( INDRWORK ),
+ $ SIZE1 )
+ END IF
+*
+ NZ = M
+*
+
+***********************************************************************
+*
+* Compute eigenvectors of A from eigenvectors of T
+*
+***********************************************************************
+ IF( NZ.GT.0 ) THEN
+ CALL PCUNMTR( 'L', UPLO, 'N', N, NZ, A, IA, JA, DESCA,
+ $ WORK( INDTAU ), Z, IZ, JZ, DESCZ,
+ $ WORK( INDWORK ), LLWORK, IINFO )
+ END IF
+ IF (IINFO.NE.0) THEN
+ CALL PXERBLA( ICTXT, 'PCUNMTR', -IINFO )
+ RETURN
+ END IF
+*
+
+ END IF
+*
+ WORK( 1 ) = CMPLX( LWOPT )
+ RWORK( 1 ) = REAL( LRWOPT )
+ IWORK( 1 ) = LIWMIN
+
+ RETURN
+*
+* End of PCHEEVR
+*
+ END
diff --git a/SRC/pcheevx.f b/SRC/pcheevx.f
index 6846916..3de0547 100644
--- a/SRC/pcheevx.f
+++ b/SRC/pcheevx.f
@@ -607,6 +607,9 @@
RSRC_Z = DESCZ( RSRC_ )
IROFFZ = MOD( IZ-1, MB_A )
IZROW = INDXG2P( 1, NB_A, MYROW, RSRC_Z, NPROW )
+ ELSE
+ IROFFZ = 0
+ IZROW = 0
END IF
*
IF( ( .NOT.WANTZ ) .OR. ( VALEIG .AND. ( .NOT.LQUERY ) ) )
diff --git a/SRC/pchettrd.f b/SRC/pchettrd.f
index 1740f0e..c3870c8 100644
--- a/SRC/pchettrd.f
+++ b/SRC/pchettrd.f
@@ -1,10 +1,9 @@
SUBROUTINE PCHETTRD( UPLO, N, A, IA, JA, DESCA, D, E, TAU, WORK,
$ LWORK, INFO )
*
-* -- ScaLAPACK routine (version 1.7) --
-* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
-* and University of California, Berkeley.
-* October 15, 1999
+* -- ScaLAPACK routine (version 2.0.2) --
+* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver
+* May 1 2012
*
* .. Scalar Arguments ..
CHARACTER UPLO
@@ -443,7 +442,7 @@
* ..
* .. External Subroutines ..
EXTERNAL BLACS_GRIDINFO, CGEBR2D, CGEBS2D, CGEMM, CGEMV,
- $ CGERV2D, CGESD2D, CGSUM2D, CHK1MAT, CLACPY,
+ $ CGERV2D, CGESD2D, CGSUM2D, CHK1MAT, CLAMOV,
$ CSCAL, CTRMVT, PCHK1MAT, PSTREECOMB, PXERBLA,
$ SCOMBNRM2, SGEBR2D, SGEBS2D, SGSUM2D
* ..
@@ -1132,10 +1131,10 @@
IF( INTERLEAVE ) THEN
LDZG = LDV / 2
ELSE
- CALL CLACPY( 'A', LTNM1, ANB, WORK( INHT+LIJP1-1 ),
+ CALL CLAMOV( 'A', LTNM1, ANB, WORK( INHT+LIJP1-1 ),
$ LDV, WORK( INVT+LIJP1-1+ANB*LDV ), LDV )
*
- CALL CLACPY( 'A', LTNM1, ANB, WORK( INV+LTLIP1-1 ),
+ CALL CLAMOV( 'A', LTNM1, ANB, WORK( INV+LTLIP1-1 ),
$ LDV, WORK( INH+LTLIP1-1+ANB*LDV ), LDV )
LDZG = LDV
END IF
diff --git a/SRC/pclacp2.f b/SRC/pclacp2.f
index 89220da..7265ea2 100644
--- a/SRC/pclacp2.f
+++ b/SRC/pclacp2.f
@@ -1,10 +1,9 @@
SUBROUTINE PCLACP2( UPLO, M, N, A, IA, JA, DESCA, B, IB, JB,
$ DESCB )
*
-* -- ScaLAPACK auxiliary routine (version 1.7) --
-* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
-* and University of California, Berkeley.
-* November 15, 1997
+* -- ScaLAPACK auxiliary routine (version 2.0.2) --
+* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver
+* May 1 2012
*
* .. Scalar Arguments ..
CHARACTER UPLO
@@ -157,7 +156,7 @@
$ NQ, NQAA, WIDE
* ..
* .. External Subroutines ..
- EXTERNAL BLACS_GRIDINFO, CLACPY, INFOG2L
+ EXTERNAL BLACS_GRIDINFO, CLAMOV, INFOG2L
* ..
* .. External Functions ..
LOGICAL LSAME
@@ -247,7 +246,7 @@
*
10 CONTINUE
IF( ( N-ITOP ).GT.0 ) THEN
- CALL CLACPY( UPLO, IINXTA-IIBEGA+1, N-ITOP,
+ CALL CLAMOV( UPLO, IINXTA-IIBEGA+1, N-ITOP,
$ A( IIBEGA+(JJA+ITOP-1)*LDA ), LDA,
$ B( IIBEGB+(JJB+ITOP-1)*LDB ), LDB )
MYDIST = MYDIST + NPROW
@@ -272,10 +271,10 @@
20 CONTINUE
IF( JJAA.LE.( JJA+N-1 ) ) THEN
HEIGHT = IBASE - ITOP
- CALL CLACPY( 'All', MPAA, ITOP-JJAA+JJA,
+ CALL CLAMOV( 'All', MPAA, ITOP-JJAA+JJA,
$ A( IIAA+(JJAA-1)*LDA ), LDA,
$ B( IIBB+(JJBB-1)*LDB ), LDB )
- CALL CLACPY( UPLO, MPAA, HEIGHT,
+ CALL CLAMOV( UPLO, MPAA, HEIGHT,
$ A( IIAA+(JJA+ITOP-1)*LDA ), LDA,
$ B( IIBB+(JJB+ITOP-1)*LDB ), LDB )
MPAA = MAX( 0, MPAA - HEIGHT )
@@ -292,7 +291,7 @@
*
ELSE
*
- CALL CLACPY( 'All', MP, N, A( IIA+(JJA-1)*LDA ),
+ CALL CLAMOV( 'All', MP, N, A( IIA+(JJA-1)*LDA ),
$ LDA, B( IIB+(JJB-1)*LDB ), LDB )
*
END IF
@@ -345,7 +344,7 @@
*
30 CONTINUE
IF( ( M-ILEFT ).GT.0 ) THEN
- CALL CLACPY( UPLO, M-ILEFT, JJNXTA-JJBEGA+1,
+ CALL CLAMOV( UPLO, M-ILEFT, JJNXTA-JJBEGA+1,
$ A( IIA+ILEFT+(JJBEGA-1)*LDA ), LDA,
$ B( IIB+ILEFT+(JJBEGB-1)*LDB ), LDB )
MYDIST = MYDIST + NPCOL
@@ -370,10 +369,10 @@
40 CONTINUE
IF( IIAA.LE.( IIA+M-1 ) ) THEN
WIDE = IRIGHT - ILEFT
- CALL CLACPY( 'All', ILEFT-IIAA+IIA, NQAA,
+ CALL CLAMOV( 'All', ILEFT-IIAA+IIA, NQAA,
$ A( IIAA+(JJAA-1)*LDA ), LDA,
$ B( IIBB+(JJBB-1)*LDB ), LDB )
- CALL CLACPY( UPLO, WIDE, NQAA,
+ CALL CLAMOV( UPLO, WIDE, NQAA,
$ A( IIA+ILEFT+(JJAA-1)*LDA ), LDA,
$ B( IIB+ILEFT+(JJBB-1)*LDB ), LDB )
NQAA = MAX( 0, NQAA - WIDE )
@@ -390,7 +389,7 @@
*
ELSE
*
- CALL CLACPY( 'All', M, NQ, A( IIA+(JJA-1)*LDA ),
+ CALL CLAMOV( 'All', M, NQ, A( IIA+(JJA-1)*LDA ),
$ LDA, B( IIB+(JJB-1)*LDB ), LDB )
*
END IF
diff --git a/SRC/pclarfb.f b/SRC/pclarfb.f
index 7930ee2..4c11f35 100644
--- a/SRC/pclarfb.f
+++ b/SRC/pclarfb.f
@@ -1,10 +1,9 @@
SUBROUTINE PCLARFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, V, IV,
$ JV, DESCV, T, C, IC, JC, DESCC, WORK )
*
-* -- ScaLAPACK auxiliary routine (version 1.7) --
-* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
-* and University of California, Berkeley.
-* May 1, 1997
+* -- ScaLAPACK auxiliary routine (version 2.0.2) --
+* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver
+* May 1 2012
*
* .. Scalar Arguments ..
CHARACTER SIDE, TRANS, DIRECT, STOREV
@@ -237,7 +236,7 @@
* ..
* .. External Subroutines ..
EXTERNAL BLACS_GRIDINFO, CGEBR2D, CGEBS2D,CGEMM,
- $ CGSUM2D, CLACPY, CLASET, CTRBR2D,
+ $ CGSUM2D, CLAMOV, CLASET, CTRBR2D,
$ CTRBS2D, CTRMM, INFOG1L, INFOG2L, PB_TOPGET,
$ PBCTRAN
* ..
@@ -325,7 +324,7 @@
IF( MYROW.EQ.IVROW )
$ CALL CTRBS2D( ICTXT, 'Rowwise', ROWBTOP, UPLO,
$ 'Non unit', K, K, T, NBV )
- CALL CLACPY( 'All', MPC, K, V( IOFFV ), LDV, WORK( IPV ),
+ CALL CLAMOV( 'All', MPC, K, V( IOFFV ), LDV, WORK( IPV ),
$ LV )
ELSE
CALL CGEBR2D( ICTXT, 'Rowwise', ROWBTOP, MPC, K,
@@ -462,11 +461,11 @@
CALL CLASET( 'All', IROFFV, K, ZERO, ZERO,
$ WORK( IPW ), LW )
IPW1 = IPW + IROFFV
- CALL CLACPY( 'All', NPV, K, V( IOFFV ), LDV,
+ CALL CLAMOV( 'All', NPV, K, V( IOFFV ), LDV,
$ WORK( IPW1 ), LW )
ELSE
IPW1 = IPW
- CALL CLACPY( 'All', NPV, K, V( IOFFV ), LDV,
+ CALL CLAMOV( 'All', NPV, K, V( IOFFV ), LDV,
$ WORK( IPW1 ), LW )
END IF
*
@@ -626,11 +625,11 @@
CALL CLASET( 'All', K, ICOFFV, ZERO, ZERO,
$ WORK( IPW ), LW )
IPW1 = IPW + ICOFFV * LW
- CALL CLACPY( 'All', K, MQV, V( IOFFV ), LDV,
+ CALL CLAMOV( 'All', K, MQV, V( IOFFV ), LDV,
$ WORK( IPW1 ), LW )
ELSE
IPW1 = IPW
- CALL CLACPY( 'All', K, MQV, V( IOFFV ), LDV,
+ CALL CLAMOV( 'All', K, MQV, V( IOFFV ), LDV,
$ WORK( IPW1 ), LW )
END IF
*
@@ -775,7 +774,7 @@
IF( MYCOL.EQ.IVCOL )
$ CALL CTRBS2D( ICTXT, 'Columnwise', COLBTOP, UPLO,
$ 'Non unit', K, K, T, MBV )
- CALL CLACPY( 'All', K, NQC, V( IOFFV ), LDV, WORK( IPV ),
+ CALL CLAMOV( 'All', K, NQC, V( IOFFV ), LDV, WORK( IPV ),
$ LV )
ELSE
CALL CGEBR2D( ICTXT, 'Columnwise', COLBTOP, K, NQC,
diff --git a/SRC/pclarzb.f b/SRC/pclarzb.f
index 58117b3..d67a903 100644
--- a/SRC/pclarzb.f
+++ b/SRC/pclarzb.f
@@ -1,10 +1,9 @@
SUBROUTINE PCLARZB( SIDE, TRANS, DIRECT, STOREV, M, N, K, L, V,
$ IV, JV, DESCV, T, C, IC, JC, DESCC, WORK )
*
-* -- ScaLAPACK auxiliary routine (version 1.7) --
-* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
-* and University of California, Berkeley.
-* March 14, 2000
+* -- ScaLAPACK auxiliary routine (version 2.0.2) --
+* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver
+* May 1 2012
*
* .. Scalar Arguments ..
CHARACTER DIRECT, SIDE, STOREV, TRANS
@@ -243,7 +242,7 @@
* .. External Subroutines ..
EXTERNAL BLACS_ABORT, BLACS_GRIDINFO, CGEBR2D,
$ CGEBS2D, CGEMM, CGSUM2D, CLACGV,
- $ CLACPY, CLASET, CTRBR2D, CTRBS2D,
+ $ CLAMOV, CLASET, CTRBR2D, CTRBS2D,
$ CTRMM, INFOG2L, PBCMATADD, PBCTRAN,
$ PB_TOPGET, PXERBLA
* ..
@@ -381,10 +380,10 @@
*
IF( MYROW.EQ.IVROW ) THEN
IF( MYCOL.EQ.IVCOL ) THEN
- CALL CLACPY( 'All', K, MQV, V( IOFFV ), LDV,
+ CALL CLAMOV( 'All', K, MQV, V( IOFFV ), LDV,
$ WORK( IPW+ICOFFV*LW ), LW )
ELSE
- CALL CLACPY( 'All', K, MQV, V( IOFFV ), LDV,
+ CALL CLAMOV( 'All', K, MQV, V( IOFFV ), LDV,
$ WORK( IPW ), LW )
END IF
END IF
@@ -517,7 +516,7 @@
IF( MYCOL.EQ.IVCOL )
$ CALL CTRBS2D( ICTXT, 'Columnwise', COLBTOP, 'Lower',
$ 'Non unit', K, K, T, MBV )
- CALL CLACPY( 'All', K, NQC2, V( IOFFV ), LDV, WORK( IPV ),
+ CALL CLAMOV( 'All', K, NQC2, V( IOFFV ), LDV, WORK( IPV ),
$ LV )
ELSE
CALL CGEBR2D( ICTXT, 'Columnwise', COLBTOP, K, NQC2,
diff --git a/SRC/pclascl.f b/SRC/pclascl.f
index 3cc5fbf..9b167b8 100644
--- a/SRC/pclascl.f
+++ b/SRC/pclascl.f
@@ -153,10 +153,10 @@
EXTERNAL BLACS_GRIDINFO, CHK1MAT, INFOG2L, PXERBLA
* ..
* .. External Functions ..
- LOGICAL LSAME
+ LOGICAL LSAME, SISNAN
INTEGER ICEIL, NUMROC
REAL PSLAMCH
- EXTERNAL ICEIL, LSAME, NUMROC, PSLAMCH
+ EXTERNAL SISNAN, ICEIL, LSAME, NUMROC, PSLAMCH
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MIN, MOD
@@ -189,8 +189,10 @@
END IF
IF( ITYPE.EQ.-1 ) THEN
INFO = -1
- ELSE IF( CFROM.EQ.ZERO ) THEN
+ ELSE IF( CFROM.EQ.ZERO .OR. SISNAN(CFROM) ) THEN
INFO = -4
+ ELSE IF( SISNAN(CTO) ) THEN
+ INFO = -5
END IF
END IF
END IF
@@ -230,18 +232,32 @@
*
10 CONTINUE
CFROM1 = CFROMC*SMLNUM
- CTO1 = CTOC / BIGNUM
- IF( ABS( CFROM1 ).GT.ABS( CTOC ) .AND. CTOC.NE.ZERO ) THEN
- MUL = SMLNUM
- DONE = .FALSE.
- CFROMC = CFROM1
- ELSE IF( ABS( CTO1 ).GT.ABS( CFROMC ) ) THEN
- MUL = BIGNUM
- DONE = .FALSE.
- CTOC = CTO1
- ELSE
+ 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
*
IOFFA = ( JJA - 1 ) * LDA
diff --git a/SRC/pcpbtrf.f b/SRC/pcpbtrf.f
index 667d0aa..2c85781 100644
--- a/SRC/pcpbtrf.f
+++ b/SRC/pcpbtrf.f
@@ -1,12 +1,9 @@
SUBROUTINE PCPBTRF( UPLO, N, BW, A, JA, DESCA, AF, LAF, WORK,
$ LWORK, INFO )
*
-*
-*
-* -- ScaLAPACK routine (version 1.7) --
-* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
-* and University of California, Berkeley.
-* May 25, 2001
+* -- ScaLAPACK routine (version 2.0.2) --
+* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver
+* May 1 2012
*
* .. Scalar Arguments ..
CHARACTER UPLO
@@ -382,7 +379,7 @@
* ..
* .. External Subroutines ..
EXTERNAL BLACS_GET, BLACS_GRIDEXIT, BLACS_GRIDINFO,
- $ CAXPY, CGEMM, CGERV2D, CGESD2D, CLACPY,
+ $ CAXPY, CGEMM, CGERV2D, CGESD2D, CLAMOV,
$ CLATCPY, CPBTRF, CPOTRF, CSYRK, CTBTRS, CTRMM,
$ CTRRV2D, CTRSD2D, CTRSM, CTRTRS, DESC_CONVERT,
$ GLOBCHK, PXERBLA, RESHAPE
@@ -878,7 +875,7 @@
* Copy last diagonal block into AF storage for subsequent
* operations.
*
- CALL CLACPY( 'N', BW, BW,
+ CALL CLAMOV( 'N', BW, BW,
$ A( OFST+ODD_SIZE*LLDA+1 ),
$ LLDA-1, AF( ODD_SIZE*BW+MBW2+1 ),
$ BW )
@@ -965,7 +962,7 @@
* Move block into place that it will be expected to be for
* calcs.
*
- CALL CLACPY( 'N', BW, BW, AF( ODD_SIZE*BW+1 ), BW,
+ CALL CLAMOV( 'N', BW, BW, AF( ODD_SIZE*BW+1 ), BW,
$ AF( ODD_SIZE*BW+2*MBW2+1 ), BW )
*
ELSE
@@ -1124,7 +1121,7 @@
*
* Move the connection block in preparation.
*
- CALL CLACPY( 'L', BW, BW, A( ( OFST+1+ODD_SIZE*LLDA ) ),
+ CALL CLAMOV( 'L', BW, BW, A( ( OFST+1+ODD_SIZE*LLDA ) ),
$ LLDA-1, AF( ODD_SIZE*BW+2*MBW2+1+BW-BW ), BW )
*
*
@@ -1136,7 +1133,7 @@
*
* Move the resulting block back to its location in main storage.
*
- CALL CLACPY( 'L', BW, BW, AF( ODD_SIZE*BW+2*MBW2+1+BW-BW ),
+ CALL CLAMOV( 'L', BW, BW, AF( ODD_SIZE*BW+2*MBW2+1+BW-BW ),
$ BW, A(( OFST+1+ODD_SIZE*LLDA )), LLDA-1 )
*
*
@@ -1353,7 +1350,7 @@
* Move block into place that it will be expected to be for
* calcs.
*
- CALL CLACPY( 'N', BW, BW, AF( ODD_SIZE*BW+1 ), BW,
+ CALL CLAMOV( 'N', BW, BW, AF( ODD_SIZE*BW+1 ), BW,
$ AF( ODD_SIZE*BW+2*MBW2+1 ), BW )
*
ELSE
diff --git a/SRC/pcpbtrsv.f b/SRC/pcpbtrsv.f
index 2b36510..2ec2835 100644
--- a/SRC/pcpbtrsv.f
+++ b/SRC/pcpbtrsv.f
@@ -1,12 +1,9 @@
SUBROUTINE PCPBTRSV( UPLO, TRANS, N, BW, NRHS, A, JA, DESCA, B,
$ IB, DESCB, AF, LAF, WORK, LWORK, INFO )
*
-*
-*
-* -- ScaLAPACK routine (version 1.7) --
-* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
-* and University of California, Berkeley.
-* November 15, 1997
+* -- ScaLAPACK routine (version 2.0.2) --
+* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver
+* May 1 2012
*
* .. Scalar Arguments ..
CHARACTER TRANS, UPLO
@@ -400,7 +397,7 @@
* ..
* .. External Subroutines ..
EXTERNAL BLACS_GET, BLACS_GRIDEXIT, BLACS_GRIDINFO,
- $ CGEMM, CGERV2D, CGESD2D, CLACPY, CMATADD,
+ $ CGEMM, CGERV2D, CGESD2D, CLAMOV, CMATADD,
$ CTBTRS, CTRMM, CTRTRS, DESC_CONVERT, GLOBCHK,
$ PXERBLA, RESHAPE
* ..
@@ -772,7 +769,7 @@
* First copy and multiply it into temporary storage,
* then use it on RHS
*
- CALL CLACPY( 'N', BW, NRHS,
+ CALL CLAMOV( 'N', BW, NRHS,
$ B( PART_OFFSET+ODD_SIZE-BW+1), LLDB,
$ WORK( 1 ), BW )
*
@@ -1115,7 +1112,7 @@
* First copy and multiply it into temporary storage,
* then use it on RHS
*
- CALL CLACPY( 'N', BW, NRHS, B( PART_OFFSET+ODD_SIZE+1), LLDB,
+ CALL CLAMOV( 'N', BW, NRHS, B( PART_OFFSET+ODD_SIZE+1), LLDB,
$ WORK( 1+BW-BW ), BW )
*
CALL CTRMM( 'L', 'U', 'C', 'N', BW, NRHS, -CONE,
@@ -1168,7 +1165,7 @@
* First copy and multiply it into temporary storage,
* then use it on RHS
*
- CALL CLACPY( 'N', BW, NRHS,
+ CALL CLAMOV( 'N', BW, NRHS,
$ B( PART_OFFSET+ODD_SIZE-BW+1), LLDB,
$ WORK( 1 ), BW )
*
@@ -1511,7 +1508,7 @@
* First copy and multiply it into temporary storage,
* then use it on RHS
*
- CALL CLACPY( 'N', BW, NRHS, B( PART_OFFSET+ODD_SIZE+1), LLDB,
+ CALL CLAMOV( 'N', BW, NRHS, B( PART_OFFSET+ODD_SIZE+1), LLDB,
$ WORK( 1+BW-BW ), BW )
*
CALL CTRMM( 'L', 'L', 'N', 'N', BW, NRHS, -CONE,
diff --git a/SRC/pcpttrf.f b/SRC/pcpttrf.f
index 457920e..aa32f6b 100644
--- a/SRC/pcpttrf.f
+++ b/SRC/pcpttrf.f
@@ -380,7 +380,7 @@
* ..
* .. External Subroutines ..
EXTERNAL BLACS_GET, BLACS_GRIDEXIT, BLACS_GRIDINFO,
- $ CAXPY, CGEMM, CGERV2D, CGESD2D, CLACPY,
+ $ CAXPY, CGEMM, CGERV2D, CGESD2D, CLAMOV,
$ CLATCPY, CPBTRF, CPOTRF, CSYRK, CTBTRS, CTRMM,
$ CTRRV2D, CTRSD2D, CTRSM, CTRTRS, DESC_CONVERT,
$ GLOBCHK, PXERBLA, RESHAPE
diff --git a/SRC/pcpttrsv.f b/SRC/pcpttrsv.f
index 2a2d61d..018b994 100644
--- a/SRC/pcpttrsv.f
+++ b/SRC/pcpttrsv.f
@@ -409,7 +409,7 @@
* ..
* .. External Subroutines ..
EXTERNAL BLACS_GET, BLACS_GRIDEXIT, BLACS_GRIDINFO,
- $ CGEMM, CGERV2D, CGESD2D, CLACPY, CMATADD,
+ $ CGEMM, CGERV2D, CGESD2D, CLAMOV, CMATADD,
$ CTBTRS, CTRMM, CTRTRS, DESC_CONVERT, GLOBCHK,
$ PXERBLA, RESHAPE
* ..
diff --git a/SRC/pcunmrq.f b/SRC/pcunmrq.f
index 8d39e36..d25ecb9 100644
--- a/SRC/pcunmrq.f
+++ b/SRC/pcunmrq.f
@@ -223,7 +223,7 @@
$ RSRC_ = 7, CSRC_ = 8, LLD_ = 9 )
* ..
* .. Local Scalars ..
- LOGICAL LEFT, LQUERY, NOTRAN
+ LOGICAL LEFT, LQUERY, NOTRAN, RIGHT, TRAN
CHARACTER COLBTOP, ROWBTOP, TRANST
INTEGER I, I1, I2, I3, IACOL, IB, ICCOL, ICOFFA,
$ ICOFFC, ICROW, ICTXT, IINFO, IPW, IROFFC, LCM,
@@ -258,8 +258,20 @@
IF( NPROW.EQ.-1 ) THEN
INFO = -(900+CTXT_)
ELSE
- LEFT = LSAME( SIDE, 'L' )
- NOTRAN = LSAME( TRANS, 'N' )
+ IF( LSAME( SIDE, 'L' ) ) THEN
+ LEFT = .TRUE.
+ RIGHT = .FALSE.
+ ELSE
+ LEFT = .FALSE.
+ RIGHT = .TRUE.
+ END IF
+ IF( LSAME( TRANS, 'N' ) ) THEN
+ NOTRAN = .TRUE.
+ TRAN = .FALSE.
+ ELSE
+ NOTRAN = .FALSE.
+ TRAN = .TRUE.
+ END IF
*
* NQ is the order of Q
*
@@ -439,8 +451,8 @@
$ WORK( IPW ) )
10 CONTINUE
*
- IF( ( LEFT .AND. .NOT.NOTRAN ) .OR.
- $ ( .NOT.LEFT .AND. NOTRAN ) ) THEN
+ IF( ( RIGHT .AND. TRAN ) .OR.
+ $ ( LEFT .AND. NOTRAN ) ) THEN
IB = I2 - IA
IF( LEFT ) THEN
MI = M - K + IB
diff --git a/SRC/pddbtrf.f b/SRC/pddbtrf.f
index 608b9a8..5743f32 100644
--- a/SRC/pddbtrf.f
+++ b/SRC/pddbtrf.f
@@ -1,10 +1,9 @@
SUBROUTINE PDDBTRF( N, BWL, BWU, A, JA, DESCA, AF, LAF, WORK,
$ LWORK, INFO )
*
-* -- ScaLAPACK routine (version 1.7) --
-* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
-* and University of California, Berkeley.
-* April 3, 2000
+* -- ScaLAPACK routine (version 2.0.2) --
+* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver
+* May 1 2012
*
* .. Scalar Arguments ..
INTEGER BWL, BWU, INFO, JA, LAF, LWORK, N
@@ -371,7 +370,7 @@
* .. External Subroutines ..
EXTERNAL BLACS_GRIDEXIT, BLACS_GRIDINFO, DAXPY, DDBTRF,
$ DESC_CONVERT, DGEMM, DGEMV, DGERV2D, DGESD2D,
- $ DLACPY, DLATCPY, DTBTRS, DTRMM, DTRRV2D,
+ $ DLAMOV, DLATCPY, DTBTRS, DTRMM, DTRRV2D,
$ DTRSD2D, GLOBCHK, IGAMX2D, IGEBR2D, IGEBS2D,
$ PXERBLA, RESHAPE
* ..
@@ -723,7 +722,7 @@
CALL DLATCPY( 'U', BWL, BWL, A( ( OFST+( BWL+BWU+1 )+
$ ( ODD_SIZE-BWL )*LLDA ) ), LLDA-1,
$ AF( ODD_SIZE*BWU+2*MBW2+1+MAX_BW-BWL ), MAX_BW )
- CALL DLACPY( 'L', BWU, BWU, A( ( OFST+1+ODD_SIZE*LLDA ) ),
+ CALL DLAMOV( 'L', BWU, BWU, A( ( OFST+1+ODD_SIZE*LLDA ) ),
$ LLDA-1, AF( WORK_U+ODD_SIZE*BWL+2*MBW2+1+MAX_BW-
$ BWU ), MAX_BW )
*
@@ -750,7 +749,7 @@
*
* Move the resulting block back to its location in main storage.
*
- CALL DLACPY( 'L', BWU, BWU, AF( WORK_U+ODD_SIZE*BWL+2*MBW2+1+
+ CALL DLAMOV( 'L', BWU, BWU, AF( WORK_U+ODD_SIZE*BWL+2*MBW2+1+
$ MAX_BW-BWU ), MAX_BW, A( ( OFST+1+ODD_SIZE*
$ LLDA ) ), LLDA-1 )
*
@@ -816,7 +815,7 @@
*
* Copy D block into AF storage for solve.
*
- CALL DLACPY( 'L', UP_PREV_TRI_SIZE_N, UP_PREV_TRI_SIZE_M,
+ CALL DLAMOV( 'L', UP_PREV_TRI_SIZE_N, UP_PREV_TRI_SIZE_M,
$ A( OFST+1 ), LLDA-1, AF( 1 ), BWU )
*
DO 80 I1 = 1, ODD_SIZE
@@ -865,7 +864,7 @@
* Since we have GU_i stored,
* transpose HU_i to HU_i^T.
*
- CALL DLACPY( 'N', BWL, BWL,
+ CALL DLAMOV( 'N', BWL, BWL,
$ AF( WORK_U+( ODD_SIZE-BWL )*BWL+1 ), BWL,
$ AF( ( ODD_SIZE )*BWU+1+( MAX_BW-BWL ) ),
$ MAX_BW )
@@ -881,7 +880,7 @@
* Since we have GL_i^T stored,
* transpose HL_i^T to HL_i.
*
- CALL DLACPY( 'N', BWU, BWU, AF( ( ODD_SIZE-BWU )*BWU+1 ),
+ CALL DLAMOV( 'N', BWU, BWU, AF( ( ODD_SIZE-BWU )*BWU+1 ),
$ BWU, AF( WORK_U+( ODD_SIZE )*BWL+1+MAX_BW-
$ BWU ), MAX_BW )
*
@@ -946,7 +945,7 @@
* Copy last diagonal block into AF storage for subsequent
* operations.
*
- CALL DLACPY( 'N', MAX_BW, MAX_BW, A( OFST+ODD_SIZE*LLDA+BWU+1 ),
+ CALL DLAMOV( 'N', MAX_BW, MAX_BW, A( OFST+ODD_SIZE*LLDA+BWU+1 ),
$ LLDA-1, AF( ODD_SIZE*BWU+MBW2+1 ), MAX_BW )
*
* Receive cont. to diagonal block that is stored on this proc.
@@ -1030,10 +1029,10 @@
* Move block into place that it will be expected to be for
* calcs.
*
- CALL DLACPY( 'N', MAX_BW, MAX_BW, AF( ODD_SIZE*BWU+1 ), MAX_BW,
+ CALL DLAMOV( 'N', MAX_BW, MAX_BW, AF( ODD_SIZE*BWU+1 ), MAX_BW,
$ AF( WORK_U+ODD_SIZE*BWL+2*MBW2+1 ), MAX_BW )
*
- CALL DLACPY( 'N', MAX_BW, MAX_BW, AF( WORK_U+ODD_SIZE*BWL+1 ),
+ CALL DLAMOV( 'N', MAX_BW, MAX_BW, AF( WORK_U+ODD_SIZE*BWL+1 ),
$ MAX_BW, AF( ODD_SIZE*BWU+2*MBW2+1 ), MAX_BW )
*
ELSE
diff --git a/SRC/pddbtrsv.f b/SRC/pddbtrsv.f
index b63405d..293d12c 100644
--- a/SRC/pddbtrsv.f
+++ b/SRC/pddbtrsv.f
@@ -1,10 +1,9 @@
SUBROUTINE PDDBTRSV( UPLO, TRANS, N, BWL, BWU, NRHS, A, JA, DESCA,
$ B, IB, DESCB, AF, LAF, WORK, LWORK, INFO )
*
-* -- ScaLAPACK routine (version 1.7) --
-* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
-* and University of California, Berkeley.
-* April 3, 2000
+* -- ScaLAPACK routine (version 2.0.2) --
+* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver
+* May 1 2012
*
* .. Scalar Arguments ..
CHARACTER TRANS, UPLO
@@ -399,7 +398,7 @@
* ..
* .. External Subroutines ..
EXTERNAL BLACS_GRIDEXIT, BLACS_GRIDINFO, DESC_CONVERT,
- $ DGEMM, DGERV2D, DGESD2D, DLACPY, DMATADD,
+ $ DGEMM, DGERV2D, DGESD2D, DLAMOV, DMATADD,
$ DTBTRS, DTRMM, GLOBCHK, PXERBLA, RESHAPE
* ..
* .. External Functions ..
@@ -777,7 +776,7 @@
* First copy and multiply it into temporary storage,
* then use it on RHS
*
- CALL DLACPY( 'N', BWL, NRHS,
+ CALL DLAMOV( 'N', BWL, NRHS,
$ B( PART_OFFSET+ODD_SIZE-BWL+1 ), LLDB,
$ WORK( 1 ), MAX_BW )
*
@@ -1111,7 +1110,7 @@
* First copy and multiply it into temporary storage,
* then use it on RHS
*
- CALL DLACPY( 'N', BWL, NRHS, B( PART_OFFSET+ODD_SIZE+1 ),
+ CALL DLAMOV( 'N', BWL, NRHS, B( PART_OFFSET+ODD_SIZE+1 ),
$ LLDB, WORK( 1+MAX_BW-BWL ), MAX_BW )
*
CALL DTRMM( 'L', 'U', 'T', 'N', BWL, NRHS, -ONE,
@@ -1163,7 +1162,7 @@
* First copy and multiply it into temporary storage,
* then use it on RHS
*
- CALL DLACPY( 'N', BWU, NRHS,
+ CALL DLAMOV( 'N', BWU, NRHS,
$ B( PART_OFFSET+ODD_SIZE-BWU+1 ), LLDB,
$ WORK( 1 ), MAX_BW )
*
@@ -1497,7 +1496,7 @@
* First copy and multiply it into temporary storage,
* then use it on RHS
*
- CALL DLACPY( 'N', BWU, NRHS, B( PART_OFFSET+ODD_SIZE+1 ),
+ CALL DLAMOV( 'N', BWU, NRHS, B( PART_OFFSET+ODD_SIZE+1 ),
$ LLDB, WORK( 1+MAX_BW-BWU ), MAX_BW+BWL )
*
CALL DTRMM( 'L', 'L', 'N', 'N', BWU, NRHS, -ONE,
diff --git a/SRC/pdgbtrf.f b/SRC/pdgbtrf.f
index 5d71b4a..dfea1da 100644
--- a/SRC/pdgbtrf.f
+++ b/SRC/pdgbtrf.f
@@ -1,10 +1,9 @@
SUBROUTINE PDGBTRF( N, BWL, BWU, A, JA, DESCA, IPIV, AF, LAF,
$ WORK, LWORK, INFO )
*
-* -- ScaLAPACK routine (version 1.7) --
-* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
-* and University of California, Berkeley.
-* April 3, 2000
+* -- ScaLAPACK routine (version 2.0.2) --
+* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver
+* May 1 2012
*
* .. Scalar Arguments ..
INTEGER BWL, BWU, INFO, JA, LAF, LWORK, N
@@ -385,7 +384,7 @@
* .. External Subroutines ..
EXTERNAL BLACS_GRIDEXIT, BLACS_GRIDINFO, DESC_CONVERT,
$ DGBTRF, DGEMM, DGER, DGERV2D, DGESD2D, DGETRF,
- $ DLACPY, DLASWP, DLATCPY, DSWAP, DTRRV2D,
+ $ DLAMOV, DLASWP, DLATCPY, DSWAP, DTRRV2D,
$ DTRSD2D, DTRSM, GLOBCHK, IGAMX2D, IGEBR2D,
$ IGEBS2D, PXERBLA, RESHAPE
* ..
@@ -834,7 +833,7 @@
* DBPTR = Pointer to diagonal blocks in A
DBPTR = BW + 1 + LBWU + LN*LLDA
*
- CALL DLACPY( 'G', BM, BN, A( DBPTR ), LLDA-1, AF( BBPTR+BW*LDBB ),
+ CALL DLAMOV( 'G', BM, BN, A( DBPTR ), LLDA-1, AF( BBPTR+BW*LDBB ),
$ LDBB )
*
* Zero out any junk entries that were copied
@@ -919,7 +918,7 @@
*
* Copy diagonal block to align whole system
*
- CALL DLACPY( 'G', BMN, BW, AF( BBPTR+BM ), LDBB,
+ CALL DLAMOV( 'G', BMN, BW, AF( BBPTR+BM ), LDBB,
$ AF( BBPTR+2*BW*LDBB+BM ), LDBB )
END IF
*
@@ -945,7 +944,7 @@
CALL DGESD2D( ICTXT, BM, 2*BW, AF( BBPTR+BW*LDBB ), LDBB, 0,
$ NEICOL )
*
- CALL DLACPY( 'G', BM, 2*BW, AF( BBPTR+BW*LDBB ), LDBB,
+ CALL DLAMOV( 'G', BM, 2*BW, AF( BBPTR+BW*LDBB ), LDBB,
$ AF( BBPTR+BMN ), LDBB )
*
DO 130 J = BBPTR + 2*BW*LDBB, BBPTR + 3*BW*LDBB - 1, LDBB
@@ -961,7 +960,7 @@
*
* Copy diagonal block to align whole system
*
- CALL DLACPY( 'G', BM, BW, AF( BBPTR+BMN ), LDBB,
+ CALL DLAMOV( 'G', BM, BW, AF( BBPTR+BMN ), LDBB,
$ AF( BBPTR+2*BW*LDBB+BMN ), LDBB )
END IF
*
@@ -1023,9 +1022,9 @@
* Local copying in the block bidiagonal area
*
*
- CALL DLACPY( 'G', BM, BW, AF( BBPTR+BW ), LDBB,
+ CALL DLAMOV( 'G', BM, BW, AF( BBPTR+BW ), LDBB,
$ AF( BBPTR+BW*LDBB ), LDBB )
- CALL DLACPY( 'G', BM, BW, AF( BBPTR+2*BW*LDBB+BW ), LDBB,
+ CALL DLAMOV( 'G', BM, BW, AF( BBPTR+2*BW*LDBB+BW ), LDBB,
$ AF( BBPTR+2*BW*LDBB ), LDBB )
*
* Zero out space that held original copy
diff --git a/SRC/pdgbtrs.f b/SRC/pdgbtrs.f
index 7d2e8ea..fa8f4a1 100644
--- a/SRC/pdgbtrs.f
+++ b/SRC/pdgbtrs.f
@@ -1,10 +1,9 @@
SUBROUTINE PDGBTRS( TRANS, N, BWL, BWU, NRHS, A, JA, DESCA, IPIV,
$ B, IB, DESCB, AF, LAF, WORK, LWORK, INFO )
*
-* -- ScaLAPACK routine (version 1.7) --
-* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
-* and University of California, Berkeley.
-* April 3, 2000
+* -- ScaLAPACK routine (version 2.0.2) --
+* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver
+* May 1 2012
*
* .. Scalar Arguments ..
CHARACTER TRANS
@@ -397,7 +396,7 @@
* .. External Subroutines ..
EXTERNAL BLACS_GRIDEXIT, BLACS_GRIDINFO, DCOPY,
$ DESC_CONVERT, DGEMM, DGEMV, DGER, DGERV2D,
- $ DGESD2D, DGETRS, DLACPY, DLASWP, DSCAL, DSWAP,
+ $ DGESD2D, DGETRS, DLAMOV, DLASWP, DSCAL, DSWAP,
$ DTRSM, GLOBCHK, PXERBLA, RESHAPE
* ..
* .. External Functions ..
@@ -725,7 +724,7 @@
*
LDW = NB + BWU + 2*BW + BWU
*
- CALL DLACPY( 'G', LM, NRHS, B( 1 ), LLDB, WORK( WPTR ), LDW )
+ CALL DLAMOV( 'G', LM, NRHS, B( 1 ), LLDB, WORK( WPTR ), LDW )
*
* Zero out rest of work
*
@@ -872,7 +871,7 @@
BMN = BW
END IF
*
- CALL DLACPY( 'G', BM, NRHS, WORK( LN+1 ), LDW,
+ CALL DLAMOV( 'G', BM, NRHS, WORK( LN+1 ), LDW,
$ WORK( NB+BWU+BMN+1 ), LDW )
*
CALL DGERV2D( ICTXT, BMN, NRHS, WORK( NB+BWU+1 ), LDW, 0,
@@ -1023,7 +1022,7 @@
*
* Move RHS to make room for received solutions
*
- CALL DLACPY( 'G', BW, NRHS, WORK( NB+BWU+1 ), LDW,
+ CALL DLAMOV( 'G', BW, NRHS, WORK( NB+BWU+1 ), LDW,
$ WORK( NB+BWU+BW+1 ), LDW )
*
CALL DGERV2D( ICTXT, 2*BW, NRHS, WORK( LN+1 ), LDW, 0,
@@ -1053,7 +1052,7 @@
*
* Copy new solution into expected place
*
- CALL DLACPY( 'G', BW, NRHS, WORK( NB+BWU+1+BW ), LDW,
+ CALL DLAMOV( 'G', BW, NRHS, WORK( NB+BWU+1+BW ), LDW,
$ WORK( LN+BW+1 ), LDW )
*
ELSE
@@ -1071,7 +1070,7 @@
*
* Shift solutions into expected positions
*
- CALL DLACPY( 'G', BNN+BN-BW, NRHS, WORK( NB+BWU+1+BW ), LDW,
+ CALL DLAMOV( 'G', BNN+BN-BW, NRHS, WORK( NB+BWU+1+BW ), LDW,
$ WORK( LN+1 ), LDW )
*
*
@@ -1147,7 +1146,7 @@
*
*
*
- CALL DLACPY( 'G', ODD_SIZE, NRHS, WORK( 1 ), LDW, B( 1 ), LLDB )
+ CALL DLAMOV( 'G', ODD_SIZE, NRHS, WORK( 1 ), LDW, B( 1 ), LLDB )
*
* Free BLACS space used to hold standard-form grid.
*
diff --git a/SRC/pdgebal.f b/SRC/pdgebal.f
new file mode 100644
index 0000000..ff6b845
--- /dev/null
+++ b/SRC/pdgebal.f
@@ -0,0 +1,443 @@
+ SUBROUTINE PDGEBAL( JOB, N, A, DESCA, ILO, IHI, SCALE, INFO )
+*
+* Contribution from the Department of Computing Science and HPC2N,
+* Umea University, Sweden
+*
+* -- ScaLAPACK computational routine (version 2.0.1) --
+* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
+* Univ. of Colorado Denver and University of California, Berkeley.
+* January, 2012
+*
+ IMPLICIT NONE
+*
+* .. Scalar Arguments ..
+ CHARACTER JOB
+ INTEGER IHI, ILO, INFO, N
+* ..
+* .. Array Arguments ..
+ INTEGER DESCA( * )
+ DOUBLE PRECISION A( * ), SCALE( * )
+* ..
+*
+* Purpose
+* =======
+*
+* PDGEBAL 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.
+*
+* Notes
+* =====
+*
+* Each global data object is described by an associated description
+* vector. This vector stores the information required to establish
+* the mapping between an object element and its corresponding process
+* and memory location.
+*
+* Let A be a generic term for any 2D block cyclicly distributed array.
+* Such a global array has an associated description vector DESCA.
+* In the following comments, the character _ should be read as
+* "of the global array".
+*
+* NOTATION STORED IN EXPLANATION
+* --------------- -------------- --------------------------------------
+* DTYPE_A(global) DESCA( DTYPE_ )The descriptor type. In this case,
+* DTYPE_A = 1.
+* CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating
+* the BLACS process grid A is distribu-
+* ted over. The context itself is glo-
+* bal, but the handle (the integer
+* value) may vary.
+* M_A (global) DESCA( M_ ) The number of rows in the global
+* array A.
+* N_A (global) DESCA( N_ ) The number of columns in the global
+* array A.
+* MB_A (global) DESCA( MB_ ) The blocking factor used to distribute
+* the rows of the array.
+* NB_A (global) DESCA( NB_ ) The blocking factor used to distribute
+* the columns of the array.
+* RSRC_A (global) DESCA( RSRC_ ) The process row over which the first
+* row of the array A is distributed.
+* CSRC_A (global) DESCA( CSRC_ ) The process column over which the
+* first column of the array A is
+* distributed.
+* LLD_A (local) DESCA( LLD_ ) The leading dimension of the local
+* array. LLD_A >= MAX(1,LOCr(M_A)).
+*
+* Let K be the number of rows or columns of a distributed matrix,
+* and assume that its process grid has dimension p x q.
+* LOCr( K ) denotes the number of elements of K that a process
+* would receive if K were distributed over the p processes of its
+* process column.
+* Similarly, LOCc( K ) denotes the number of elements of K that a
+* process would receive if K were distributed over the q processes of
+* its process row.
+* The values of LOCr() and LOCc() may be determined via a call to the
+* ScaLAPACK tool function, NUMROC:
+* LOCr( M ) = NUMROC( M, MB_A, MYROW, RSRC_A, NPROW ),
+* LOCc( N ) = NUMROC( N, NB_A, MYCOL, CSRC_A, NPCOL ).
+* An upper bound for these quantities may be computed by:
+* LOCr( M ) <= ceil( ceil(M/MB_A)/NPROW )*MB_A
+* LOCc( N ) <= ceil( ceil(N/NB_A)/NPCOL )*NB_A
+*
+*
+* Arguments
+* =========
+*
+* JOB (global input) CHARACTER*1
+* Specifies the operations to be performed on A:
+* = 'N': none: simply set ILO = 1, IHI = N, SCALE(I) = 1.0
+* for i = 1,...,N;
+* = 'P': permute only;
+* = 'S': scale only;
+* = 'B': both permute and scale.
+*
+* N (global input) INTEGER
+* The order of the matrix A. N >= 0.
+*
+* A (local input/output) DOUBLE PRECISION array, dimension
+* (DESCA(LLD_,LOCc(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.
+*
+* DESCA (global and local input) INTEGER array of dimension DLEN_.
+* The array descriptor for the distributed matrix A.
+*
+* ILO (global output) INTEGER
+* IHI (global output) INTEGER
+* ILO and IHI are set to integers such that on exit
+* A(i,j) = 0 if i > j and j = 1,...,ILO-1 or I = IHI+1,...,N.
+* If JOB = 'N' or 'S', ILO = 1 and IHI = N.
+*
+* SCALE (global output) DOUBLE PRECISION array, dimension (N)
+* Details of the permutations and scaling factors applied to
+* A. If P(j) is the index of the row and column interchanged
+* with row and column j and D(j) is the scaling factor
+* applied to row and column j, then
+* SCALE(j) = P(j) for j = 1,...,ILO-1
+* = D(j) for j = ILO,...,IHI
+* = P(j) for j = IHI+1,...,N.
+* The order in which the interchanges are made is N to IHI+1,
+* then 1 to ILO-1.
+*
+* INFO (global output) INTEGER
+* = 0: successful exit.
+* < 0: if INFO = -i, the i-th argument had an illegal value.
+*
+* Further Details
+* ===============
+*
+* The permutations consist of row and column interchanges which put
+* the matrix in the form
+*
+* ( T1 X Y )
+* P A P = ( 0 B Z )
+* ( 0 0 T2 )
+*
+* where T1 and T2 are upper triangular matrices whose eigenvalues lie
+* along the diagonal. The column indices ILO and IHI mark the starting
+* and ending columns of the submatrix B. Balancing consists of applying
+* a diagonal similarity transformation inv(D) * B * D to make the
+* 1-norms of each row of B and its corresponding column nearly equal.
+* The output matrix is
+*
+* ( T1 X*D Y )
+* ( 0 inv(D)*B*D inv(D)*Z ).
+* ( 0 0 T2 )
+*
+* Information about the permutations P and the diagonal matrix D is
+* returned in the vector SCALE.
+*
+* This subroutine is based on the EISPACK routine BALANC. In principle,
+* the parallelism is extracted by using PBLAS and BLACS routines for
+* the permutation and balancing.
+*
+* Modified by Tzu-Yi Chen, Computer Science Division, University of
+* California at Berkeley, USA
+*
+* Parallel version by Robert Granat and Meiyue Shao, Department of
+* Computing Science and HPC2N, Umea University, Sweden
+*
+* =====================================================================
+*
+* .. Parameters ..
+ INTEGER BLOCK_CYCLIC_2D, CSRC_, CTXT_, DLEN_, DTYPE_,
+ $ LLD_, MB_, M_, NB_, N_, RSRC_
+ PARAMETER ( BLOCK_CYCLIC_2D = 1, DLEN_ = 9, DTYPE_ = 1,
+ $ CTXT_ = 2, M_ = 3, N_ = 4, MB_ = 5, NB_ = 6,
+ $ RSRC_ = 7, CSRC_ = 8, LLD_ = 9 )
+ 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, LLDA,
+ $ ICTXT, NPROW, NPCOL, MYROW, MYCOL, II, JJ,
+ $ ARSRC, ACSRC
+ DOUBLE PRECISION C, CA, F, G, R, RA, S, SFMAX1, SFMAX2, SFMIN1,
+ $ SFMIN2, ELEM
+* ..
+* .. Local Arrays ..
+ DOUBLE PRECISION CR( 2 )
+* ..
+* .. External Functions ..
+ LOGICAL DISNAN, LSAME
+ INTEGER IDAMAX
+ DOUBLE PRECISION DLAMCH
+ EXTERNAL DISNAN, LSAME, DLAMCH
+* ..
+* .. External Subroutines ..
+ EXTERNAL PDSCAL, PDSWAP, PDAMAX, PXERBLA,
+ $ BLACS_GRIDINFO, CHK1MAT, DGSUM2D,
+ $ INFOG2L, PDELGET
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX, MIN
+* ..
+* .. Executable Statements ..
+ INFO = 0
+ ICTXT = DESCA( CTXT_ )
+ CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL )
+*
+* Test the input parameters.
+*
+ 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
+ CALL CHK1MAT( N, 2, N, 2, 1, 1, DESCA, 4, INFO )
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL PXERBLA( 'PDGEBAL', -INFO )
+ RETURN
+ END IF
+*
+* Extract local leading dimension of A.
+*
+ LLDA = DESCA( LLD_ )
+*
+ 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 PDSWAP( L, A, 1, J, DESCA, 1, A, 1, M, DESCA, 1 )
+ CALL PDSWAP( N-K+1, A, J, K, DESCA, DESCA(M_), A, M, K, DESCA,
+ $ DESCA(M_) )
+*
+ 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
+*
+* All processors need the information to make correct decisions.
+*
+ CALL PDELGET( 'All', '1-Tree', ELEM, A, J, I, DESCA )
+ IF( ELEM.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
+*
+* All processors need the information to make correct decisions.
+*
+ CALL PDELGET( 'All', '1-Tree', ELEM, A, I, J, DESCA )
+ IF( ELEM.NE.ZERO )
+ $ GO TO 110
+ 100 CONTINUE
+*
+ M = K
+ IEXC = 2
+ GO TO 20
+ 110 CONTINUE
+*
+ 120 CONTINUE
+ DO 130 I = K, L
+ SCALE( I ) = ONE
+ 130 CONTINUE
+*
+ IF( LSAME( JOB, 'P' ) )
+ $ GO TO 210
+*
+* Balance the submatrix in rows K to L.
+*
+* Iterative loop for norm reduction.
+*
+ SFMIN1 = DLAMCH( 'S' ) / DLAMCH( 'P' )
+ SFMAX1 = ONE / SFMIN1
+ SFMIN2 = SFMIN1*SCLFAC
+ SFMAX2 = ONE / SFMIN2
+ 140 CONTINUE
+ NOCONV = .FALSE.
+*
+ DO 200 I = K, L
+ C = ZERO
+ R = ZERO
+*
+* Compute local partial values of R and C in parallel and combine
+* with a call to the BLACS global summation routine distributing
+* information to all processors.
+*
+ DO 150 J = K, L
+ IF( J.EQ.I )
+ $ GO TO 150
+ CALL INFOG2L( J, I, DESCA, NPROW, NPCOL, MYROW,
+ $ MYCOL, II, JJ, ARSRC, ACSRC )
+ IF( MYROW.EQ.ARSRC .AND. MYCOL.EQ.ACSRC ) THEN
+ C = C + ABS( A( II + (JJ-1)*LLDA ) )
+ END IF
+ CALL INFOG2L( I, J, DESCA, NPROW, NPCOL, MYROW,
+ $ MYCOL, II, JJ, ARSRC, ACSRC )
+ IF( MYROW.EQ.ARSRC .AND. MYCOL.EQ.ACSRC ) THEN
+ R = R + ABS( A( II + (JJ-1)*LLDA ) )
+ END IF
+ 150 CONTINUE
+ CR( 1 ) = C
+ CR( 2 ) = R
+ CALL DGSUM2D( ICTXT, 'All', '1-Tree', 2, 1, CR, 2, -1, -1 )
+ C = CR( 1 )
+ R = CR( 2 )
+*
+* Find global maximum absolute values and indices in parallel.
+*
+ CALL PDAMAX( L, CA, ICA, A, 1, I, DESCA, 1 )
+ CALL PDAMAX( N-K+1, RA, IRA, A, I, K, DESCA, DESCA(M_) )
+*
+* 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 PXERBLA( 'PDGEBAL', -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 PDSCAL( N-K+1, G, A, I, K, DESCA, DESCA(M_) )
+ CALL PDSCAL( L, F, A, 1, I, DESCA, 1 )
+*
+ 200 CONTINUE
+*
+ IF( NOCONV )
+ $ GO TO 140
+*
+ 210 CONTINUE
+ ILO = K
+ IHI = L
+*
+ RETURN
+*
+* End of PDGEBAL
+*
+ END
diff --git a/SRC/pdgecon.f b/SRC/pdgecon.f
index 374abec..b4d95ce 100644
--- a/SRC/pdgecon.f
+++ b/SRC/pdgecon.f
@@ -153,7 +153,7 @@
* LIWORK (local or global input) INTEGER
* The dimension of the array IWORK.
* LIWORK is local input and must be at least
-* LIWORK >= LOCr(N+MOD(IA-1,MB_A)).
+* LIWORK >= MAX( 1, LOCr(N+MOD(IA-1,MB_A)) ).
*
* If LIWORK = -1, then LIWORK is global input and a workspace
* query is assumed; the routine only calculates the minimum
@@ -238,7 +238,7 @@
$ DESCA( NB_ )*
$ MAX( 1, ICEIL( NPCOL-1, NPROW ) ) ) )
WORK( 1 ) = DBLE( LWMIN )
- LIWMIN = NPMOD
+ LIWMIN = MAX( 1, NPMOD )
IWORK( 1 ) = LIWMIN
LQUERY = ( LWORK.EQ.-1 .OR. LIWORK.EQ.-1 )
*
diff --git a/SRC/pdgehrd.f b/SRC/pdgehrd.f
index b27185d..49ee0af 100644
--- a/SRC/pdgehrd.f
+++ b/SRC/pdgehrd.f
@@ -263,7 +263,8 @@
INFO = -2
ELSE IF( IHI.LT.MIN( ILO, N ) .OR. IHI.GT.N ) THEN
INFO = -3
- ELSE IF( IROFFA.NE.ICOFFA .OR. IROFFA.NE.0 ) THEN
+C ELSE IF( IROFFA.NE.ICOFFA .OR. IROFFA.NE.0 ) THEN
+ ELSE IF( IROFFA.NE.ICOFFA ) THEN
INFO = -6
ELSE IF( DESCA( MB_ ).NE.DESCA( NB_ ) ) THEN
INFO = -(700+NB_)
diff --git a/SRC/pdgels.f b/SRC/pdgels.f
index 12c99d3..dae599f 100644
--- a/SRC/pdgels.f
+++ b/SRC/pdgels.f
@@ -277,7 +277,11 @@
INFO = -( 800 + CTXT_ )
ELSE
CALL CHK1MAT( M, 2, N, 3, IA, JA, DESCA, 8, INFO )
- CALL CHK1MAT( N, 3, NRHS, 4, IB, JB, DESCB, 12, INFO )
+ IF ( M .GE. N ) THEN
+ CALL CHK1MAT( M, 2, NRHS, 4, IB, JB, DESCB, 12, INFO )
+ ELSE
+ CALL CHK1MAT( N, 3, NRHS, 4, IB, JB, DESCB, 12, INFO )
+ ENDIF
IF( INFO.EQ.0 ) THEN
IROFFA = MOD( IA-1, DESCA( MB_ ) )
ICOFFA = MOD( JA-1, DESCA( NB_ ) )
diff --git a/SRC/pdhseqr.f b/SRC/pdhseqr.f
new file mode 100644
index 0000000..dfada31
--- /dev/null
+++ b/SRC/pdhseqr.f
@@ -0,0 +1,682 @@
+ SUBROUTINE PDHSEQR( JOB, COMPZ, N, ILO, IHI, H, DESCH, WR, WI, Z,
+ $ DESCZ, WORK, LWORK, IWORK, LIWORK, INFO )
+*
+* Contribution from the Department of Computing Science and HPC2N,
+* Umea University, Sweden
+*
+* -- ScaLAPACK driver routine (version 2.0.1) --
+* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
+* Univ. of Colorado Denver and University of California, Berkeley.
+* January, 2012
+*
+ IMPLICIT NONE
+*
+* .. Scalar Arguments ..
+ INTEGER IHI, ILO, INFO, LWORK, LIWORK, N
+ CHARACTER COMPZ, JOB
+* ..
+* .. Array Arguments ..
+ INTEGER DESCH( * ) , DESCZ( * ), IWORK( * )
+ DOUBLE PRECISION H( * ), WI( N ), WORK( * ), WR( N ), Z( * )
+* ..
+* Purpose
+* =======
+*
+* PDHSEQR computes the eigenvalues of an upper 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.
+*
+* Notes
+* =====
+*
+* Each global data object is described by an associated description
+* vector. This vector stores the information required to establish
+* the mapping between an object element and its corresponding process
+* and memory location.
+*
+* Let A be a generic term for any 2D block cyclicly distributed array.
+* Such a global array has an associated description vector DESCA.
+* In the following comments, the character _ should be read as
+* "of the global array".
+*
+* NOTATION STORED IN EXPLANATION
+* --------------- -------------- --------------------------------------
+* DTYPE_A(global) DESCA( DTYPE_ )The descriptor type. In this case,
+* DTYPE_A = 1.
+* CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating
+* the BLACS process grid A is distribu-
+* ted over. The context itself is glo-
+* bal, but the handle (the integer
+* value) may vary.
+* M_A (global) DESCA( M_ ) The number of rows in the global
+* array A.
+* N_A (global) DESCA( N_ ) The number of columns in the global
+* array A.
+* MB_A (global) DESCA( MB_ ) The blocking factor used to distribute
+* the rows of the array.
+* NB_A (global) DESCA( NB_ ) The blocking factor used to distribute
+* the columns of the array.
+* RSRC_A (global) DESCA( RSRC_ ) The process row over which the first
+* row of the array A is distributed.
+* CSRC_A (global) DESCA( CSRC_ ) The process column over which the
+* first column of the array A is
+* distributed.
+* LLD_A (local) DESCA( LLD_ ) The leading dimension of the local
+* array. LLD_A >= MAX(1,LOCr(M_A)).
+*
+* Let K be the number of rows or columns of a distributed matrix,
+* and assume that its process grid has dimension p x q.
+* LOCr( K ) denotes the number of elements of K that a process
+* would receive if K were distributed over the p processes of its
+* process column.
+* Similarly, LOCc( K ) denotes the number of elements of K that a
+* process would receive if K were distributed over the q processes of
+* its process row.
+* The values of LOCr() and LOCc() may be determined via a call to the
+* ScaLAPACK tool function, NUMROC:
+* LOCr( M ) = NUMROC( M, MB_A, MYROW, RSRC_A, NPROW ),
+* LOCc( N ) = NUMROC( N, NB_A, MYCOL, CSRC_A, NPCOL ).
+* An upper bound for these quantities may be computed by:
+* LOCr( M ) <= ceil( ceil(M/MB_A)/NPROW )*MB_A
+* LOCc( N ) <= ceil( ceil(N/NB_A)/NPCOL )*NB_A
+*
+* Arguments
+* =========
+*
+* JOB (global input) CHARACTER*1
+* = 'E': compute eigenvalues only;
+* = 'S': compute eigenvalues and the Schur form T.
+*
+* COMPZ (global input) CHARACTER*1
+* = 'N': no Schur vectors are computed;
+* = 'I': Z is initialized to the unit matrix and the matrix Z
+* of Schur vectors of H is returned;
+* = 'V': Z must contain an orthogonal matrix Q on entry, and
+* the product Q*Z is returned.
+*
+* N (global input) INTEGER
+* The order of the Hessenberg matrix H (and Z if WANTZ).
+* N >= 0.
+*
+* ILO (global input) INTEGER
+* IHI (global input) INTEGER
+* It is assumed that H is already upper triangular in rows
+* and columns 1:ILO-1 and IHI+1:N. ILO and IHI are normally
+* set by a previous call to PDGEBAL, and then passed to PDGEHRD
+* when the matrix output by PDGEBAL is reduced to Hessenberg
+* form. Otherwise ILO and IHI should be set to 1 and N
+* respectively. If N.GT.0, then 1.LE.ILO.LE.IHI.LE.N.
+* If N = 0, then ILO = 1 and IHI = 0.
+*
+* H (global input/output) DOUBLE PRECISION array, dimension
+* (DESCH(LLD_),*)
+* On entry, the upper Hessenberg matrix H.
+* On exit, if JOB = 'S', H is upper quasi-triangular in
+* rows and columns ILO:IHI, with 1-by-1 and 2-by-2 blocks on
+* the main diagonal. The 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.
+*
+* DESCH (global and local input) INTEGER array of dimension DLEN_.
+* The array descriptor for the distributed matrix H.
+*
+* WR (global output) DOUBLE PRECISION array, dimension (N)
+* WI (global output) DOUBLE PRECISION array, dimension (N)
+* The real and imaginary parts, respectively, of the computed
+* eigenvalues ILO to IHI are stored in the corresponding
+* elements of WR and WI. If two eigenvalues are computed as a
+* complex conjugate pair, they are stored in consecutive
+* elements of WR and WI, say the i-th and (i+1)th, with
+* WI(i) > 0 and WI(i+1) < 0. If JOB = 'S', the
+* eigenvalues are stored in the same order as on the diagonal
+* of the Schur form returned in H.
+*
+* Z (global input/output) DOUBLE PRECISION array.
+* If COMPZ = 'V', on entry Z must contain the current
+* matrix Z of accumulated transformations from, e.g., PDGEHRD,
+* and on exit Z has been updated; transformations are applied
+* only to the submatrix Z(ILO:IHI,ILO:IHI).
+* 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.
+*
+* DESCZ (global and local input) INTEGER array of dimension DLEN_.
+* The array descriptor for the distributed matrix Z.
+*
+* WORK (local workspace) DOUBLE PRECISION array, dimension(LWORK)
+*
+* LWORK (local input) INTEGER
+* The length of the workspace array WORK.
+*
+* IWORK (local workspace) INTEGER array, dimension (LIWORK)
+*
+* LIWORK (local input) INTEGER
+* The length of the workspace array IWORK.
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* .LT. 0: if INFO = -i, the i-th argument had an illegal
+* value (see also below for -7777 and -8888).
+* .GT. 0: if INFO = i, PDHSEQR 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.
+*
+* = -7777: PDLAQR0 failed to converge and PDLAQR1 was called
+* instead. This could happen. Mostly due to a bug.
+* Please, send a bug report to the authors.
+* = -8888: PDLAQR1 failed to converge and PDLAQR0 was called
+* instead. This should not happen.
+*
+* ================================================================
+* Based on contributions by
+* Robert Granat, Department of Computing Science and HPC2N,
+* Umea University, Sweden.
+* ================================================================
+*
+* Restrictions: The block size in H and Z must be square and larger
+* than or equal to six (6) due to restrictions in PDLAQR1, PDLAQR5
+* and DLAQR6. Moreover, H and Z need to be distributed identically
+* with the same context.
+*
+* ================================================================
+* References:
+* K. Braman, R. Byers, and R. Mathias,
+* The Multi-Shift QR Algorithm Part I: Maintaining Well Focused
+* Shifts, and Level 3 Performance.
+* SIAM J. Matrix Anal. Appl., 23(4):929--947, 2002.
+*
+* K. Braman, R. Byers, and R. Mathias,
+* The Multi-Shift QR Algorithm Part II: Aggressive Early
+* Deflation.
+* SIAM J. Matrix Anal. Appl., 23(4):948--973, 2002.
+*
+* R. Granat, B. Kagstrom, and D. Kressner,
+* A Novel Parallel QR Algorithm for Hybrid Distributed Momory HPC
+* Systems.
+* SIAM J. Sci. Comput., 32(4):2345--2378, 2010.
+*
+* ================================================================
+* .. Parameters ..
+ INTEGER BLOCK_CYCLIC_2D, CSRC_, CTXT_, DLEN_, DTYPE_,
+ $ LLD_, MB_, M_, NB_, N_, RSRC_
+ LOGICAL CRSOVER
+ PARAMETER ( BLOCK_CYCLIC_2D = 1, DLEN_ = 9, DTYPE_ = 1,
+ $ CTXT_ = 2, M_ = 3, N_ = 4, MB_ = 5, NB_ = 6,
+ $ RSRC_ = 7, CSRC_ = 8, LLD_ = 9,
+ $ CRSOVER = .TRUE. )
+ INTEGER NTINY
+ PARAMETER ( NTINY = 11 )
+ INTEGER NL
+ PARAMETER ( NL = 49 )
+ DOUBLE PRECISION ZERO, ONE
+ PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 )
+* ..
+* .. Local Scalars ..
+ INTEGER I, KBOT, NMIN, LLDH, LLDZ, ICTXT, NPROW, NPCOL,
+ $ MYROW, MYCOL, HROWS, HCOLS, IPW, NH, NB,
+ $ II, JJ, HRSRC, HCSRC, NPROCS, ILOC1, JLOC1,
+ $ HRSRC1, HCSRC1, K, ILOC2, JLOC2, ILOC3, JLOC3,
+ $ ILOC4, JLOC4, HRSRC2, HCSRC2, HRSRC3, HCSRC3,
+ $ HRSRC4, HCSRC4, LIWKOPT
+ LOGICAL INITZ, LQUERY, WANTT, WANTZ, PAIR, BORDER
+ DOUBLE PRECISION TMP1, TMP2, TMP3, TMP4, DUM1, DUM2, DUM3,
+ $ DUM4, ELEM1, ELEM2, ELEM3, ELEM4,
+ $ CS, SN, ELEM5, TMP, LWKOPT
+* ..
+* .. Local Arrays ..
+ INTEGER DESCH2( DLEN_ )
+* ..
+* .. External Functions ..
+ INTEGER PILAENVX, NUMROC, ICEIL
+ LOGICAL LSAME
+ EXTERNAL PILAENVX, LSAME, NUMROC, ICEIL
+* ..
+* .. External Subroutines ..
+ EXTERNAL PDLACPY, PDLAQR1, PDLAQR0, PDLASET, PXERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC DBLE, MAX, MIN
+* ..
+* .. Executable Statements ..
+*
+* Decode and check the input parameters.
+*
+ INFO = 0
+ ICTXT = DESCH( CTXT_ )
+ CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL )
+ NPROCS = NPROW*NPCOL
+ IF( NPROW.EQ.-1 ) INFO = -(600+CTXT_)
+ IF( INFO.EQ.0 ) THEN
+ WANTT = LSAME( JOB, 'S' )
+ INITZ = LSAME( COMPZ, 'I' )
+ WANTZ = INITZ .OR. LSAME( COMPZ, 'V' )
+ LLDH = DESCH( LLD_ )
+ LLDZ = DESCZ( LLD_ )
+ NB = DESCH( MB_ )
+ LQUERY = ( LWORK.EQ.-1 .OR. LIWORK.EQ.-1 )
+*
+ 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
+ ELSEIF( DESCZ( CTXT_ ).NE.DESCH( CTXT_ ) ) THEN
+ INFO = -( 1000+CTXT_ )
+ ELSEIF( DESCH( MB_ ).NE.DESCH( NB_ ) ) THEN
+ INFO = -( 700+NB_ )
+ ELSEIF( DESCZ( MB_ ).NE.DESCZ( NB_ ) ) THEN
+ INFO = -( 1000+NB_ )
+ ELSEIF( DESCH( MB_ ).NE.DESCZ( MB_ ) ) THEN
+ INFO = -( 1000+MB_ )
+ ELSEIF( DESCH( MB_ ).LT.6 ) THEN
+ INFO = -( 700+NB_ )
+ ELSEIF( DESCZ( MB_ ).LT.6 ) THEN
+ INFO = -( 1000+MB_ )
+ ELSE
+ CALL CHK1MAT( N, 3, N, 3, 1, 1, DESCH, 7, INFO )
+ IF( INFO.EQ.0 )
+ $ CALL CHK1MAT( N, 3, N, 3, 1, 1, DESCZ, 11, INFO )
+ IF( INFO.EQ.0 )
+ $ CALL PCHK2MAT( N, 3, N, 3, 1, 1, DESCH, 7, N, 3, N, 3,
+ $ 1, 1, DESCZ, 11, 0, IWORK, IWORK, INFO )
+ END IF
+ END IF
+*
+* Compute required workspace.
+*
+ CALL PDLAQR1( WANTT, WANTZ, N, ILO, IHI, H, DESCH, WR, WI,
+ $ ILO, IHI, Z, DESCZ, WORK, -1, IWORK, -1, INFO )
+ LWKOPT = WORK(1)
+ LIWKOPT = IWORK(1)
+ CALL PDLAQR0( WANTT, WANTZ, N, ILO, IHI, H, DESCH, WR, WI,
+ $ ILO, IHI, Z, DESCZ, WORK, -1, IWORK, -1, INFO, 0 )
+ IF( N.LT.NL ) THEN
+ HROWS = NUMROC( NL, NB, MYROW, DESCH(RSRC_), NPROW )
+ HCOLS = NUMROC( NL, NB, MYCOL, DESCH(CSRC_), NPCOL )
+ WORK(1) = WORK(1) + DBLE(2*HROWS*HCOLS)
+ END IF
+ LWKOPT = MAX( LWKOPT, WORK(1) )
+ LIWKOPT = MAX( LIWKOPT, IWORK(1) )
+ WORK(1) = LWKOPT
+ IWORK(1) = LIWKOPT
+*
+ IF( .NOT.LQUERY .AND. LWORK.LT.INT(LWKOPT) ) THEN
+ INFO = -13
+ ELSEIF( .NOT.LQUERY .AND. LIWORK.LT.LIWKOPT ) THEN
+ INFO = -15
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+*
+* Quick return in case of invalid argument.
+*
+ CALL PXERBLA( 'PDHSEQR', -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.
+*
+ RETURN
+*
+ ELSE
+*
+* Copy eigenvalues isolated by PDGEBAL.
+*
+ DO 10 I = 1, ILO - 1
+ CALL INFOG2L( I, I, DESCH, NPROW, NPCOL, MYROW, MYCOL, II,
+ $ JJ, HRSRC, HCSRC )
+ IF( MYROW.EQ.HRSRC .AND. MYCOL.EQ.HCSRC ) THEN
+ WR( I ) = H( (JJ-1)*LLDH + II )
+ ELSE
+ WR( I ) = ZERO
+ END IF
+ WI( I ) = ZERO
+ 10 CONTINUE
+ IF( ILO.GT.1 )
+ $ CALL DGSUM2D( ICTXT, 'All', '1-Tree', ILO-1, 1, WR, N, -1,
+ $ -1 )
+ DO 20 I = IHI + 1, N
+ CALL INFOG2L( I, I, DESCH, NPROW, NPCOL, MYROW, MYCOL, II,
+ $ JJ, HRSRC, HCSRC )
+ IF( MYROW.EQ.HRSRC .AND. MYCOL.EQ.HCSRC ) THEN
+ WR( I ) = H( (JJ-1)*LLDH + II )
+ ELSE
+ WR( I ) = ZERO
+ END IF
+ WI( I ) = ZERO
+ 20 CONTINUE
+ IF( IHI.LT.N )
+ $ CALL DGSUM2D( ICTXT, 'All', '1-Tree', N-IHI, 1, WR(IHI+1),
+ $ N, -1, -1 )
+*
+* Initialize Z, if requested.
+*
+ IF( INITZ )
+ $ CALL PDLASET( 'A', N, N, ZERO, ONE, Z, 1, 1, DESCZ )
+*
+* Quick return if possible.
+*
+ NPROCS = NPROW*NPCOL
+ IF( ILO.EQ.IHI ) THEN
+ CALL INFOG2L( ILO, ILO, DESCH, NPROW, NPCOL, MYROW,
+ $ MYCOL, II, JJ, HRSRC, HCSRC )
+ IF( MYROW.EQ.HRSRC .AND. MYCOL.EQ.HCSRC ) THEN
+ WR( ILO ) = H( (JJ-1)*LLDH + II )
+ IF( NPROCS.GT.1 )
+ $ CALL DGEBS2D( ICTXT, 'All', '1-Tree', 1, 1, WR(ILO),
+ $ 1 )
+ ELSE
+ CALL DGEBR2D( ICTXT, 'All', '1-Tree', 1, 1, WR(ILO),
+ $ 1, HRSRC, HCSRC )
+ END IF
+ WI( ILO ) = ZERO
+ RETURN
+ END IF
+*
+* PDLAQR1/PDLAQR0 crossover point.
+*
+ NH = IHI-ILO+1
+ NMIN = PILAENVX( ICTXT, 12, 'PDHSEQR',
+ $ JOB( : 1 ) // COMPZ( : 1 ), N, ILO, IHI, LWORK )
+ NMIN = MAX( NTINY, NMIN )
+*
+* PDLAQR0 for big matrices; PDLAQR1 for small ones.
+*
+ IF( (.NOT. CRSOVER .AND. NH.GT.NTINY) .OR. NH.GT.NMIN .OR.
+ $ DESCH(RSRC_).NE.0 .OR. DESCH(CSRC_).NE.0 ) THEN
+ CALL PDLAQR0( WANTT, WANTZ, N, ILO, IHI, H, DESCH, WR, WI,
+ $ ILO, IHI, Z, DESCZ, WORK, LWORK, IWORK, LIWORK, INFO,
+ $ 0 )
+ IF( INFO.GT.0 .AND. ( DESCH(RSRC_).NE.0 .OR.
+ $ DESCH(CSRC_).NE.0 ) ) THEN
+*
+* A rare PDLAQR0 failure! PDLAQR1 sometimes succeeds
+* when PDLAQR0 fails.
+*
+ KBOT = INFO
+ CALL PDLAQR1( WANTT, WANTZ, N, ILO, IHI, H, DESCH, WR,
+ $ WI, ILO, IHI, Z, DESCZ, WORK, LWORK, IWORK,
+ $ LIWORK, INFO )
+ INFO = -7777
+ END IF
+ ELSE
+*
+* Small matrix.
+*
+ CALL PDLAQR1( WANTT, WANTZ, N, ILO, IHI, H, DESCH, WR, WI,
+ $ ILO, IHI, Z, DESCZ, WORK, LWORK, IWORK, LIWORK, INFO )
+*
+ IF( INFO.GT.0 ) THEN
+*
+* A rare PDLAQR1 failure! PDLAQR0 sometimes succeeds
+* when PDLAQR1 fails.
+*
+ KBOT = INFO
+*
+ IF( N.GE.NL ) THEN
+*
+* Larger matrices have enough subdiagonal scratch
+* space to call PDLAQR0 directly.
+*
+ CALL PDLAQR0( WANTT, WANTZ, N, ILO, KBOT, H, DESCH,
+ $ WR, WI, ILO, IHI, Z, DESCZ, WORK, LWORK,
+ $ IWORK, LIWORK, INFO, 0 )
+ ELSE
+*
+* Tiny matrices don't have enough subdiagonal
+* scratch space to benefit from PDLAQR0. Hence,
+* tiny matrices must be copied into a larger
+* array before calling PDLAQR0.
+*
+ HROWS = NUMROC( NL, NB, MYROW, DESCH(RSRC_), NPROW )
+ HCOLS = NUMROC( NL, NB, MYCOL, DESCH(CSRC_), NPCOL )
+ CALL DESCINIT( DESCH2, NL, NL, NB, NB, DESCH(RSRC_),
+ $ DESCH(CSRC_), ICTXT, MAX(1, HROWS), INFO )
+ CALL PDLACPY( 'All', N, N, H, 1, 1, DESCH, WORK, 1,
+ $ 1, DESCH2 )
+ CALL PDELSET( WORK, N+1, N, DESCH2, ZERO )
+ CALL PDLASET( 'All', NL, NL-N, ZERO, ZERO, WORK, 1,
+ $ N+1, DESCH2 )
+ IPW = 1 + DESCH2(LLD_)*HCOLS
+ CALL PDLAQR0( WANTT, WANTZ, NL, ILO, KBOT, WORK,
+ $ DESCH2, WR, WI, ILO, IHI, Z, DESCZ,
+ $ WORK(IPW), LWORK-IPW+1, IWORK,
+ $ LIWORK, INFO, 0 )
+ IF( WANTT .OR. INFO.NE.0 )
+ $ CALL PDLACPY( 'All', N, N, WORK, 1, 1, DESCH2,
+ $ H, 1, 1, DESCH )
+ END IF
+ INFO = -8888
+ END IF
+ END IF
+*
+* Clear out the trash, if necessary.
+*
+ IF( ( WANTT .OR. INFO.NE.0 ) .AND. N.GT.2 )
+ $ CALL PDLASET( 'L', N-2, N-2, ZERO, ZERO, H, 3, 1, DESCH )
+*
+* Force any 2-by-2 blocks to be complex conjugate pairs of
+* eigenvalues by removing false such blocks.
+*
+ DO 30 I = ILO, IHI-1
+ CALL PDELGET( 'All', ' ', TMP3, H, I+1, I, DESCH )
+ IF( TMP3.NE.0.0D+00 ) THEN
+ CALL PDELGET( 'All', ' ', TMP1, H, I, I, DESCH )
+ CALL PDELGET( 'All', ' ', TMP2, H, I, I+1, DESCH )
+ CALL PDELGET( 'All', ' ', TMP4, H, I+1, I+1, DESCH )
+ CALL DLANV2( TMP1, TMP2, TMP3, TMP4, DUM1, DUM2, DUM3,
+ $ DUM4, CS, SN )
+ IF( TMP3.EQ.0.0D+00 ) THEN
+ IF( WANTT ) THEN
+ IF( I+2.LE.N )
+ $ CALL PDROT( N-I-1, H, I, I+2, DESCH,
+ $ DESCH(M_), H, I+1, I+2, DESCH, DESCH(M_),
+ $ CS, SN, WORK, LWORK, INFO )
+ CALL PDROT( I-1, H, 1, I, DESCH, 1, H, 1, I+1,
+ $ DESCH, 1, CS, SN, WORK, LWORK, INFO )
+ END IF
+ IF( WANTZ ) THEN
+ CALL PDROT( N, Z, 1, I, DESCZ, 1, Z, 1, I+1, DESCZ,
+ $ 1, CS, SN, WORK, LWORK, INFO )
+ END IF
+ CALL PDELSET( H, I, I, DESCH, TMP1 )
+ CALL PDELSET( H, I, I+1, DESCH, TMP2 )
+ CALL PDELSET( H, I+1, I, DESCH, TMP3 )
+ CALL PDELSET( H, I+1, I+1, DESCH, TMP4 )
+ END IF
+ END IF
+ 30 CONTINUE
+*
+* Read out eigenvalues: first let all the processes compute the
+* eigenvalue inside their diagonal blocks in parallel, except for
+* the eigenvalue located next to a block border. After that,
+* compute all eigenvalues located next to the block borders.
+* Finally, do a global summation over WR and WI so that all
+* processors receive the result.
+*
+ DO 40 K = ILO, IHI
+ WR( K ) = ZERO
+ WI( K ) = ZERO
+ 40 CONTINUE
+ NB = DESCH( MB_ )
+*
+* Loop 50: extract eigenvalues from the blocks which are not laid
+* out across a border of the processor mesh, except for those 1x1
+* blocks on the border.
+*
+ PAIR = .FALSE.
+ DO 50 K = ILO, IHI
+ IF( .NOT. PAIR ) THEN
+ BORDER = MOD( K, NB ).EQ.0 .OR. ( K.NE.1 .AND.
+ $ MOD( K, NB ).EQ.1 )
+ IF( .NOT. BORDER ) THEN
+ CALL INFOG2L( K, K, DESCH, NPROW, NPCOL, MYROW,
+ $ MYCOL, ILOC1, JLOC1, HRSRC1, HCSRC1 )
+ IF( MYROW.EQ.HRSRC1 .AND. MYCOL.EQ.HCSRC1 ) THEN
+ ELEM1 = H((JLOC1-1)*LLDH+ILOC1)
+ IF( K.LT.N ) THEN
+ ELEM3 = H((JLOC1-1)*LLDH+ILOC1+1)
+ ELSE
+ ELEM3 = ZERO
+ END IF
+ IF( ELEM3.NE.ZERO ) THEN
+ ELEM2 = H((JLOC1)*LLDH+ILOC1)
+ ELEM4 = H((JLOC1)*LLDH+ILOC1+1)
+ CALL DLANV2( ELEM1, ELEM2, ELEM3, ELEM4,
+ $ WR( K ), WI( K ), WR( K+1 ), WI( K+1 ),
+ $ SN, CS )
+ PAIR = .TRUE.
+ ELSE
+ IF( K.GT.1 ) THEN
+ TMP = H((JLOC1-2)*LLDH+ILOC1)
+ IF( TMP.NE.ZERO ) THEN
+ ELEM1 = H((JLOC1-2)*LLDH+ILOC1-1)
+ ELEM2 = H((JLOC1-1)*LLDH+ILOC1-1)
+ ELEM3 = H((JLOC1-2)*LLDH+ILOC1)
+ ELEM4 = H((JLOC1-1)*LLDH+ILOC1)
+ CALL DLANV2( ELEM1, ELEM2, ELEM3,
+ $ ELEM4, WR( K-1 ), WI( K-1 ),
+ $ WR( K ), WI( K ), SN, CS )
+ ELSE
+ WR( K ) = ELEM1
+ END IF
+ ELSE
+ WR( K ) = ELEM1
+ END IF
+ END IF
+ END IF
+ END IF
+ ELSE
+ PAIR = .FALSE.
+ END IF
+ 50 CONTINUE
+*
+* Loop 60: extract eigenvalues from the blocks which are laid
+* out across a border of the processor mesh. The processors are
+* numbered as below:
+*
+* 1 | 2
+* --+--
+* 3 | 4
+*
+ DO 60 K = ICEIL(ILO,NB)*NB, IHI-1, NB
+ CALL INFOG2L( K, K, DESCH, NPROW, NPCOL, MYROW, MYCOL,
+ $ ILOC1, JLOC1, HRSRC1, HCSRC1 )
+ CALL INFOG2L( K, K+1, DESCH, NPROW, NPCOL, MYROW, MYCOL,
+ $ ILOC2, JLOC2, HRSRC2, HCSRC2 )
+ CALL INFOG2L( K+1, K, DESCH, NPROW, NPCOL, MYROW, MYCOL,
+ $ ILOC3, JLOC3, HRSRC3, HCSRC3 )
+ CALL INFOG2L( K+1, K+1, DESCH, NPROW, NPCOL, MYROW, MYCOL,
+ $ ILOC4, JLOC4, HRSRC4, HCSRC4 )
+ IF( MYROW.EQ.HRSRC2 .AND. MYCOL.EQ.HCSRC2 ) THEN
+ ELEM2 = H((JLOC2-1)*LLDH+ILOC2)
+ IF( HRSRC1.NE.HRSRC2 .OR. HCSRC1.NE.HCSRC2 )
+ $ CALL DGESD2D( ICTXT, 1, 1, ELEM2, 1, HRSRC1, HCSRC1)
+ END IF
+ IF( MYROW.EQ.HRSRC3 .AND. MYCOL.EQ.HCSRC3 ) THEN
+ ELEM3 = H((JLOC3-1)*LLDH+ILOC3)
+ IF( HRSRC1.NE.HRSRC3 .OR. HCSRC1.NE.HCSRC3 )
+ $ CALL DGESD2D( ICTXT, 1, 1, ELEM3, 1, HRSRC1, HCSRC1)
+ END IF
+ IF( MYROW.EQ.HRSRC4 .AND. MYCOL.EQ.HCSRC4 ) THEN
+ WORK(1) = H((JLOC4-1)*LLDH+ILOC4)
+ IF( K+1.LT.N ) THEN
+ WORK(2) = H((JLOC4-1)*LLDH+ILOC4+1)
+ ELSE
+ WORK(2) = ZERO
+ END IF
+ IF( HRSRC1.NE.HRSRC4 .OR. HCSRC1.NE.HCSRC4 )
+ $ CALL DGESD2D( ICTXT, 2, 1, WORK, 2, HRSRC1, HCSRC1 )
+ END IF
+ IF( MYROW.EQ.HRSRC1 .AND. MYCOL.EQ.HCSRC1 ) THEN
+ ELEM1 = H((JLOC1-1)*LLDH+ILOC1)
+ IF( HRSRC1.NE.HRSRC2 .OR. HCSRC1.NE.HCSRC2 )
+ $ CALL DGERV2D( ICTXT, 1, 1, ELEM2, 1, HRSRC2, HCSRC2)
+ IF( HRSRC1.NE.HRSRC3 .OR. HCSRC1.NE.HCSRC3 )
+ $ CALL DGERV2D( ICTXT, 1, 1, ELEM3, 1, HRSRC3, HCSRC3)
+ IF( HRSRC1.NE.HRSRC4 .OR. HCSRC1.NE.HCSRC4 )
+ $ CALL DGERV2D( ICTXT, 2, 1, WORK, 2, HRSRC4, HCSRC4 )
+ ELEM4 = WORK(1)
+ ELEM5 = WORK(2)
+ IF( ELEM5.EQ.ZERO ) THEN
+ IF( WR( K ).EQ.ZERO .AND. WI( K ).EQ.ZERO ) THEN
+ CALL DLANV2( ELEM1, ELEM2, ELEM3, ELEM4, WR( K ),
+ $ WI( K ), WR( K+1 ), WI( K+1 ), SN, CS )
+ ELSEIF( WR( K+1 ).EQ.ZERO .AND. WI( K+1 ).EQ.ZERO )
+ $ THEN
+ WR( K+1 ) = ELEM4
+ END IF
+ ELSEIF( WR( K ).EQ.ZERO .AND. WI( K ).EQ.ZERO )
+ $ THEN
+ WR( K ) = ELEM1
+ END IF
+ END IF
+ 60 CONTINUE
+*
+ IF( NPROCS.GT.1 ) THEN
+ CALL DGSUM2D( ICTXT, 'All', ' ', IHI-ILO+1, 1, WR(ILO), N,
+ $ -1, -1 )
+ CALL DGSUM2D( ICTXT, 'All', ' ', IHI-ILO+1, 1, WI(ILO), N,
+ $ -1, -1 )
+ END IF
+*
+ END IF
+*
+ WORK(1) = LWKOPT
+ IWORK(1) = LIWKOPT
+ RETURN
+*
+* End of PDHSEQR
+*
+ END
diff --git a/SRC/pdlabad.f b/SRC/pdlabad.f
index 84df34b..4fd00d8 100644
--- a/SRC/pdlabad.f
+++ b/SRC/pdlabad.f
@@ -62,6 +62,7 @@
SMALL = SQRT( SMALL )
LARGE = SQRT( LARGE )
END IF
+ IDUMM = 0
*
CALL DGAMX2D( ICTXT, 'All', ' ', 1, 1, SMALL, 1, IDUMM,
$ IDUMM, -1, -1, IDUMM )
diff --git a/SRC/pdlacp2.f b/SRC/pdlacp2.f
index 48c067e..dc7b44c 100644
--- a/SRC/pdlacp2.f
+++ b/SRC/pdlacp2.f
@@ -1,10 +1,9 @@
SUBROUTINE PDLACP2( UPLO, M, N, A, IA, JA, DESCA, B, IB, JB,
$ DESCB )
*
-* -- ScaLAPACK auxiliary routine (version 1.7) --
-* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
-* and University of California, Berkeley.
-* November 15, 1997
+* -- ScaLAPACK routine (version 2.0.2) --
+* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver
+* May 1 2012
*
* .. Scalar Arguments ..
CHARACTER UPLO
@@ -157,7 +156,7 @@
$ NQ, NQAA, WIDE
* ..
* .. External Subroutines ..
- EXTERNAL BLACS_GRIDINFO, DLACPY, INFOG2L
+ EXTERNAL BLACS_GRIDINFO, DLAMOV, INFOG2L
* ..
* .. External Functions ..
LOGICAL LSAME
@@ -247,7 +246,7 @@
*
10 CONTINUE
IF( ( N-ITOP ).GT.0 ) THEN
- CALL DLACPY( UPLO, IINXTA-IIBEGA+1, N-ITOP,
+ CALL DLAMOV( UPLO, IINXTA-IIBEGA+1, N-ITOP,
$ A( IIBEGA+(JJA+ITOP-1)*LDA ), LDA,
$ B( IIBEGB+(JJB+ITOP-1)*LDB ), LDB )
MYDIST = MYDIST + NPROW
@@ -272,10 +271,10 @@
20 CONTINUE
IF( JJAA.LE.( JJA+N-1 ) ) THEN
HEIGHT = IBASE - ITOP
- CALL DLACPY( 'All', MPAA, ITOP-JJAA+JJA,
+ CALL DLAMOV( 'All', MPAA, ITOP-JJAA+JJA,
$ A( IIAA+(JJAA-1)*LDA ), LDA,
$ B( IIBB+(JJBB-1)*LDB ), LDB )
- CALL DLACPY( UPLO, MPAA, HEIGHT,
+ CALL DLAMOV( UPLO, MPAA, HEIGHT,
$ A( IIAA+(JJA+ITOP-1)*LDA ), LDA,
$ B( IIBB+(JJB+ITOP-1)*LDB ), LDB )
MPAA = MAX( 0, MPAA - HEIGHT )
@@ -292,7 +291,7 @@
*
ELSE
*
- CALL DLACPY( 'All', MP, N, A( IIA+(JJA-1)*LDA ),
+ CALL DLAMOV( 'All', MP, N, A( IIA+(JJA-1)*LDA ),
$ LDA, B( IIB+(JJB-1)*LDB ), LDB )
*
END IF
@@ -345,7 +344,7 @@
*
30 CONTINUE
IF( ( M-ILEFT ).GT.0 ) THEN
- CALL DLACPY( UPLO, M-ILEFT, JJNXTA-JJBEGA+1,
+ CALL DLAMOV( UPLO, M-ILEFT, JJNXTA-JJBEGA+1,
$ A( IIA+ILEFT+(JJBEGA-1)*LDA ), LDA,
$ B( IIB+ILEFT+(JJBEGB-1)*LDB ), LDB )
MYDIST = MYDIST + NPCOL
@@ -370,10 +369,10 @@
40 CONTINUE
IF( IIAA.LE.( IIA+M-1 ) ) THEN
WIDE = IRIGHT - ILEFT
- CALL DLACPY( 'All', ILEFT-IIAA+IIA, NQAA,
+ CALL DLAMOV( 'All', ILEFT-IIAA+IIA, NQAA,
$ A( IIAA+(JJAA-1)*LDA ), LDA,
$ B( IIBB+(JJBB-1)*LDB ), LDB )
- CALL DLACPY( UPLO, WIDE, NQAA,
+ CALL DLAMOV( UPLO, WIDE, NQAA,
$ A( IIA+ILEFT+(JJAA-1)*LDA ), LDA,
$ B( IIB+ILEFT+(JJBB-1)*LDB ), LDB )
NQAA = MAX( 0, NQAA - WIDE )
@@ -390,7 +389,7 @@
*
ELSE
*
- CALL DLACPY( 'All', M, NQ, A( IIA+(JJA-1)*LDA ),
+ CALL DLAMOV( 'All', M, NQ, A( IIA+(JJA-1)*LDA ),
$ LDA, B( IIB+(JJB-1)*LDB ), LDB )
*
END IF
diff --git a/SRC/pdlacp3.f b/SRC/pdlacp3.f
index a4d7d0e..3b1aa0e 100644
--- a/SRC/pdlacp3.f
+++ b/SRC/pdlacp3.f
@@ -1,4 +1,5 @@
SUBROUTINE PDLACP3( M, I, A, DESCA, B, LDB, II, JJ, REV )
+ IMPLICIT NONE
*
* -- ScaLAPACK routine (version 1.7) --
* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
@@ -141,9 +142,10 @@
PARAMETER ( ZERO = 0.0D+0 )
* ..
* .. Local Scalars ..
- INTEGER COL, CONTXT, HBL, ICOL1, ICOL2, IDI, IDJ, IFIN,
- $ III, IROW1, IROW2, ISTOP, ISTOPI, ISTOPJ, ITMP,
- $ JJJ, LDA, MYCOL, MYROW, NPCOL, NPROW, ROW
+ INTEGER COL, CONTXT, HBL, IAFIRST, ICOL1, ICOL2, IDI,
+ $ IDJ, IFIN, III, IROW1, IROW2, ISTOP, ISTOPI,
+ $ ISTOPJ, ITMP, JAFIRST, JJJ, LDA, MYCOL, MYROW,
+ $ NPCOL, NPROW, ROW
* ..
* .. External Functions ..
INTEGER NUMROC
@@ -164,6 +166,8 @@
HBL = DESCA( MB_ )
CONTXT = DESCA( CTXT_ )
LDA = DESCA( LLD_ )
+ IAFIRST = DESCA( RSRC_ )
+ JAFIRST = DESCA( CSRC_ )
*
CALL BLACS_GRIDINFO( CONTXT, NPROW, NPCOL, MYROW, MYCOL )
*
@@ -190,12 +194,12 @@
ISTOPI = ISTOP
IF( IDI.LE.IFIN ) THEN
40 CONTINUE
- ROW = MOD( ( IDI-1 ) / HBL, NPROW )
- COL = MOD( ( IDJ-1 ) / HBL, NPCOL )
- CALL INFOG1L( IDI, HBL, NPROW, ROW, 0, IROW1, ITMP )
- IROW2 = NUMROC( ISTOPI, HBL, ROW, 0, NPROW )
- CALL INFOG1L( IDJ, HBL, NPCOL, COL, 0, ICOL1, ITMP )
- ICOL2 = NUMROC( ISTOPJ, HBL, COL, 0, NPCOL )
+ ROW = MOD( ( IDI-1 ) / HBL + IAFIRST, NPROW )
+ COL = MOD( ( IDJ-1 ) / HBL + JAFIRST, NPCOL )
+ CALL INFOG1L( IDI, HBL, NPROW, ROW, IAFIRST, IROW1, ITMP )
+ IROW2 = NUMROC( ISTOPI, HBL, ROW, IAFIRST, NPROW )
+ CALL INFOG1L( IDJ, HBL, NPCOL, COL, JAFIRST, ICOL1, ITMP )
+ ICOL2 = NUMROC( ISTOPJ, HBL, COL, JAFIRST, NPCOL )
IF( ( MYROW.EQ.ROW ) .AND. ( MYCOL.EQ.COL ) ) THEN
IF( ( II.EQ.-1 ) .AND. ( JJ.EQ.-1 ) ) THEN
*
diff --git a/SRC/pdlahqr.f b/SRC/pdlahqr.f
index 6393898..7d857dd 100644
--- a/SRC/pdlahqr.f
+++ b/SRC/pdlahqr.f
@@ -2,13 +2,9 @@
$ ILOZ, IHIZ, Z, DESCZ, WORK, LWORK, IWORK,
$ ILWORK, INFO )
*
-* -- ScaLAPACK routine (version 1.7.3) --
-* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
-* and University of California, Berkeley.
-* 1.7.3: March 22, 2006
-* modification suggested by Mark Fahey and Greg Henry
-* 1.7.1: January 30, 2006
-* 1.7.0: December 31, 1998
+* -- ScaLAPACK routine (version 2.0.2) --
+* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver
+* May 1 2012
*
* .. Scalar Arguments ..
LOGICAL WANTT, WANTZ
@@ -259,7 +255,7 @@
DOUBLE PRECISION AVE, DISC, H00, H10, H11, H12, H21, H22, H33,
$ H43H34, H44, OVFL, S, SMLNUM, SUM, T1, T1COPY,
$ T2, T3, ULP, UNFL, V1SAVE, V2, V2SAVE, V3,
- $ V3SAVE
+ $ V3SAVE, CS, SN
* ..
* .. Local Arrays ..
INTEGER ICURCOL( IBLK ), ICURROW( IBLK ), K1( IBLK ),
@@ -278,7 +274,7 @@
$ DGERV2D, DGESD2D, DGSUM2D, DLAHQR, DLAREF,
$ DLARFG, DLASORTE, IGAMN2D, INFOG1L, INFOG2L,
$ PDLABAD, PDLACONSB, PDLACP3, PDLASMSUB,
- $ PDLAWIL, PXERBLA
+ $ PDLAWIL, PXERBLA, DLANV2
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, MIN, MOD, SIGN, SQRT
@@ -523,14 +519,24 @@
* Look for two consecutive small subdiagonal elements:
* PDLACONSB is the routine that does this.
*
- CALL PDLACONSB( A, DESCA, I, L, M, H44, H33, H43H34,
- $ WORK( IRBUF+1 ), LWORK-IRBUF )
+c CALL PDLACONSB( A, DESCA, I, L, M, H44, H33, H43H34,
+c $ WORK( IRBUF+1 ), LWORK-IRBUF )
*
* Skip small submatrices
*
* IF ( M .GE. I - 5 )
* $ GO TO 80
*
+* In principle PDLACONSB needs to check all shifts to decide
+* whether two consecutive small subdiagonal entries are suitable
+* as the starting position of the bulge chasing phase. It can be
+* dangerous to check the first pair of shifts only. Moreover it
+* is quite rare to obtain an M which is much larger than L. This
+* process is a bit expensive compared with the benefit.
+* Therefore it is sensible to abandon this routine. Total amount
+* of communications is saved in average.
+*
+ M = L
* Double-shift QR step
*
* NBULGE is the number of bulges that will be attempted
@@ -2016,79 +2022,18 @@
*
* H(I-1,I-2) is negligible: a pair of eigenvalues have converged.
*
- WR( I-1 ) = ZERO
- WR( I ) = ZERO
- WI( I-1 ) = ZERO
- WI( I ) = ZERO
- MODKM1 = MOD( I-1+HBL, HBL )
- CALL INFOG2L( I-1, I-1, DESCA, NPROW, NPCOL, MYROW, MYCOL,
- $ IROW1, ICOL1, II, JJ )
- IF( ( MYROW.EQ.II ) .AND. ( MYCOL.EQ.JJ ) ) THEN
- H11 = A( ( ICOL1-1 )*LDA+IROW1 )
- IF( MODKM1.NE.0 ) THEN
- H21 = A( ( ICOL1-1 )*LDA+IROW1+1 )
- H12 = A( ICOL1*LDA+IROW1 )
- H22 = A( ICOL1*LDA+IROW1+1 )
- ELSE
- IF( NPROW.GT.1 ) THEN
- CALL DGERV2D( CONTXT, 1, 1, H21, 1, DOWN, MYCOL )
- ELSE
- H21 = A( ( ICOL1-1 )*LDA+IROW1+1 )
- END IF
- IF( NPCOL.GT.1 ) THEN
- CALL DGERV2D( CONTXT, 1, 1, H12, 1, MYROW, RIGHT )
- ELSE
- H12 = A( ICOL1*LDA+IROW1 )
- END IF
- IF( NUM.GT.1 ) THEN
- CALL DGERV2D( CONTXT, 1, 1, H22, 1, DOWN, RIGHT )
- ELSE
- H22 = A( ICOL1*LDA+IROW1+1 )
- END IF
- END IF
- H00 = HALF*( H11+H22 )
- H10 = H11*H22 - H12*H21
- ELSE
- IF( MODKM1.EQ.0 ) THEN
- IF( ( NPROW.GT.1 ) .AND. ( MYCOL.EQ.JJ ) .AND.
- $ ( UP.EQ.II ) ) THEN
- CALL INFOG2L( I, I-1, DESCA, NPROW, NPCOL, MYROW,
- $ MYCOL, IROW1, ICOL1, ITMP1, ITMP2 )
- CALL DGESD2D( CONTXT, 1, 1,
- $ A( ( ICOL1-1 )*LDA+IROW1 ), 1, II, JJ )
- END IF
- IF( ( NPCOL.GT.1 ) .AND. ( LEFT.EQ.JJ ) .AND.
- $ ( MYROW.EQ.II ) ) THEN
- CALL INFOG2L( I-1, I, DESCA, NPROW, NPCOL, MYROW,
- $ MYCOL, IROW1, ICOL1, ITMP1, ITMP2 )
- CALL DGESD2D( CONTXT, 1, 1,
- $ A( ( ICOL1-1 )*LDA+IROW1 ), 1, II, JJ )
- END IF
- IF( ( NUM.GT.1 ) .AND. ( LEFT.EQ.JJ ) .AND.
- $ ( UP.EQ.II ) ) THEN
- CALL INFOG2L( I, I, DESCA, NPROW, NPCOL, MYROW, MYCOL,
- $ IROW1, ICOL1, ITMP1, ITMP2 )
- CALL DGESD2D( CONTXT, 1, 1,
- $ A( ( ICOL1-1 )*LDA+IROW1 ), 1, II, JJ )
- END IF
- END IF
- H00 = ZERO
- H10 = ZERO
- END IF
- H21 = H00*H00 - H10
- IF( H21.GE.ZERO ) THEN
- H21 = SQRT( H21 )
- WR( I-1 ) = H00 + H21
- WI( I-1 ) = ZERO
- WR( I ) = H00 - H21
+ CALL PDELGET( 'All', ' ', H11, A, L, L, DESCA )
+ CALL PDELGET( 'All', ' ', H21, A, I, L, DESCA )
+ CALL PDELGET( 'All', ' ', H12, A, L, I, DESCA )
+ CALL PDELGET( 'All', ' ', H22, A, I, I, DESCA )
+ CALL DLANV2( H11, H12, H21, H22, WR( L ), WI( L ), WR( I ),
+ $ WI( I ), CS, SN )
+ IF( NODE .NE. 0 ) THEN
+ WR( L ) = ZERO
+ WR( I ) = ZERO
+ WI( L ) = ZERO
WI( I ) = ZERO
- ELSE
- H21 = SQRT( ABS( H21 ) )
- WR( I-1 ) = H00
- WI( I-1 ) = H21
- WR( I ) = H00
- WI( I ) = -H21
- END IF
+ ENDIF
ELSE
*
* Find the eigenvalues in H(L:I,L:I), L < I-1
diff --git a/SRC/pdlaiect.c b/SRC/pdlaiect.c
index 3bce029..2d43591 100644
--- a/SRC/pdlaiect.c
+++ b/SRC/pdlaiect.c
@@ -19,11 +19,7 @@
#define proto(x) ()
-void pdlasnbt_( ieflag )
-/*
-* .. Scalar Arguments ..
-*/
- int *ieflag;
+void pdlasnbt_( int *ieflag )
{
/*
*
@@ -85,12 +81,7 @@ void pdlasnbt_( ieflag )
#endif
}
-void pdlaiectb_( sigma, n, d, count )
-/*
-* .. Scalar Arguments ..
-*/
- double *sigma, *d;
- int *n, *count;
+void pdlaiectb_( double *sigma, int *n, double *d, int *count )
{
/*
*
@@ -156,12 +147,7 @@ void pdlaiectb_( sigma, n, d, count )
}
}
-void pdlaiectl_( sigma, n, d, count )
-/*
-* .. Scalar Arguments ..
-*/
- double *sigma, *d;
- int *n, *count;
+void pdlaiectl_( double *sigma, int *n, double *d, int *count )
{
/*
*
@@ -227,12 +213,7 @@ void pdlaiectl_( sigma, n, d, count )
}
}
-pdlachkieee_( isieee, rmax, rmin )
-/*
-* .. Scalar Arguments ..
-*/
- double *rmax, *rmin;
- int *isieee;
+void pdlachkieee_( int *isieee, double *rmax, double *rmin )
{
/*
*
diff --git a/SRC/pdlamch.f b/SRC/pdlamch.f
index 1f57e0c..9a3ebb6 100644
--- a/SRC/pdlamch.f
+++ b/SRC/pdlamch.f
@@ -65,6 +65,7 @@
* .. Executable Statements ..
*
TEMP = DLAMCH( CMACH )
+ IDUMM = 0
*
IF( LSAME( CMACH, 'E' ).OR.LSAME( CMACH, 'S' ).OR.
$ LSAME( CMACH, 'M' ).OR.LSAME( CMACH, 'U' ) ) THEN
diff --git a/SRC/pdlamve.f b/SRC/pdlamve.f
new file mode 100644
index 0000000..7686cc5
--- /dev/null
+++ b/SRC/pdlamve.f
@@ -0,0 +1,205 @@
+ SUBROUTINE PDLAMVE( UPLO, M, N, A, IA, JA, DESCA, B, IB, JB,
+ $ DESCB, DWORK )
+*
+* Contribution from the Department of Computing Science and HPC2N,
+* Umea University, Sweden
+*
+* -- ScaLAPACK auxiliary routine (version 2.0.2) --
+* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver
+* May 1 2012
+*
+ IMPLICIT NONE
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER IA, IB, JA, JB, M, N
+* ..
+* .. Array Arguments ..
+ INTEGER DESCA( * ), DESCB( * )
+ DOUBLE PRECISION A( * ), B( * ), DWORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* PDLAMVE copies all or part of a distributed matrix A to another
+* distributed matrix B. There is no alignment assumptions at all
+* except that A and B are of the same size.
+*
+* Notes
+* =====
+*
+* Each global data object is described by an associated description
+* vector. This vector stores the information required to establish
+* the mapping between an object element and its corresponding process
+* and memory location.
+*
+* Let A be a generic term for any 2D block cyclicly distributed array.
+* Such a global array has an associated description vector DESCA.
+* In the following comments, the character _ should be read as
+* "of the global array".
+*
+* NOTATION STORED IN EXPLANATION
+* --------------- -------------- --------------------------------------
+* DTYPE_A(global) DESCA( DTYPE_ )The descriptor type. In this case,
+* DTYPE_A = 1.
+* CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating
+* the BLACS process grid A is distribu-
+* ted over. The context itself is glo-
+* bal, but the handle (the integer
+* value) may vary.
+* M_A (global) DESCA( M_ ) The number of rows in the global
+* array A.
+* N_A (global) DESCA( N_ ) The number of columns in the global
+* array A.
+* MB_A (global) DESCA( MB_ ) The blocking factor used to distribute
+* the rows of the array.
+* NB_A (global) DESCA( NB_ ) The blocking factor used to distribute
+* the columns of the array.
+* RSRC_A (global) DESCA( RSRC_ ) The process row over which the first
+* row of the array A is distributed.
+* CSRC_A (global) DESCA( CSRC_ ) The process column over which the
+* first column of the array A is
+* distributed.
+* LLD_A (local) DESCA( LLD_ ) The leading dimension of the local
+* array. LLD_A >= MAX(1,LOCr(M_A)).
+*
+* Let K be the number of rows or columns of a distributed matrix,
+* and assume that its process grid has dimension p x q.
+* LOCr( K ) denotes the number of elements of K that a process
+* would receive if K were distributed over the p processes of its
+* process column.
+* Similarly, LOCc( K ) denotes the number of elements of K that a
+* process would receive if K were distributed over the q processes of
+* its process row.
+* The values of LOCr() and LOCc() may be determined via a call to the
+* ScaLAPACK tool function, NUMROC:
+* LOCr( M ) = NUMROC( M, MB_A, MYROW, RSRC_A, NPROW ),
+* LOCc( N ) = NUMROC( N, NB_A, MYCOL, CSRC_A, NPCOL ).
+* An upper bound for these quantities may be computed by:
+* LOCr( M ) <= ceil( ceil(M/MB_A)/NPROW )*MB_A
+* LOCc( N ) <= ceil( ceil(N/NB_A)/NPCOL )*NB_A
+*
+* Arguments
+* =========
+*
+* UPLO (global input) CHARACTER
+* Specifies the part of the distributed matrix sub( A ) to be
+* copied:
+* = 'U': Upper triangular part is copied; the strictly
+* lower triangular part of sub( A ) is not referenced;
+* = 'L': Lower triangular part is copied; the strictly
+* upper triangular part of sub( A ) is not referenced;
+* Otherwise: All of the matrix sub( A ) is copied.
+*
+* M (global input) INTEGER
+* The number of rows to be operated on i.e the number of rows
+* of the distributed submatrix sub( A ). M >= 0.
+*
+* N (global input) INTEGER
+* The number of columns to be operated on i.e the number of
+* columns of the distributed submatrix sub( A ). N >= 0.
+*
+* A (local input) DOUBLE PRECISION pointer into the local memory
+* to an array of dimension (LLD_A, LOCc(JA+N-1) ). This array
+* contains the local pieces of the distributed matrix sub( A )
+* to be copied from.
+*
+* IA (global input) INTEGER
+* The row index in the global array A indicating the first
+* row of sub( A ).
+*
+* JA (global input) INTEGER
+* The column index in the global array A indicating the
+* first column of sub( A ).
+*
+* DESCA (global and local input) INTEGER array of dimension DLEN_.
+* The array descriptor for the distributed matrix A.
+*
+* B (local output) DOUBLE PRECISION pointer into the local memory
+* to an array of dimension (LLD_B, LOCc(JB+N-1) ). This array
+* contains on exit the local pieces of the distributed matrix
+* sub( B ).
+*
+* IB (global input) INTEGER
+* The row index in the global array B indicating the first
+* row of sub( B ).
+*
+* JB (global input) INTEGER
+* The column index in the global array B indicating the
+* first column of sub( B ).
+*
+* DESCB (global and local input) INTEGER array of dimension DLEN_.
+* The array descriptor for the distributed matrix B.
+*
+* DWORK (local workspace) DOUBLE PRECISION array
+* If UPLO = 'U' or UPLO = 'L' and number of processors > 1,
+* the length of DWORK is at least as large as the length of B.
+* Otherwise, DWORK is not referenced.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ INTEGER BLOCK_CYCLIC_2D, CSRC_, CTXT_, DLEN_, DTYPE_,
+ $ LLD_, MB_, M_, NB_, N_, RSRC_
+ PARAMETER ( BLOCK_CYCLIC_2D = 1, DLEN_ = 9, DTYPE_ = 1,
+ $ CTXT_ = 2, M_ = 3, N_ = 4, MB_ = 5, NB_ = 6,
+ $ RSRC_ = 7, CSRC_ = 8, LLD_ = 9 )
+* ..
+* .. Local Scalars ..
+ LOGICAL UPPER, LOWER, FULL
+ INTEGER ICTXT, NPROW, NPCOL, MYROW, MYCOL, MYPROC,
+ $ NPROCS, AROWS, ACOLS, K, SPROC, SRSRC, SCSRC,
+ $ RPROC, RRSRC, RCSRC, COUNT, J, I, IIA, JJA,
+ $ IIB, JJB, BRSRC, BCSRC, RAROWS, RACOLS,
+ $ INDEX, IDUM, NUMREC, NUMSND
+* ..
+* .. External Subroutines ..
+ EXTERNAL DLAMOV, INFOG2L
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ INTEGER ICEIL, NUMROC, INDXL2G
+ EXTERNAL ICEIL, LSAME, NUMROC, INDXL2G
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MIN, MOD
+* ..
+* .. Executable Statements ..
+*
+* Find underlying mesh properties.
+*
+ ICTXT = DESCA( CTXT_ )
+ CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL )
+*
+* Decode input parameters.
+*
+ UPPER = LSAME( UPLO, 'U' )
+ IF( .NOT. UPPER ) LOWER = LSAME( UPLO, 'L' )
+ FULL = (.NOT. UPPER) .AND. (.NOT. LOWER)
+*
+* Assign indiviual numbers based on column major ordering.
+*
+ NPROCS = NPROW*NPCOL
+*
+* Do redistribution operation.
+*
+ IF( NPROCS.EQ.1 ) THEN
+ CALL DLAMOV( UPLO, M, N, A((JA-1)*DESCA(LLD_)+IA),
+ $ DESCA(LLD_), B((JB-1)*DESCB(LLD_)+IB),
+ $ DESCB(LLD_) )
+ ELSEIF( FULL ) THEN
+ CALL PDGEMR2D( M, N, A, IA, JA, DESCA, B, IB, JB, DESCB,
+ $ ICTXT )
+ ELSE
+ CALL PDGEMR2D( M, N, A, IA, JA, DESCA, DWORK, IB, JB, DESCB,
+ $ ICTXT )
+ CALL PDLACPY( UPLO, M, N, DWORK, IB, JB, DESCB, B, IB, JB,
+ $ DESCB )
+ END IF
+*
+ RETURN
+*
+* End of PDLAMVE
+*
+ END
diff --git a/SRC/pdlaqr0.f b/SRC/pdlaqr0.f
new file mode 100644
index 0000000..9153500
--- /dev/null
+++ b/SRC/pdlaqr0.f
@@ -0,0 +1,929 @@
+ RECURSIVE SUBROUTINE PDLAQR0( WANTT, WANTZ, N, ILO, IHI, H,
+ $ DESCH, WR, WI, ILOZ, IHIZ, Z, DESCZ, WORK, LWORK,
+ $ IWORK, LIWORK, INFO, RECLEVEL )
+*
+* Contribution from the Department of Computing Science and HPC2N,
+* Umea University, Sweden
+*
+* -- ScaLAPACK auxiliary routine (version 2.0.1) --
+* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
+* Univ. of Colorado Denver and University of California, Berkeley.
+* January, 2012
+*
+ IMPLICIT NONE
+*
+* .. Scalar Arguments ..
+ INTEGER IHI, IHIZ, ILO, ILOZ, INFO, LIWORK, LWORK, N,
+ $ RECLEVEL
+ LOGICAL WANTT, WANTZ
+* ..
+* .. Array Arguments ..
+ INTEGER DESCH( * ), DESCZ( * ), IWORK( * )
+ DOUBLE PRECISION H( * ), WI( N ), WORK( * ), WR( N ),
+ $ Z( * )
+* ..
+*
+* Purpose
+* =======
+*
+* PDLAQR0 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.
+*
+* Notes
+* =====
+*
+* Each global data object is described by an associated description
+* vector. This vector stores the information required to establish
+* the mapping between an object element and its corresponding process
+* and memory location.
+*
+* Let A be a generic term for any 2D block cyclicly distributed array.
+* Such a global array has an associated description vector DESCA.
+* In the following comments, the character _ should be read as
+* "of the global array".
+*
+* NOTATION STORED IN EXPLANATION
+* --------------- -------------- --------------------------------------
+* DTYPE_A(global) DESCA( DTYPE_ )The descriptor type. In this case,
+* DTYPE_A = 1.
+* CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating
+* the BLACS process grid A is distribu-
+* ted over. The context itself is glo-
+* bal, but the handle (the integer
+* value) may vary.
+* M_A (global) DESCA( M_ ) The number of rows in the global
+* array A.
+* N_A (global) DESCA( N_ ) The number of columns in the global
+* array A.
+* MB_A (global) DESCA( MB_ ) The blocking factor used to distribute
+* the rows of the array.
+* NB_A (global) DESCA( NB_ ) The blocking factor used to distribute
+* the columns of the array.
+* RSRC_A (global) DESCA( RSRC_ ) The process row over which the first
+* row of the array A is distributed.
+* CSRC_A (global) DESCA( CSRC_ ) The process column over which the
+* first column of the array A is
+* distributed.
+* LLD_A (local) DESCA( LLD_ ) The leading dimension of the local
+* array. LLD_A >= MAX(1,LOCr(M_A)).
+*
+* Let K be the number of rows or columns of a distributed matrix,
+* and assume that its process grid has dimension p x q.
+* LOCr( K ) denotes the number of elements of K that a process
+* would receive if K were distributed over the p processes of its
+* process column.
+* Similarly, LOCc( K ) denotes the number of elements of K that a
+* process would receive if K were distributed over the q processes of
+* its process row.
+* The values of LOCr() and LOCc() may be determined via a call to the
+* ScaLAPACK tool function, NUMROC:
+* LOCr( M ) = NUMROC( M, MB_A, MYROW, RSRC_A, NPROW ),
+* LOCc( N ) = NUMROC( N, NB_A, MYCOL, CSRC_A, NPCOL ).
+* An upper bound for these quantities may be computed by:
+* LOCr( M ) <= ceil( ceil(M/MB_A)/NPROW )*MB_A
+* LOCc( N ) <= ceil( ceil(N/NB_A)/NPCOL )*NB_A
+*
+* Arguments
+* =========
+*
+* WANTT (global input) LOGICAL
+* = .TRUE. : the full Schur form T is required;
+* = .FALSE.: only eigenvalues are required.
+*
+* WANTZ (global input) LOGICAL
+* = .TRUE. : the matrix of Schur vectors Z is required;
+* = .FALSE.: Schur vectors are not required.
+*
+* N (global input) INTEGER
+* The order of the Hessenberg matrix H (and Z if WANTZ).
+* N >= 0.
+*
+* ILO (global input) INTEGER
+* IHI (global input) INTEGER
+* It is assumed that H is already upper triangular in rows
+* and columns 1:ILO-1 and IHI+1:N. ILO and IHI are normally
+* set by a previous call to PDGEBAL, and then passed to PDGEHRD
+* when the matrix output by PDGEBAL is reduced to Hessenberg
+* form. Otherwise ILO and IHI should be set to 1 and N
+* respectively. If N.GT.0, then 1.LE.ILO.LE.IHI.LE.N.
+* If N = 0, then ILO = 1 and IHI = 0.
+*
+* H (global input/output) DOUBLE PRECISION array, dimension
+* (DESCH(LLD_),*)
+* On entry, the upper Hessenberg matrix H.
+* On exit, if JOB = 'S', H is upper quasi-triangular in
+* rows and columns ILO:IHI, with 1-by-1 and 2-by-2 blocks on
+* the main diagonal. The 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.
+*
+* DESCH (global and local input) INTEGER array of dimension DLEN_.
+* The array descriptor for the distributed matrix H.
+*
+* WR (global output) DOUBLE PRECISION array, dimension (N)
+* WI (global output) DOUBLE PRECISION array, dimension (N)
+* The real and imaginary parts, respectively, of the computed
+* eigenvalues ILO to IHI are stored in the corresponding
+* elements of WR and WI. If two eigenvalues are computed as a
+* complex conjugate pair, they are stored in consecutive
+* elements of WR and WI, say the i-th and (i+1)th, with
+* WI(i) > 0 and WI(i+1) < 0. If JOB = 'S', the
+* eigenvalues are stored in the same order as on the diagonal
+* of the Schur form returned in H.
+*
+* Z (global input/output) DOUBLE PRECISION array.
+* If COMPZ = 'V', on entry Z must contain the current
+* matrix Z of accumulated transformations from, e.g., PDGEHRD,
+* and on exit Z has been updated; transformations are applied
+* only to the submatrix Z(ILO:IHI,ILO:IHI).
+* 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.
+*
+* DESCZ (global and local input) INTEGER array of dimension DLEN_.
+* The array descriptor for the distributed matrix Z.
+*
+* WORK (local workspace) DOUBLE PRECISION array, dimension(DWORK)
+*
+* LWORK (local input) INTEGER
+* The length of the workspace array WORK.
+*
+* IWORK (local workspace) INTEGER array, dimension (LIWORK)
+*
+* LIWORK (local input) INTEGER
+* The length of the workspace array IWORK.
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* .LT. 0: if INFO = -i, the i-th argument had an illegal
+* value
+* .GT. 0: if INFO = i, PDLAQR0 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.
+*
+* ================================================================
+* Based on contributions by
+* Robert Granat, Department of Computing Science and HPC2N,
+* Umea University, Sweden.
+* ================================================================
+*
+* Restrictions: The block size in H and Z must be square and larger
+* than or equal to six (6) due to restrictions in PDLAQR1, PDLAQR5
+* and DLAQR6. Moreover, H and Z need to be distributed identically
+* with the same context.
+*
+* ================================================================
+* References:
+* K. Braman, R. Byers, and R. Mathias,
+* The Multi-Shift QR Algorithm Part I: Maintaining Well Focused
+* Shifts, and Level 3 Performance.
+* SIAM J. Matrix Anal. Appl., 23(4):929--947, 2002.
+*
+* K. Braman, R. Byers, and R. Mathias,
+* The Multi-Shift QR Algorithm Part II: Aggressive Early
+* Deflation.
+* SIAM J. Matrix Anal. Appl., 23(4):948--973, 2002.
+*
+* R. Granat, B. Kagstrom, and D. Kressner,
+* A Novel Parallel QR Algorithm for Hybrid Distributed Momory HPC
+* Systems.
+* SIAM J. Sci. Comput., 32(4):2345--2378, 2010.
+*
+* ================================================================
+*
+* .. Parameters ..
+*
+* ==== Exceptional deflation windows: try to cure rare
+* . slow convergence by increasing the size of the
+* . deflation window after KEXNW iterations. =====
+*
+* ==== Exceptional shifts: try to cure rare slow convergence
+* . with ad-hoc exceptional shifts every KEXSH iterations.
+* . The constants WILK1 and WILK2 are used to form the
+* . exceptional shifts. ====
+*
+ INTEGER BLOCK_CYCLIC_2D, CSRC_, CTXT_, DLEN_, DTYPE_,
+ $ LLD_, MB_, M_, NB_, N_, RSRC_
+ INTEGER RECMAX
+ PARAMETER ( BLOCK_CYCLIC_2D = 1, DLEN_ = 9, DTYPE_ = 1,
+ $ CTXT_ = 2, M_ = 3, N_ = 4, MB_ = 5, NB_ = 6,
+ $ RSRC_ = 7, CSRC_ = 8, LLD_ = 9, RECMAX = 3 )
+ INTEGER NTINY
+ PARAMETER ( NTINY = 11 )
+ INTEGER KEXNW, KEXSH
+ PARAMETER ( KEXNW = 5, KEXSH = 6 )
+ DOUBLE PRECISION WILK1, WILK2
+ PARAMETER ( WILK1 = 0.75D0, WILK2 = -0.4375D0 )
+ DOUBLE PRECISION ZERO, ONE
+ PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 )
+* ..
+* .. Local Scalars ..
+ DOUBLE PRECISION AA, BB, CC, CS, DD, SN, SS, SWAP, ELEM, T0,
+ $ ELEM1, ELEM2, ELEM3, ALPHA, SDSUM, STAMP
+ INTEGER I, J, INF, IT, ITMAX, K, KACC22, KBOT, KDU, KS,
+ $ KT, KTOP, KU, KV, KWH, KWTOP, KWV, LD, LS,
+ $ LWKOPT, NDFL, NH, NHO, NIBBLE, NMIN, NS, NSMAX,
+ $ NSR, NVE, NW, NWMAX, NWR, LLDH, LLDZ, II, JJ,
+ $ ICTXT, NPROW, NPCOL, MYROW, MYCOL, IPV, IPT,
+ $ IPW, IPWRK, VROWS, VCOLS, TROWS, TCOLS, WROWS,
+ $ WCOLS, HRSRC, HCSRC, NB, IS, IE, NPROCS, KK,
+ $ IROFFH, ICOFFH, HRSRC3, HCSRC3, NWIN, TOTIT,
+ $ SWEEP, JW, TOTNS, LIWKOPT, NPMIN, ICTXT_NEW,
+ $ MYROW_NEW, MYCOL_NEW
+ LOGICAL NWINC, SORTED, LQUERY, RECURSION
+ CHARACTER JBCMPZ*2
+* ..
+* .. External Functions ..
+ INTEGER PILAENVX, NUMROC, INDXG2P, ICEIL, BLACS_PNUM
+ EXTERNAL PILAENVX, NUMROC, INDXG2P, ICEIL, BLACS_PNUM
+* ..
+* .. Local Arrays ..
+ INTEGER DESCV( DLEN_ ), DESCT( DLEN_ ), DESCW( DLEN_ ),
+ $ PMAP( 64*64 )
+ DOUBLE PRECISION ZDUM( 1, 1 )
+* ..
+* .. External Subroutines ..
+ EXTERNAL PDLACPY, PDLAQR1, DLANV2, PDLAQR3, PDLAQR5,
+ $ PDELGET, DLAQR0, DLASET, PDGEMR2D
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, DBLE, INT, MAX, MIN, MOD
+* ..
+* .. Executable Statements ..
+ INFO = 0
+ ICTXT = DESCH( CTXT_ )
+ CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL )
+ NPROCS = NPROW*NPCOL
+ RECURSION = RECLEVEL .LT. RECMAX
+*
+* Quick return for N = 0: nothing to do.
+*
+ IF( N.EQ.0 ) THEN
+ WORK( 1 ) = ONE
+ IWORK( 1 ) = 1
+ RETURN
+ END IF
+*
+* Set up job flags for PILAENV.
+*
+ 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
+*
+* Check if workspace query
+*
+ LQUERY = LWORK.EQ.-1 .OR. LIWORK.EQ.-1
+*
+* Extract local leading dimensions and block factors of matrices
+* H and Z
+*
+ LLDH = DESCH( LLD_ )
+ LLDZ = DESCZ( LLD_ )
+ NB = DESCH( MB_ )
+*
+* Tiny (sub-) matrices must use PDLAQR1. (Stops recursion)
+*
+ IF( N.LE.NTINY ) THEN
+*
+* Estimate optimal workspace.
+*
+ CALL PDLAQR1( WANTT, WANTZ, N, ILO, IHI, H, DESCH, WR, WI,
+ $ ILOZ, IHIZ, Z, DESCZ, WORK, LWORK, IWORK, LIWORK, INFO )
+ LWKOPT = INT( WORK(1) )
+ LIWKOPT = IWORK(1)
+*
+* Completely local matrices uses LAPACK. (Stops recursion)
+*
+ ELSEIF( N.LE.NB ) THEN
+ IF( MYROW.EQ.DESCH(RSRC_) .AND. MYCOL.EQ.DESCH(CSRC_) ) THEN
+ CALL DLAQR0( WANTT, WANTZ, N, ILO, IHI, H, DESCH(LLD_),
+ $ WR, WI, ILOZ, IHIZ, Z, DESCZ(LLD_), WORK, LWORK, INFO )
+ IF( N.GT.2 )
+ $ CALL DLASET( 'L', N-2, N-2, ZERO, ZERO, H(3),
+ $ DESCH(LLD_) )
+ LWKOPT = INT( WORK(1) )
+ LIWKOPT = 1
+ ELSE
+ LWKOPT = 1
+ LIWKOPT = 1
+ END IF
+*
+* Do one more step of recursion
+*
+ ELSE
+*
+* Zero out iteration and sweep counters for debugging purposes
+*
+ TOTIT = 0
+ SWEEP = 0
+ TOTNS = 0
+*
+* Use small bulge multi-shift QR with aggressive early
+* deflation on larger-than-tiny matrices.
+*
+* Hope for the best.
+*
+ INFO = 0
+*
+* NWR = recommended deflation window size. At this
+* point, N .GT. NTINY = 11, so there is enough
+* subdiagonal workspace for NWR.GE.2 as required.
+* (In fact, there is enough subdiagonal space for
+* NWR.GE.3.)
+*
+ NWR = PILAENVX( ICTXT, 13, 'PDLAQR0', JBCMPZ, N, ILO, IHI,
+ $ LWORK )
+ NWR = MAX( 2, NWR )
+ NWR = MIN( IHI-ILO+1, NWR )
+ NW = NWR
+*
+* NSR = recommended number of simultaneous shifts.
+* At this point N .GT. NTINY = 11, so there is at
+* enough subdiagonal workspace for NSR to be even
+* and greater than or equal to two as required.
+*
+ NWIN = PILAENVX( ICTXT, 19, 'PDLAQR0', JBCMPZ, N, NB, NB, NB )
+ NSR = PILAENVX( ICTXT, 15, 'PDLAQR0', JBCMPZ, N, ILO, IHI,
+ $ MAX(NWIN,NB) )
+ NSR = MIN( NSR, IHI-ILO )
+ NSR = MAX( 2, NSR-MOD( NSR, 2 ) )
+*
+* Estimate optimal workspace
+*
+ LWKOPT = 3*ICEIL(NWR,NPROW)*ICEIL(NWR,NPCOL)
+*
+* Workspace query call to PDLAQR3
+*
+ CALL PDLAQR3( WANTT, WANTZ, N, ILO, IHI, NWR+1, H,
+ $ DESCH, ILOZ, IHIZ, Z, DESCZ, LS, LD, WR, WI, H,
+ $ DESCH, N, H, DESCH, N, H, DESCH, WORK, -1, IWORK,
+ $ LIWORK, RECLEVEL )
+ LWKOPT = LWKOPT + INT( WORK( 1 ) )
+ LIWKOPT = IWORK( 1 )
+*
+* Workspace query call to PDLAQR5
+*
+ CALL PDLAQR5( WANTT, WANTZ, 2, N, 1, N, N, WR, WI, H,
+ $ DESCH, ILOZ, IHIZ, Z, DESCZ, WORK, -1, IWORK,
+ $ LIWORK )
+*
+* Optimal workspace = MAX(PDLAQR3, PDLAQR5)
+*
+ LWKOPT = MAX( LWKOPT, INT( WORK( 1 ) ) )
+ LIWKOPT = MAX( LIWKOPT, IWORK( 1 ) )
+*
+* Quick return in case of workspace query.
+*
+ IF( LQUERY ) THEN
+ WORK( 1 ) = DBLE( LWKOPT )
+ IWORK( 1 ) = LIWKOPT
+ RETURN
+ END IF
+*
+* PDLAQR1/PDLAQR0 crossover point.
+*
+ NMIN = PILAENVX( ICTXT, 12, 'PDLAQR0', JBCMPZ, N, ILO, IHI,
+ $ LWORK )
+ NMIN = MAX( NTINY, NMIN )
+*
+* Nibble crossover point.
+*
+ NIBBLE = PILAENVX( ICTXT, 14, 'PDLAQR0', JBCMPZ, N, ILO, IHI,
+ $ LWORK )
+ NIBBLE = MAX( 0, NIBBLE )
+*
+* Accumulate reflections during ttswp? Use block
+* 2-by-2 structure during matrix-matrix multiply?
+*
+ KACC22 = PILAENVX( ICTXT, 16, 'PDLAQR0', JBCMPZ, N, ILO, IHI,
+ $ LWORK )
+ KACC22 = MAX( 1, KACC22 )
+ KACC22 = MIN( 2, KACC22 )
+*
+* NWMAX = the largest possible deflation window for
+* which there is sufficient workspace.
+*
+ NWMAX = MIN( ( N-1 ) / 3, LWORK / 2 )
+*
+* NSMAX = the Largest number of simultaneous shifts
+* for which there is sufficient workspace.
+*
+ NSMAX = MIN( ( N+6 ) / 9, LWORK - 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 110 IT = 1, ITMAX
+ TOTIT = TOTIT + 1
+*
+* Done when KBOT falls below ILO.
+*
+ IF( KBOT.LT.ILO )
+ $ GO TO 120
+*
+* Locate active block.
+*
+ DO 10 K = KBOT, ILO + 1, -1
+ CALL INFOG2L( K, K-1, DESCH, NPROW, NPCOL, MYROW, MYCOL,
+ $ II, JJ, HRSRC, HCSRC )
+ IF( MYROW.EQ.HRSRC .AND. MYCOL.EQ.HCSRC ) THEN
+ IF( H( II + (JJ-1)*LLDH ).EQ.ZERO )
+ $ GO TO 20
+ END IF
+ 10 CONTINUE
+ K = ILO
+ 20 CONTINUE
+ KTOP = K
+ IF( NPROCS.GT.1 )
+ $ CALL IGAMX2D( ICTXT, 'All', '1-Tree', 1, 1, KTOP, 1,
+ $ -1, -1, -1, -1, -1 )
+*
+* Select deflation window size.
+*
+ NH = KBOT - KTOP + 1
+ IF( NH.LE.NTINY ) THEN
+ NW = NH
+ ELSEIF( NDFL.LT.KEXNW .OR. NH.LT.NW ) THEN
+*
+* Typical deflation window. If possible and
+* advisable, nibble the entire active block.
+* If not, use size NWR or NWR+1 depending upon
+* which has the smaller corresponding subdiagonal
+* entry (a heuristic).
+*
+ NWINC = .TRUE.
+ IF( NH.LE.MIN( NMIN, NWMAX ) ) THEN
+ NW = NH
+ ELSE
+ NW = MIN( NWR, NH, NWMAX )
+ IF( NW.LT.NWMAX ) THEN
+ IF( NW.GE.NH-1 ) THEN
+ NW = NH
+ ELSE
+ KWTOP = KBOT - NW + 1
+ CALL PDELGET( 'All', '1-Tree', ELEM1, H, KWTOP,
+ $ KWTOP-1, DESCH )
+ CALL PDELGET( 'All', '1-Tree', ELEM2, H,
+ $ KWTOP-1, KWTOP-2, DESCH )
+ IF( ABS( ELEM1 ).GT.ABS( ELEM2 ) ) NW = NW + 1
+ END IF
+ END IF
+ END IF
+ ELSE
+*
+* Exceptional deflation window. If there have
+* been no deflations in KEXNW or more iterations,
+* then vary the deflation window size. At first,
+* because, larger windows are, in general, more
+* powerful than smaller ones, rapidly increase the
+* window up to the maximum reasonable and possible.
+* Then maybe try a slightly smaller window.
+*
+ IF( NWINC .AND. NW.LT.MIN( NWMAX, NH ) ) THEN
+ NW = MIN( NWMAX, NH, 2*NW )
+ ELSE
+ NWINC = .FALSE.
+ IF( NW.EQ.NH .AND. NH.GT.2 )
+ $ NW = NH - 1
+ END IF
+ END IF
+*
+* Aggressive early deflation:
+* split workspace into
+* - an NW-by-NW work array V for orthogonal matrix
+* - an NW-by-at-least-NW-but-more-is-better
+* (NW-by-NHO) horizontal work array for Schur factor
+* - an at-least-NW-but-more-is-better (NVE-by-NW)
+* vertical work array for matrix multiplications
+* - align T, V and W with the deflation window
+*
+ KV = N - NW + 1
+ KT = NW + 1
+ NHO = ( N-NW-1 ) - KT + 1
+ KWV = NW + 2
+ NVE = ( N-NW ) - KWV + 1
+*
+ JW = MIN( NW, KBOT-KTOP+1 )
+ KWTOP = KBOT - JW + 1
+ IROFFH = MOD( KWTOP - 1, NB )
+ ICOFFH = IROFFH
+ HRSRC = INDXG2P( KWTOP, NB, MYROW, DESCH(RSRC_), NPROW )
+ HCSRC = INDXG2P( KWTOP, NB, MYCOL, DESCH(CSRC_), NPCOL )
+ VROWS = NUMROC( JW+IROFFH, NB, MYROW, HRSRC, NPROW )
+ VCOLS = NUMROC( JW+ICOFFH, NB, MYCOL, HCSRC, NPCOL )
+ CALL DESCINIT( DESCV, JW+IROFFH, JW+ICOFFH, NB, NB,
+ $ HRSRC, HCSRC, ICTXT, MAX(1, VROWS), INFO )
+*
+ TROWS = NUMROC( JW+IROFFH, NB, MYROW, HRSRC, NPROW )
+ TCOLS = NUMROC( JW+ICOFFH, NB, MYCOL, HCSRC, NPCOL )
+ CALL DESCINIT( DESCT, JW+IROFFH, JW+ICOFFH, NB, NB,
+ $ HRSRC, HCSRC, ICTXT, MAX(1, TROWS), INFO )
+ WROWS = NUMROC( JW+IROFFH, NB, MYROW, HRSRC, NPROW )
+ WCOLS = NUMROC( JW+ICOFFH, NB, MYCOL, HCSRC, NPCOL )
+ CALL DESCINIT( DESCW, JW+IROFFH, JW+ICOFFH, NB, NB,
+ $ HRSRC, HCSRC, ICTXT, MAX(1, WROWS), INFO )
+*
+ IPV = 1
+ IPT = IPV + DESCV( LLD_ ) * VCOLS
+ IPW = IPT + DESCT( LLD_ ) * TCOLS
+ IPWRK = IPW + DESCW( LLD_ ) * WCOLS
+*
+* Aggressive early deflation
+*
+ IWORK(1) = IT
+ CALL PDLAQR3( WANTT, WANTZ, N, KTOP, KBOT, NW, H,
+ $ DESCH, ILOZ, IHIZ, Z, DESCZ, LS, LD, WR, WI,
+ $ WORK(IPV), DESCV, NHO, WORK(IPT), DESCT, NVE,
+ $ WORK(IPW), DESCW, WORK(IPWRK), LWORK-IPWRK+1,
+ $ IWORK, LIWORK, RECLEVEL )
+*
+* 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 PDLAQR3
+* 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
+* PDLAQR3 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
+ CALL PDELGET( 'All', '1-Tree', ELEM1, H, I, I-1,
+ $ DESCH )
+ CALL PDELGET( 'All', '1-Tree', ELEM2, H, I-1, I-2,
+ $ DESCH )
+ CALL PDELGET( 'All', '1-Tree', ELEM3, H, I, I,
+ $ DESCH )
+ SS = ABS( ELEM1 ) + ABS( ELEM2 )
+ AA = WILK1*SS + ELEM3
+ 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
+ CALL PDELGET( 'All', '1-Tree', ELEM1, H, KS+1,
+ $ KS+1, DESCH )
+ WR( KS+1 ) = ELEM1
+ WI( KS+1 ) = ZERO
+ WR( KS ) = WR( KS+1 )
+ WI( KS ) = WI( KS+1 )
+ END IF
+ ELSE
+*
+* Got NS/2 or fewer shifts? Use PDLAQR0 or
+* PDLAQR1 on a trailing principal submatrix to
+* get more.
+*
+ IF( KBOT-KS+1.LE.NS / 2 ) THEN
+ KS = KBOT - NS + 1
+ KT = N - NS + 1
+ NPMIN = PILAENVX( ICTXT, 23, 'PDLAQR0', 'EN', NS,
+ $ NB, NPROW, NPCOL )
+c
+c Temporarily force NPMIN <= 8 since only PDLAQR1 is used.
+c
+ NPMIN = MIN(NPMIN, 8)
+ IF( MIN(NPROW, NPCOL).LE.NPMIN+1 .OR.
+ $ RECLEVEL.GE.1 ) THEN
+*
+* The window is large enough. Compute the Schur
+* decomposition with all processors.
+*
+ IROFFH = MOD( KS - 1, NB )
+ ICOFFH = IROFFH
+ IF( NS.GT.NMIN ) THEN
+ HRSRC = INDXG2P( KS, NB, MYROW, DESCH(RSRC_),
+ $ NPROW )
+ HCSRC = INDXG2P( KS, NB, MYROW, DESCH(CSRC_),
+ $ NPCOL )
+ ELSE
+ HRSRC = 0
+ HCSRC = 0
+ END IF
+ TROWS = NUMROC( NS+IROFFH, NB, MYROW, HRSRC,
+ $ NPROW )
+ TCOLS = NUMROC( NS+ICOFFH, NB, MYCOL, HCSRC,
+ $ NPCOL )
+ CALL DESCINIT( DESCT, NS+IROFFH, NS+ICOFFH, NB,
+ $ NB, HRSRC, HCSRC, ICTXT, MAX(1, TROWS),
+ $ INFO )
+ IPT = 1
+ IPWRK = IPT + DESCT(LLD_) * TCOLS
+*
+ IF( NS.GT.NMIN .AND. RECURSION ) THEN
+ CALL PDLACPY( 'All', NS, NS, H, KS, KS,
+ $ DESCH, WORK(IPT), 1+IROFFH, 1+ICOFFH,
+ $ DESCT )
+ CALL PDLAQR0( .FALSE., .FALSE., IROFFH+NS,
+ $ 1+IROFFH, IROFFH+NS, WORK(IPT),
+ $ DESCT, WR( KS-IROFFH ),
+ $ WI( KS-IROFFH ), 1, 1, ZDUM,
+ $ DESCZ, WORK( IPWRK ),
+ $ LWORK-IPWRK+1, IWORK, LIWORK,
+ $ INF, RECLEVEL+1 )
+ ELSE
+ CALL PDLAMVE( 'All', NS, NS, H, KS, KS,
+ $ DESCH, WORK(IPT), 1+IROFFH, 1+ICOFFH,
+ $ DESCT, WORK(IPWRK) )
+ CALL PDLAQR1( .FALSE., .FALSE., IROFFH+NS,
+ $ 1+IROFFH, IROFFH+NS, WORK(IPT),
+ $ DESCT, WR( KS-IROFFH ),
+ $ WI( KS-IROFFH ), 1+IROFFH, IROFFH+NS,
+ $ ZDUM, DESCZ, WORK( IPWRK ),
+ $ LWORK-IPWRK+1, IWORK, LIWORK, INF )
+ END IF
+ ELSE
+*
+* The window is too small. Redistribute the AED
+* window to a subgrid and do the computation on
+* the subgrid.
+*
+ ICTXT_NEW = ICTXT
+ DO 50 I = 0, NPMIN-1
+ DO 40 J = 0, NPMIN-1
+ PMAP( J+1+I*NPMIN ) =
+ $ BLACS_PNUM( ICTXT, I, J )
+ 40 CONTINUE
+ 50 CONTINUE
+ CALL BLACS_GRIDMAP( ICTXT_NEW, PMAP, NPMIN,
+ $ NPMIN, NPMIN )
+ CALL BLACS_GRIDINFO( ICTXT_NEW, NPMIN, NPMIN,
+ $ MYROW_NEW, MYCOL_NEW )
+ IF( MYROW.GE.NPMIN .OR. MYCOL.GE.NPMIN )
+ $ ICTXT_NEW = -1
+*
+ IF( ICTXT_NEW.GE.0 ) THEN
+ TROWS = NUMROC( NS, NB, MYROW_NEW, 0, NPMIN )
+ TCOLS = NUMROC( NS, NB, MYCOL_NEW, 0, NPMIN )
+ CALL DESCINIT( DESCT, NS, NS, NB, NB, 0, 0,
+ $ ICTXT_NEW, MAX(1,TROWS), INFO )
+ IPT = 1
+ IPWRK = IPT + DESCT(LLD_) * TCOLS
+ ELSE
+ IPT = 1
+ IPWRK = 2
+ DESCT( CTXT_ ) = -1
+ INF = 0
+ END IF
+ CALL PDGEMR2D( NS, NS, H, KS, KS, DESCH,
+ $ WORK(IPT), 1, 1, DESCT, ICTXT )
+*
+c
+c This part is still not perfect.
+c Either PDLAQR0 or PDLAQR1 can work, but not both.
+c
+c NMIN = PILAENVX( ICTXT_NEW, 12, 'PDLAQR0',
+c $ 'EN', NS, 1, NS, LWORK )
+ IF( ICTXT_NEW.GE.0 ) THEN
+c IF( NS.GT.NMIN .AND. RECLEVEL.LT.1 ) THEN
+c CALL PDLAQR0( .FALSE., .FALSE., NS, 1,
+c $ NS, WORK(IPT), DESCT, WR( KS ),
+c $ WI( KS ), 1, 1, ZDUM, DESCT,
+c $ WORK( IPWRK ), LWORK-IPWRK+1, IWORK,
+c $ LIWORK, INF, RECLEVEL+1 )
+c ELSE
+ CALL PDLAQR1( .FALSE., .FALSE., NS, 1,
+ $ NS, WORK(IPT), DESCT, WR( KS ),
+ $ WI( KS ), 1, NS, ZDUM, DESCT,
+ $ WORK( IPWRK ), LWORK-IPWRK+1, IWORK,
+ $ LIWORK, INF )
+c END IF
+ CALL BLACS_GRIDEXIT( ICTXT_NEW )
+ END IF
+ IF( MYROW+MYCOL.GT.0 ) THEN
+ DO 60 J = 0, NS-1
+ WR( KS+J ) = ZERO
+ WI( KS+J ) = ZERO
+ 60 CONTINUE
+ END IF
+ CALL IGAMN2D( ICTXT, 'All', '1-Tree', 1, 1, INF,
+ $ 1, -1, -1, -1, -1, -1 )
+ CALL DGSUM2D( ICTXT, 'All', ' ', NS, 1, WR(KS),
+ $ NS, -1, -1 )
+ CALL DGSUM2D( ICTXT, 'All', ' ', NS, 1, WI(KS),
+ $ NS, -1, -1 )
+ 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
+ CALL PDELGET( 'All', '1-Tree', AA, H, KBOT-1,
+ $ KBOT-1, DESCH )
+ CALL PDELGET( 'All', '1-Tree', CC, H, KBOT,
+ $ KBOT-1, DESCH )
+ CALL PDELGET( 'All', '1-Tree', BB, H, KBOT-1,
+ $ KBOT, DESCH )
+ CALL PDELGET( 'All', '1-Tree', DD, H, KBOT,
+ $ KBOT, DESCH )
+ 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 80 K = KBOT, KS + 1, -1
+ IF( SORTED )
+ $ GO TO 90
+ SORTED = .TRUE.
+ DO 70 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
+ 70 CONTINUE
+ 80 CONTINUE
+ 90 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 100 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
+ 100 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
+ CALL PDELGET( 'All', '1-Tree', ELEM, H, KBOT,
+ $ KBOT, DESCH )
+ IF( ABS( WR( KBOT )-ELEM ).LT.
+ $ ABS( WR( KBOT-1 )-ELEM ) ) 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.
+*
+ TOTNS = TOTNS + NS
+ SWEEP = SWEEP + 1
+ CALL PDLAQR5( WANTT, WANTZ, KACC22, N, KTOP, KBOT,
+ $ NS, WR( KS ), WI( KS ), H, DESCH, ILOZ, IHIZ, Z,
+ $ DESCZ, WORK, LWORK, IWORK, LIWORK )
+ 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.
+ 110 CONTINUE
+*
+* Iteration limit exceeded. Set INFO to show where
+* the problem occurred and exit.
+*
+ INFO = KBOT
+ 120 CONTINUE
+ END IF
+*
+* Return the optimal value of LWORK.
+*
+ WORK( 1 ) = DBLE( LWKOPT )
+ IWORK( 1 ) = LIWKOPT
+ IF( .NOT. LQUERY ) THEN
+ IWORK( 1 ) = TOTIT
+ IWORK( 2 ) = SWEEP
+ IWORK( 3 ) = TOTNS
+ END IF
+ RETURN
+*
+* End of PDLAQR0
+*
+ END
diff --git a/SRC/pdlahqr.f b/SRC/pdlaqr1.f
similarity index 84%
copy from SRC/pdlahqr.f
copy to SRC/pdlaqr1.f
index 6393898..ef2d370 100644
--- a/SRC/pdlahqr.f
+++ b/SRC/pdlaqr1.f
@@ -1,14 +1,17 @@
- SUBROUTINE PDLAHQR( WANTT, WANTZ, N, ILO, IHI, A, DESCA, WR, WI,
- $ ILOZ, IHIZ, Z, DESCZ, WORK, LWORK, IWORK,
- $ ILWORK, INFO )
+ RECURSIVE SUBROUTINE PDLAQR1( WANTT, WANTZ, N, ILO, IHI, A,
+ $ DESCA, WR, WI, ILOZ, IHIZ, Z,
+ $ DESCZ, WORK, LWORK, IWORK,
+ $ ILWORK, INFO )
*
-* -- ScaLAPACK routine (version 1.7.3) --
+* Contribution from the Department of Computing Science and HPC2N,
+* Umea University, Sweden
+*
+* -- ScaLAPACK auxiliary routine (version 2.0.1) --
* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
-* and University of California, Berkeley.
-* 1.7.3: March 22, 2006
-* modification suggested by Mark Fahey and Greg Henry
-* 1.7.1: January 30, 2006
-* 1.7.0: December 31, 1998
+* Univ. of Colorado Denver and University of California, Berkeley.
+* January, 2012
+*
+ IMPLICIT NONE
*
* .. Scalar Arguments ..
LOGICAL WANTT, WANTZ
@@ -22,10 +25,23 @@
* Purpose
* =======
*
-* PDLAHQR is an auxiliary routine used to find the Schur decomposition
+* PDLAQR1 is an auxiliary routine used to find the Schur decomposition
* and or eigenvalues of a matrix already in Hessenberg form from
* cols ILO to IHI.
*
+* This is a modified version of PDLAHQR from ScaLAPACK version 1.7.3.
+* The following modifications were made:
+* o Recently removed workspace query functionality was added.
+* o Aggressive early deflation is implemented.
+* o Aggressive deflation (looking for two consecutive small
+* subdiagonal elements by PDLACONSB) is abandoned.
+* o The returned Schur form is now in canonical form, i.e., the
+* returned 2-by-2 blocks really correspond to complex conjugate
+* pairs of eigenvalues.
+* o For some reason, the original version of PDLAHQR sometimes did
+* not read out the converged eigenvalues correclty. This is now
+* fixed.
+*
* Notes
* =====
*
@@ -99,7 +115,7 @@
* IHI (global input) INTEGER
* It is assumed that A is already upper quasi-triangular in
* rows and columns IHI+1:N, and that A(ILO,ILO-1) = 0 (unless
-* ILO = 1). PDLAHQR works primarily with the Hessenberg
+* ILO = 1). PDLAQR1 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.
@@ -149,7 +165,7 @@
*
* LWORK (local input) INTEGER
* WORK(LWORK) is a local array and LWORK is assumed big enough
-* so that LWORK >= 3*N +
+* so that LWORK >= 6*N + 6*385*385 +
* MAX( 2*MAX(DESCZ(LLD_),DESCA(LLD_)) + 2*LOCc(N),
* 7*Ceil(N/HBL)/LCM(NPROW,NPCOL)) )
*
@@ -162,7 +178,7 @@
* INFO (global output) INTEGER
* < 0: parameter number -INFO incorrect or inconsistent
* = 0: successful exit
-* > 0: PDLAHQR failed to compute all the eigenvalues ILO to IHI
+* > 0: PDLAQR1 failed to compute all the eigenvalues ILO to IHI
* in a total of 30*(IHI-ILO+1) iterations; if INFO = i,
* elements i+1:ihi of WR and WI contain those eigenvalues
* which have been successfully computed.
@@ -188,14 +204,12 @@
*
* Subroutines:
* This routine calls:
-* PDLACONSB -> To determine where to start each iteration
* PDLAWIL -> Given the shift, get the transformation
-* DLASORTE -> Pair up eigenvalues so that reals are paired.
+* DLASORTE -> Pair up eigenvalues so that reals are paired.
* PDLACP3 -> Parallel array to local replicated array copy &
* back.
-* DLAREF -> Row/column reflector applier. Core routine
-* here.
-* PDLASMSUB -> Finds negligible subdiagonal elements.
+* DLAREF -> Row/column reflector applier. Core routine here.
+* PDLASMSUB -> Finds negligible subdiagonal elements.
*
* Current Notes and/or Restrictions:
* 1.) This code requires the distributed block size to be square
@@ -230,6 +244,9 @@
*
* Implemented by: G. Henry, November 17, 1996
*
+* Modified by Robert Granat and Meiyue Shao, Department of Computing
+* Science and HPC2N, Umea University, Sweden
+*
* =====================================================================
*
* .. Parameters ..
@@ -242,53 +259,53 @@
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, HALF = 0.5D+0 )
DOUBLE PRECISION CONST
PARAMETER ( CONST = 1.50D+0 )
- INTEGER IBLK
- PARAMETER ( IBLK = 32 )
+ INTEGER IBLK, LDS
+ PARAMETER ( IBLK = 32, LDS = 12*IBLK+1 )
* ..
* .. Local Scalars ..
INTEGER CONTXT, DOWN, HBL, I, I1, I2, IAFIRST, IBULGE,
- $ ICBUF, ICOL, ICOL1, ICOL2, IDIA, IERR, II,
+ $ ICBUF, ICOL, ICOL1, ICOL2, IERR, II,
$ IRBUF, IROW, IROW1, IROW2, ISPEC, ISTART,
- $ ISTARTCOL, ISTARTROW, ISTOP, ISUB, ISUP,
+ $ ISTARTCOL, ISTARTROW, ISTOP, ISUB,
$ ITERMAX, ITMP1, ITMP2, ITN, ITS, J, JAFIRST,
$ JBLK, JJ, K, KI, L, LCMRC, LDA, LDZ, LEFT,
$ LIHIH, LIHIZ, LILOH, LILOZ, LOCALI1, LOCALI2,
$ LOCALK, LOCALM, M, MODKM1, MYCOL, MYROW,
$ NBULGE, NH, NODE, NPCOL, NPROW, NR, NUM, NZ,
- $ RIGHT, ROTN, UP, VECSIDX
+ $ RIGHT, ROTN, UP, VECSIDX, TOTIT, TOTNS, TOTSW,
+ $ DBLK, NIBBLE, ND, NS, LTOP, LWKOPT, S1, S2, S3
DOUBLE PRECISION AVE, DISC, H00, H10, H11, H12, H21, H22, H33,
$ H43H34, H44, OVFL, S, SMLNUM, SUM, T1, T1COPY,
$ T2, T3, ULP, UNFL, V1SAVE, V2, V2SAVE, V3,
- $ V3SAVE
+ $ V3SAVE, SN, CS, SWAP
+ LOGICAL AED
* ..
* .. Local Arrays ..
INTEGER ICURCOL( IBLK ), ICURROW( IBLK ), K1( IBLK ),
$ K2( IBLK ), KCOL( IBLK ), KP2COL( IBLK ),
$ KP2ROW( IBLK ), KROW( IBLK ), LOCALK2( IBLK )
- DOUBLE PRECISION S1( 2*IBLK, 2*IBLK ), SMALLA( 6, 6, IBLK ),
- $ VCOPY( 3 )
+ DOUBLE PRECISION SMALLA( 6, 6, IBLK ), VCOPY( 3 )
* ..
* .. External Functions ..
- INTEGER ILCM, NUMROC
+ INTEGER ILCM, NUMROC, ILAENV
DOUBLE PRECISION PDLAMCH
- EXTERNAL ILCM, NUMROC, PDLAMCH
+ EXTERNAL ILCM, NUMROC, ILAENV, PDLAMCH
* ..
* .. External Subroutines ..
EXTERNAL BLACS_GRIDINFO, DCOPY, DGEBR2D, DGEBS2D,
$ DGERV2D, DGESD2D, DGSUM2D, DLAHQR, DLAREF,
$ DLARFG, DLASORTE, IGAMN2D, INFOG1L, INFOG2L,
- $ PDLABAD, PDLACONSB, PDLACP3, PDLASMSUB,
- $ PDLAWIL, PXERBLA
+ $ PDLABAD, PDLACP3, PDLASMSUB,
+ $ PDLAWIL, PXERBLA, DLANV2, PDLAQR2, PDLAQR4
* ..
* .. Intrinsic Functions ..
- INTRINSIC ABS, MAX, MIN, MOD, SIGN, SQRT
+ INTRINSIC ABS, DBLE, MAX, MIN, MOD, SIGN, SQRT
* ..
* .. Executable Statements ..
*
INFO = 0
*
ITERMAX = 30*( IHI-ILO+1 )
-* ITERMAX = 0
IF( N.EQ.0 )
$ RETURN
*
@@ -308,6 +325,9 @@
UP = MOD( MYROW+NPROW-1, NPROW )
DOWN = MOD( MYROW+1, NPROW )
LCMRC = ILCM( NPROW, NPCOL )
+ TOTIT = 0
+ TOTNS = 0
+ TOTSW = 0
*
* Determine the number of columns we have so we can check workspace
*
@@ -316,7 +336,12 @@
IF( JJ*HBL.LT.N )
$ JJ = JJ + 1
JJ = 7*JJ / LCMRC
- IF( LWORK.LT.3*N+MAX( 2*MAX( LDA, LDZ )+2*LOCALK, JJ ) ) THEN
+ LWKOPT = INT( 6*N+MAX( 3*MAX( LDA, LDZ )+2*LOCALK, JJ )
+ $ +6*LDS*LDS )
+ IF( LWORK.EQ.-1 .OR. ILWORK.EQ.-1 ) THEN
+ WORK( 1 ) = DBLE( LWKOPT )
+ RETURN
+ ELSEIF( LWORK.LT.LWKOPT ) THEN
INFO = -15
END IF
IF( DESCZ( CTXT_ ).NE.DESCA( CTXT_ ) ) THEN
@@ -331,12 +356,6 @@
IF( DESCA( MB_ ).NE.DESCZ( MB_ ) ) THEN
INFO = -( 1300+MB_ )
END IF
- IF( ( DESCA( RSRC_ ).NE.0 ) .OR. ( DESCA( CSRC_ ).NE.0 ) ) THEN
- INFO = -( 700+RSRC_ )
- END IF
- IF( ( DESCZ( RSRC_ ).NE.0 ) .OR. ( DESCZ( CSRC_ ).NE.0 ) ) THEN
- INFO = -( 1300+RSRC_ )
- END IF
IF( ( ILO.GT.N ) .OR. ( ILO.LT.1 ) ) THEN
INFO = -4
END IF
@@ -349,18 +368,20 @@
CALL IGAMN2D( CONTXT, 'ALL', ' ', 1, 1, INFO, 1, ITMP1, ITMP2, -1,
$ -1, -1 )
IF( INFO.LT.0 ) THEN
- CALL PXERBLA( CONTXT, 'PDLAHQR', -INFO )
+ CALL PXERBLA( CONTXT, 'PDLAQR1', -INFO )
+ WORK( 1 ) = DBLE( LWKOPT )
RETURN
END IF
*
* Set work array indices
*
- VECSIDX = 0
- IDIA = 3*N
- ISUB = 3*N
- ISUP = 3*N
- IRBUF = 3*N
- ICBUF = 3*N
+ S1 = 0
+ S2 = S1+LDS*LDS
+ S3 = S2+LDS*LDS
+ VECSIDX = S3+4*LDS*LDS
+ ISUB = VECSIDX+3*N
+ IRBUF = ISUB+N
+ ICBUF = IRBUF+N
*
* Find a value for ROTN
*
@@ -377,14 +398,27 @@
WR( ILO ) = ZERO
END IF
WI( ILO ) = ZERO
+ WORK( 1 ) = DBLE( LWKOPT )
RETURN
END IF
*
NH = IHI - ILO + 1
NZ = IHIZ - ILOZ + 1
*
- CALL INFOG1L( ILOZ, HBL, NPROW, MYROW, 0, LILOZ, LIHIZ )
- LIHIZ = NUMROC( IHIZ, HBL, MYROW, 0, NPROW )
+* If the diagonal block is small enough, copy it to local memory and
+* call DLAHQR directly.
+*
+ IF( NH .LE. LDS ) THEN
+ CALL PDLAQR4( WANTT, WANTZ, N, ILO, IHI, A, DESCA, WR, WI,
+ $ ILOZ, IHIZ, Z, DESCZ, WORK( S1+1 ), NH,
+ $ WORK( S2+1 ), NH, WORK( S3+1 ), 4*LDS*LDS,
+ $ INFO )
+ WORK( 1 ) = DBLE( LWKOPT )
+ RETURN
+ END IF
+*
+ CALL INFOG1L( ILOZ, HBL, NPROW, MYROW, DESCZ(RSRC_), LILOZ, LIHIZ)
+ LIHIZ = NUMROC( IHIZ, HBL, MYROW, DESCZ(RSRC_), NPROW )
*
* Set machine-dependent constants for the stopping criterion.
* If NORM(H) <= SQRT(OVFL), overflow should not occur.
@@ -426,6 +460,7 @@
* subdiagonal element has become negligible.
*
DO 420 ITS = 0, ITN
+ TOTIT = TOTIT + 1
*
* Look for a single small subdiagonal element.
*
@@ -445,12 +480,10 @@
WORK( ISUB+L-1 ) = ZERO
END IF
*
-* Exit from loop if a submatrix of order 1 or 2 has split off.
+* Exit from loop if a small submatrix has split off.
*
M = L - 10
-* IF ( L .GE. I - (2*IBLK-1) )
-* IF ( L .GE. I - MAX(2*IBLK-1,HBL) )
- IF( L.GE.I-1 )
+ IF ( L .GT. I - LDS )
$ GO TO 430
*
* Now the active submatrix is in rows and columns L to I. If
@@ -465,7 +498,9 @@
* Copy submatrix of size 2*JBLK and prepare to do generalized
* Wilkinson shift or an exceptional shift
*
- JBLK = MIN( IBLK, ( ( I-L+1 ) / 2 )-1 )
+ NH = I-L+1
+ AED = .TRUE.
+ JBLK = MIN( IBLK, ( NH / 2 )-1 )
IF( JBLK.GT.LCMRC ) THEN
*
* Make sure it's divisible by LCM (we want even workloads!)
@@ -475,31 +510,109 @@
JBLK = MIN( JBLK, 2*LCMRC )
JBLK = MAX( JBLK, 1 )
*
- CALL PDLACP3( 2*JBLK, I-2*JBLK+1, A, DESCA, S1, 2*IBLK, -1, -1,
- $ 0 )
IF( ITS.EQ.20 .OR. ITS.EQ.40 ) THEN
*
* Exceptional shift.
*
+ CALL PDLACP3( 2*JBLK, I-2*JBLK+1, A, DESCA, WORK( S1+1 ),
+ $ LDS, -1, -1, 0 )
DO 20 II = 2*JBLK, 2, -1
- S1( II, II ) = CONST*( ABS( S1( II, II ) )+
- $ ABS( S1( II, II-1 ) ) )
- S1( II, II-1 ) = ZERO
- S1( II-1, II ) = ZERO
+ WORK( S1+II+(II-1)*LDS ) = CONST*(
+ $ ABS( WORK( S1+II+(II-1)*LDS ) )+
+ $ ABS( WORK( S1+II+(II-2)*LDS ) ) )
+ WORK( S1+II+(II-2)*LDS ) = ZERO
+ WORK( S1+II-1+(II-1)*LDS ) = ZERO
20 CONTINUE
- S1( 1, 1 ) = CONST*ABS( S1( 1, 1 ) )
+ WORK( S1+1 ) = CONST*ABS( WORK( S1+1 ) )
ELSE
- CALL DLAHQR( .FALSE., .FALSE., 2*JBLK, 1, 2*JBLK, S1,
- $ 2*IBLK, WORK( IRBUF+1 ), WORK( ICBUF+1 ), 1,
- $ 2*JBLK, Z, LDZ, IERR )
+*
+* Aggressive early deflation.
+*
+ IF( AED ) THEN
+ DBLK = ILAENV( 13, 'DLAQR0', 'SV', N, L, I, 4*LDS*LDS )
+ DBLK = MAX( 2*JBLK, DBLK ) + 1
+ DBLK = MIN( NH, LDS, DBLK )
+ CALL PDLAQR2( WANTT, WANTZ, N, L, I, DBLK, A, DESCA,
+ $ ILOZ, IHIZ, Z, DESCZ, NS, ND, WR, WI,
+ $ WORK( S1+1 ), LDS, WORK( S2+1 ), DBLK,
+ $ WORK( IRBUF+1 ), WORK( ICBUF+1 ),
+ $ WORK( S3+1 ), 4*LDS*LDS )
+*
+* Skip a QR sweep if enough eigenvalues are deflated.
+*
+ NIBBLE = ILAENV( 14, 'DLAQR0', 'SV', N, L, I, 4*LDS*LDS )
+ NIBBLE = MAX( 0, NIBBLE )
+ I = I - ND
+ DBLK = DBLK - ND
+ IF( 100*ND .GT. NIBBLE*NH .OR. DBLK .LT. 2*JBLK ) GOTO 10
+*
+* Use unconverged eigenvalues as shifts for the QR sweep.
+* (This option is turned off because of the quality of
+* these shifts are not so good.)
+*
+* IF( ND.GE.0 .AND. ND+DBLK.GE.64 ) THEN
+ IF( .FALSE. ) THEN
+ CALL DLASET( 'L', DBLK-1, DBLK-1, ZERO, ZERO,
+ $ WORK( S1+2 ), LDS )
+ WORK( IRBUF+1 ) = WORK( S1+1 )
+ WORK( ICBUF+1 ) = ZERO
+*
+* Shuffle shifts into pairs of real shifts and pairs of
+* complex conjugate shifts assuming complex conjugate
+* shifts are already adjacent to one another.
+*
+ DO 21 II = DBLK, 3, -2
+ IF( WORK( ICBUF+II ).NE.-WORK( ICBUF+II-1 ) ) THEN
+ SWAP = WORK( IRBUF+II )
+ WORK( IRBUF+II ) = WORK( IRBUF+II-1 )
+ WORK( IRBUF+II-1 ) = WORK( IRBUF+II-2 )
+ WORK( IRBUF+II-2 ) = SWAP
+ SWAP = WORK( ICBUF+II )
+ WORK( ICBUF+II ) = WORK( ICBUF+II-1 )
+ WORK( ICBUF+II-1 ) = WORK( ICBUF+II-2 )
+ WORK( ICBUF+II-2 ) = SWAP
+ END IF
+ 21 CONTINUE
+*
+* Copy undeflatable eigenvalues to the diagonal of S1.
+*
+ II = 2
+ 22 CONTINUE
+ IF( WORK( ICBUF+II ) .EQ. ZERO ) THEN
+ WORK( S1+II+(II-1)*LDS ) = WORK( IRBUF+II )
+ WORK( S1+II+(II-2)*LDS ) = ZERO
+ II = II + 1
+ ELSE
+ WORK( S1+II+(II-1)*LDS ) = WORK( IRBUF+II )
+ WORK( S1+II+1+II*LDS ) = WORK( IRBUF+II )
+ WORK( S1+II+1+(II-1)*LDS ) = WORK( ICBUF+II )
+ WORK( S1+II+II*LDS ) = -WORK( ICBUF+II )
+ II = II + 2
+ END IF
+ IF( II .LE. DBLK ) GOTO 22
+ ELSE
+ CALL DLAHQR( .FALSE., .FALSE., DBLK, 1, DBLK,
+ $ WORK( S1+1 ), LDS, WORK( IRBUF+1 ),
+ $ WORK( ICBUF+1 ), 1, DBLK, Z, LDZ, IERR )
+ END IF
+ ELSE
+ DBLK = 2*JBLK
+ CALL PDLACP3( DBLK, I-DBLK+1, A, DESCA, WORK( S1+1 ),
+ $ LDS, -1, -1, 0 )
+ CALL DLAHQR( .FALSE., .FALSE., DBLK, 1, DBLK,
+ $ WORK( S1+1 ), LDS, WORK( IRBUF+1 ),
+ $ WORK( ICBUF+1 ), 1, DBLK, Z, LDZ, IERR )
+ END IF
+ TOTSW = TOTSW + 1
*
* Prepare to use Wilkinson's double shift
*
- H44 = S1( 2*JBLK, 2*JBLK )
- H33 = S1( 2*JBLK-1, 2*JBLK-1 )
- H43H34 = S1( 2*JBLK-1, 2*JBLK )*S1( 2*JBLK, 2*JBLK-1 )
+ H44 = WORK( S1+DBLK+(DBLK-1)*LDS )
+ H33 = WORK( S1+DBLK-1+(DBLK-2)*LDS )
+ H43H34 = WORK( S1+DBLK-1+(DBLK-1)*LDS )*
+ $ WORK( S1+DBLK+(DBLK-2)*LDS )
IF( ( JBLK.GT.1 ) .AND. ( ITS.GT.30 ) ) THEN
- S = S1( 2*JBLK-1, 2*JBLK-2 )
+ S = WORK( S1+DBLK-1+(DBLK-3)*LDS )
DISC = ( H33-H44 )*HALF
DISC = DISC*DISC + H43H34
IF( DISC.GT.ZERO ) THEN
@@ -523,14 +636,25 @@
* Look for two consecutive small subdiagonal elements:
* PDLACONSB is the routine that does this.
*
- CALL PDLACONSB( A, DESCA, I, L, M, H44, H33, H43H34,
- $ WORK( IRBUF+1 ), LWORK-IRBUF )
+* CALL PDLACONSB( A, DESCA, I, L, M, H44, H33, H43H34,
+* $ WORK( IRBUF+1 ), LWORK-IRBUF )
*
* Skip small submatrices
*
* IF ( M .GE. I - 5 )
* $ GO TO 80
*
+* In principle PDLACONSB needs to check all shifts to decide
+* whether two consecutive small subdiagonal entries are suitable
+* as the starting position of the bulge chasing phase. It can be
+* dangerous to check the first pair of shifts only. Moreover it
+* is quite rare to obtain an M which is much larger than L. This
+* process is a bit expensive compared with the benefit.
+* Therefore it is sensible to abandon this routine. Total amount
+* of communications is saved in average.
+*
+ M = L
+*
* Double-shift QR step
*
* NBULGE is the number of bulges that will be attempted
@@ -552,15 +676,19 @@
END IF
NBULGE = MAX( NBULGE, 1 )
*
+ TOTNS = TOTNS + NBULGE*2
+*
IF( ( ITS.NE.20 ) .AND. ( ITS.NE.40 ) .AND. ( NBULGE.GT.1 ) )
$ THEN
*
* sort the eigenpairs so that they are in twos for double
* shifts. only call if several need sorting
*
- CALL DLASORTE( S1( 2*( JBLK-NBULGE )+1,
- $ 2*( JBLK-NBULGE )+1 ), 2*IBLK, 2*NBULGE,
- $ WORK( IRBUF+1 ), IERR )
+* CALL DLASORTE( S1( 2*( JBLK-NBULGE )+1,
+* $ 2*( JBLK-NBULGE )+1 ), 3*IBLK, 2*NBULGE,
+* $ WORK( IRBUF+1 ), IERR )
+ CALL DLASORTE( WORK(S1+DBLK-2*NBULGE+1+(DBLK-2*NBULGE)*LDS),
+ $ LDS, 2*NBULGE, WORK( IRBUF+1 ), IERR )
END IF
*
* IBULGE is the number of bulges going so far
@@ -569,31 +697,31 @@
*
* "A" row defs : main row transforms from LOCALK to LOCALI2
*
- CALL INFOG1L( M, HBL, NPCOL, MYCOL, 0, ITMP1, LOCALK )
- LOCALK = NUMROC( N, HBL, MYCOL, 0, NPCOL )
- CALL INFOG1L( 1, HBL, NPCOL, MYCOL, 0, ICOL1, LOCALI2 )
- LOCALI2 = NUMROC( I2, HBL, MYCOL, 0, NPCOL )
+ CALL INFOG1L( M, HBL, NPCOL, MYCOL, DESCA(CSRC_),ITMP1,LOCALK )
+ LOCALK = NUMROC( N, HBL, MYCOL, DESCA(CSRC_), NPCOL )
+ CALL INFOG1L( 1, HBL, NPCOL, MYCOL,DESCA(CSRC_),ICOL1,LOCALI2 )
+ LOCALI2 = NUMROC( I2, HBL, MYCOL, DESCA(CSRC_), NPCOL )
*
* "A" col defs : main col transforms from LOCALI1 to LOCALM
*
- CALL INFOG1L( I1, HBL, NPROW, MYROW, 0, LOCALI1, ICOL1 )
- ICOL1 = NUMROC( N, HBL, MYROW, 0, NPROW )
- CALL INFOG1L( 1, HBL, NPROW, MYROW, 0, LOCALM, ICOL1 )
- ICOL1 = NUMROC( MIN( M+3, I ), HBL, MYROW, 0, NPROW )
+ CALL INFOG1L( I1, HBL, NPROW,MYROW,DESCA(RSRC_),LOCALI1,ICOL1 )
+ ICOL1 = NUMROC( N, HBL, MYROW, DESCA(RSRC_), NPROW )
+ CALL INFOG1L( 1, HBL, NPROW, MYROW, DESCA(RSRC_),LOCALM,ICOL1 )
+ ICOL1 = NUMROC( MIN( M+3, I ), HBL, MYROW, DESCA(RSRC_),NPROW )
*
* Which row & column will start the bulges
*
- ISTARTROW = MOD( ( M+1 ) / HBL, NPROW ) + IAFIRST
- ISTARTCOL = MOD( ( M+1 ) / HBL, NPCOL ) + JAFIRST
+ ISTARTROW = MOD( ( M+1 ) / HBL + IAFIRST, NPROW )
+ ISTARTCOL = MOD( ( M+1 ) / HBL + JAFIRST, NPCOL )
*
- CALL INFOG1L( M, HBL, NPROW, MYROW, 0, II, ITMP2 )
- ITMP2 = NUMROC( N, HBL, MYROW, 0, NPROW )
- CALL INFOG1L( M, HBL, NPCOL, MYCOL, 0, JJ, ITMP2 )
- ITMP2 = NUMROC( N, HBL, MYCOL, 0, NPCOL )
- CALL INFOG1L( 1, HBL, NPROW, MYROW, 0, ISTOP, KP2ROW( 1 ) )
- KP2ROW( 1 ) = NUMROC( M+2, HBL, MYROW, 0, NPROW )
- CALL INFOG1L( 1, HBL, NPCOL, MYCOL, 0, ISTOP, KP2COL( 1 ) )
- KP2COL( 1 ) = NUMROC( M+2, HBL, MYCOL, 0, NPCOL )
+ CALL INFOG1L( M, HBL, NPROW, MYROW, DESCA(RSRC_), II, ITMP2 )
+ ITMP2 = NUMROC( N, HBL, MYROW, DESCA(RSRC_), NPROW )
+ CALL INFOG1L( M, HBL, NPCOL, MYCOL, DESCA(CSRC_), JJ, ITMP2 )
+ ITMP2 = NUMROC( N, HBL, MYCOL, DESCA(CSRC_), NPCOL )
+ CALL INFOG1L(1,HBL,NPROW,MYROW,DESCA(RSRC_),ISTOP,KP2ROW( 1 ) )
+ KP2ROW( 1 ) = NUMROC( M+2, HBL, MYROW, DESCA(RSRC_), NPROW )
+ CALL INFOG1L(1,HBL,NPCOL,MYCOL,DESCA(CSRC_),ISTOP,KP2COL( 1 ) )
+ KP2COL( 1 ) = NUMROC( M+2, HBL, MYCOL, DESCA(CSRC_), NPCOL )
*
* Set all values for bulges. All bulges are stored in
* intermediate steps as loops over KI. Their current "task"
@@ -647,10 +775,11 @@
$ THEN
IF( ( MOD( K2( IBULGE )+2, HBL ).EQ.MOD( K2( IBULGE+1 )+
$ 2, HBL ) ) .AND. ( K1( 1 ).LE.I-1 ) ) THEN
- H44 = S1( 2*JBLK-2*IBULGE, 2*JBLK-2*IBULGE )
- H33 = S1( 2*JBLK-2*IBULGE-1, 2*JBLK-2*IBULGE-1 )
- H43H34 = S1( 2*JBLK-2*IBULGE-1, 2*JBLK-2*IBULGE )*
- $ S1( 2*JBLK-2*IBULGE, 2*JBLK-2*IBULGE-1 )
+ H44 = WORK( S1+DBLK-2*IBULGE+(DBLK-2*IBULGE-1)*LDS )
+ H33 = WORK( S1+DBLK-2*IBULGE-1+(DBLK-2*IBULGE-2)*LDS )
+ H43H34 = WORK( S1+DBLK-2*IBULGE-1+
+ $ (DBLK-2*IBULGE-1)*LDS )
+ $ *WORK(S1+DBLK-2*IBULGE+(DBLK-2*IBULGE-2)*LDS)
ITMP1 = ISTARTROW
ITMP2 = ISTARTCOL
CALL PDLAWIL( ITMP1, ITMP2, M, A, DESCA, H44, H33,
@@ -784,7 +913,7 @@
* IF ( ABS(H10) .LE. MAX(ULP*(ABS(H11)+ABS(H22)),
* $ SMLNUM) ) THEN
* SMALLA(2,1,KI) = ZERO
-* WORK(ISUB+K-2) = ZERO
+* WORK(ISUB+K-2) = ZERO
* END IF
ELSE IF( M.GT.L ) THEN
SMALLA( 3, 2, KI ) = -SMALLA( 3, 2, KI )
@@ -1161,7 +1290,7 @@
IF( ( MODKM1.GE.HBL-2 ) .AND. ( K.LE.I-1 ) ) THEN
IF( ( MODKM1.EQ.HBL-2 ) .AND. ( K.LT.I-1 ) ) THEN
*
-* Copy 6 elements from global A(K-1:K+4,K-1:K+4)
+* Copy 6 elements to global A(K-1:K+4,K-1:K+4)
*
CALL INFOG2L( K+2, K+2, DESCA, NPROW, NPCOL, MYROW,
$ MYCOL, IROW1, ICOL1, ITMP1, ITMP2 )
@@ -1172,7 +1301,7 @@
END IF
IF( MODKM1.EQ.HBL-1 ) THEN
*
-* Copy 6 elements from global A(K-2:K+3,K-2:K+3)
+* Copy 6 elements to global A(K-2:K+3,K-2:K+3)
*
CALL INFOG2L( K+1, K+1, DESCA, NPROW, NPCOL, MYROW,
$ MYCOL, IROW1, ICOL1, ITMP1, ITMP2 )
@@ -1196,9 +1325,9 @@
$ ( MOD( ISTART-1, HBL ).LT.HBL-2 ) .AND.
$ ( ICURROW( KI ).EQ.MYROW ) ) THEN
IROW1 = MIN( K2( KI )+1, I-1 ) + 1
- CALL INFOG1L( IROW1, HBL, NPCOL, MYCOL, 0, ITMP1,
- $ ITMP2 )
- ITMP2 = NUMROC( I2, HBL, MYCOL, 0, NPCOL )
+ CALL INFOG1L( IROW1, HBL, NPCOL, MYCOL, DESCA(CSRC_),
+ $ ITMP1, ITMP2 )
+ ITMP2 = NUMROC( I2, HBL, MYCOL, DESCA(CSRC_), NPCOL )
II = KROW( KI )
CALL DLAREF( 'Row', A, LDA, WANTZ, Z, LDZ, .TRUE., II,
$ II, ISTART, ISTOP, ITMP1, ITMP2, LILOZ,
@@ -1243,9 +1372,9 @@
*
IROW1 = KROW( KI )
IROW2 = KP2ROW( KI )
- CALL INFOG1L( ITMP1, HBL, NPCOL, MYCOL, 0,
- $ ICOL1, ICOL2 )
- ICOL2 = NUMROC( I2, HBL, MYCOL, 0, NPCOL )
+ CALL INFOG1L( ITMP1, HBL, NPCOL, MYCOL,
+ $ DESCA(CSRC_), ICOL1, ICOL2 )
+ ICOL2 = NUMROC(I2,HBL,MYCOL,DESCA(CSRC_),NPCOL )
IF( ( MOD( K-1, HBL ).LT.HBL-2 ) .OR.
$ ( NPROW.EQ.1 ) ) THEN
T2 = T1*V2
@@ -1311,9 +1440,9 @@
*
IROW1 = KROW( KI ) + K - ISTART
IROW2 = KP2ROW( KI ) + K - ISTART
- CALL INFOG1L( ITMP1, HBL, NPCOL, MYCOL, 0,
- $ ICOL1, ICOL2 )
- ICOL2 = NUMROC( I2, HBL, MYCOL, 0, NPCOL )
+ CALL INFOG1L( ITMP1, HBL, NPCOL, MYCOL,
+ $ DESCA(CSRC_),ICOL1, ICOL2 )
+ ICOL2 = NUMROC(I2,HBL,MYCOL,DESCA(CSRC_),NPCOL )
IF( ( MOD( K-1, HBL ).EQ.HBL-2 ) .AND.
$ ( NPROW.GT.1 ) ) THEN
IF( IROW1.NE.IROW2 ) THEN
@@ -1401,9 +1530,9 @@
*
IROW1 = KROW( KI ) + K - ISTART
IROW2 = KP2ROW( KI ) + K - ISTART
- CALL INFOG1L( ITMP1, HBL, NPCOL, MYCOL, 0,
- $ ICOL1, ICOL2 )
- ICOL2 = NUMROC( I2, HBL, MYCOL, 0, NPCOL )
+ CALL INFOG1L( ITMP1, HBL, NPCOL, MYCOL,
+ $ DESCA(CSRC_), ICOL1, ICOL2 )
+ ICOL2 = NUMROC(I2,HBL,MYCOL,DESCA(CSRC_),NPCOL )
IF( ( MOD( K-1, HBL ).EQ.HBL-2 ) .AND.
$ ( NPROW.GT.1 ) ) THEN
IF( IROW1.EQ.IROW2 ) THEN
@@ -1454,8 +1583,9 @@
END IF
*
ICOL1 = KCOL( KI )
- CALL INFOG1L( I1, HBL, NPROW, MYROW, 0, IROW1, IROW2 )
- IROW2 = NUMROC( ITMP1, HBL, MYROW, 0, NPROW )
+ CALL INFOG1L( I1, HBL, NPROW, MYROW, DESCA(RSRC_),
+ $ IROW1, IROW2 )
+ IROW2 = NUMROC( ITMP1, HBL, MYROW,DESCA(RSRC_),NPROW )
IF( IROW1.LE.IROW2 ) THEN
ITMP2 = IROW2
ELSE
@@ -1483,10 +1613,10 @@
IROW2 = IROW1 - 1
END IF
ELSE
- CALL INFOG1L( ITMP1+1, HBL, NPROW, MYROW, 0,
- $ IROW1, IROW2 )
- IROW2 = NUMROC( MIN( K+3, I ), HBL, MYROW, 0,
- $ NPROW )
+ CALL INFOG1L( ITMP1+1, HBL, NPROW, MYROW,
+ $ DESCA(RSRC_),IROW1, IROW2 )
+ IROW2 = NUMROC( MIN( K+3, I ), HBL, MYROW,
+ $ DESCA(RSRC_), NPROW )
END IF
V2 = WORK( VECSIDX+( K-1 )*3+1 )
V3 = WORK( VECSIDX+( K-1 )*3+2 )
@@ -1547,9 +1677,10 @@
END IF
ICOL1 = KCOL( KI ) + K - ISTART
ICOL2 = KP2COL( KI ) + K - ISTART
- CALL INFOG1L( I1, HBL, NPROW, MYROW, 0, IROW1,
- $ IROW2 )
- IROW2 = NUMROC( ITMP1, HBL, MYROW, 0, NPROW )
+ CALL INFOG1L( I1, HBL, NPROW, MYROW, DESCA(RSRC_),
+ $ IROW1, IROW2 )
+ IROW2 = NUMROC( ITMP1, HBL, MYROW, DESCA(RSRC_),
+ $ NPROW )
IF( ( MOD( K-1, HBL ).EQ.HBL-2 ) .AND.
$ ( NPCOL.GT.1 ) ) THEN
IF( ICOL1.EQ.ICOL2 ) THEN
@@ -1745,12 +1876,12 @@
* Apply G from the left to transform the rows of the matrix
* in columns K to I2.
*
- CALL INFOG1L( K, HBL, NPCOL, MYCOL, 0, LILOH,
- $ LIHIH )
- LIHIH = NUMROC( I2, HBL, MYCOL, 0, NPCOL )
- CALL INFOG1L( 1, HBL, NPROW, MYROW, 0, ITMP2,
- $ ITMP1 )
- ITMP1 = NUMROC( K+1, HBL, MYROW, 0, NPROW )
+ CALL INFOG1L( K, HBL, NPCOL, MYCOL, DESCA(CSRC_),
+ $ LILOH,LIHIH )
+ LIHIH = NUMROC( I2, HBL, MYCOL, DESCA(CSRC_),NPCOL)
+ CALL INFOG1L( 1, HBL, NPROW, MYROW, DESCA(RSRC_),
+ $ ITMP2,ITMP1 )
+ ITMP1 = NUMROC( K+1,HBL, MYROW,DESCA(RSRC_),NPROW )
IF( ICURROW( KI ).EQ.MYROW ) THEN
IF( ( ISPEC.EQ.0 ) .OR. ( NPROW.EQ.1 ) .OR.
$ ( MOD( K-1, HBL ).EQ.HBL-2 ) ) THEN
@@ -1794,17 +1925,18 @@
* Apply G from the right to transform the columns of the
* matrix in rows I1 to MIN(K+3,I).
*
- CALL INFOG1L( I1, HBL, NPROW, MYROW, 0, LILOH,
- $ LIHIH )
- LIHIH = NUMROC( I, HBL, MYROW, 0, NPROW )
+ CALL INFOG1L( I1, HBL, NPROW, MYROW, DESCA(RSRC_),
+ $ LILOH, LIHIH )
+ LIHIH = NUMROC( I, HBL, MYROW, DESCA(RSRC_),NPROW )
*
IF( ICURCOL( KI ).EQ.MYCOL ) THEN
* LOCAL A(LILOZ:LIHIZ,LOCALK2:LOCALK2+2)
IF( ( ISPEC.EQ.0 ) .OR. ( NPCOL.EQ.1 ) .OR.
$ ( MOD( K-1, HBL ).EQ.HBL-2 ) ) THEN
- CALL INFOG1L( K, HBL, NPCOL, MYCOL, 0, ITMP1,
- $ ITMP2 )
- ITMP2 = NUMROC( K+1, HBL, MYCOL, 0, NPCOL )
+ CALL INFOG1L( K, HBL, NPCOL, MYCOL,
+ $ DESCA(CSRC_), ITMP1,ITMP2 )
+ ITMP2 = NUMROC(K+1,HBL,MYCOL,DESCA(CSRC_),
+ $ NPCOL )
DO 360 J = LILOH, LIHIH
SUM = A( ( ITMP1-1 )*LDA+J ) +
$ V2*A( ITMP1*LDA+J )
@@ -1839,9 +1971,10 @@
CALL DGESD2D( CONTXT, LIHIH-LILOH+1, 1,
$ A( ( ITMP1-1 )*LDA+LILOH ),
$ LDA, MYROW, RIGHT )
- CALL INFOG1L( K, HBL, NPCOL, MYCOL, 0, ITMP1,
- $ ITMP2 )
- ITMP2 = NUMROC( K+1, HBL, MYCOL, 0, NPCOL )
+ CALL INFOG1L( K, HBL, NPCOL, MYCOL,
+ $ DESCA(CSRC_), ITMP1, ITMP2 )
+ ITMP2 = NUMROC( K+1, HBL, MYCOL,
+ $ DESCA(CSRC_), NPCOL )
CALL DGERV2D( CONTXT, LIHIH-LILOH+1, 1,
$ A( ( ITMP1-1 )*LDA+LILOH ),
$ LDA, MYROW, RIGHT )
@@ -1927,17 +2060,17 @@
IF( ( MOD( K1( KI )-1, HBL ).GE.HBL-2 ) .AND.
$ ( ( MYROW.EQ.ICURROW( KI ) ) .OR. ( DOWN.EQ.
$ ICURROW( KI ) ) ) .AND. ( NPROW.GT.1 ) ) THEN
- CALL INFOG1L( K2( KI )+1, HBL, NPROW, MYROW, 0,
- $ KROW( KI ), ITMP2 )
- ITMP2 = NUMROC( N, HBL, MYROW, 0, NPROW )
+ CALL INFOG1L( K2( KI )+1, HBL, NPROW, MYROW,
+ $ DESCA(RSRC_), KROW( KI ), ITMP2 )
+ ITMP2 = NUMROC( N, HBL, MYROW, DESCA(RSRC_), NPROW )
END IF
IF( ( MOD( K2( KI ), HBL ).GE.HBL-2 ) .AND.
$ ( ( MYROW.EQ.ICURROW( KI ) ) .OR. ( UP.EQ.
$ ICURROW( KI ) ) ) .AND. ( NPROW.GT.1 ) ) THEN
- CALL INFOG1L( 1, HBL, NPROW, MYROW, 0, ITMP2,
- $ KP2ROW( KI ) )
- KP2ROW( KI ) = NUMROC( K2( KI )+3, HBL, MYROW, 0,
- $ NPROW )
+ CALL INFOG1L( 1, HBL, NPROW, MYROW, DESCA(RSRC_),
+ $ ITMP2,KP2ROW( KI ) )
+ KP2ROW( KI ) = NUMROC( K2( KI )+3, HBL, MYROW,
+ $ DESCA(RSRC_), NPROW )
END IF
IF( NPCOL.EQ.1 ) THEN
KCOL( KI ) = KCOL( KI ) + K2( KI ) - K1( KI ) + 1
@@ -1956,17 +2089,17 @@
IF( ( MOD( K1( KI )-1, HBL ).GE.HBL-2 ) .AND.
$ ( ( MYCOL.EQ.ICURCOL( KI ) ) .OR. ( RIGHT.EQ.
$ ICURCOL( KI ) ) ) .AND. ( NPCOL.GT.1 ) ) THEN
- CALL INFOG1L( K2( KI )+1, HBL, NPCOL, MYCOL, 0,
- $ KCOL( KI ), ITMP2 )
- ITMP2 = NUMROC( N, HBL, MYCOL, 0, NPCOL )
+ CALL INFOG1L( K2( KI )+1, HBL, NPCOL, MYCOL,
+ $ DESCA(CSRC_), KCOL( KI ), ITMP2 )
+ ITMP2 = NUMROC( N, HBL, MYCOL, DESCA(CSRC_), NPCOL )
END IF
IF( ( MOD( K2( KI ), HBL ).GE.HBL-2 ) .AND.
$ ( ( MYCOL.EQ.ICURCOL( KI ) ) .OR. ( LEFT.EQ.
$ ICURCOL( KI ) ) ) .AND. ( NPCOL.GT.1 ) ) THEN
- CALL INFOG1L( 1, HBL, NPCOL, MYCOL, 0, ITMP2,
+ CALL INFOG1L( 1, HBL, NPCOL, MYCOL,DESCA(CSRC_),ITMP2,
$ KP2COL( KI ) )
- KP2COL( KI ) = NUMROC( K2( KI )+3, HBL, MYCOL, 0,
- $ NPCOL )
+ KP2COL( KI ) = NUMROC( K2( KI )+3, HBL, MYCOL,
+ $ DESCA(CSRC_), NPCOL )
END IF
K1( KI ) = K2( KI ) + 1
ISTOP = MIN( K1( KI )+ROTN-MOD( K1( KI ), ROTN ), I-2 )
@@ -1996,6 +2129,7 @@
* Failure to converge in remaining number of iterations
*
INFO = I
+ WORK( 1 ) = DBLE( LWKOPT )
RETURN
*
430 CONTINUE
@@ -2016,88 +2150,57 @@
*
* H(I-1,I-2) is negligible: a pair of eigenvalues have converged.
*
- WR( I-1 ) = ZERO
- WR( I ) = ZERO
- WI( I-1 ) = ZERO
- WI( I ) = ZERO
- MODKM1 = MOD( I-1+HBL, HBL )
- CALL INFOG2L( I-1, I-1, DESCA, NPROW, NPCOL, MYROW, MYCOL,
- $ IROW1, ICOL1, II, JJ )
- IF( ( MYROW.EQ.II ) .AND. ( MYCOL.EQ.JJ ) ) THEN
- H11 = A( ( ICOL1-1 )*LDA+IROW1 )
- IF( MODKM1.NE.0 ) THEN
- H21 = A( ( ICOL1-1 )*LDA+IROW1+1 )
- H12 = A( ICOL1*LDA+IROW1 )
- H22 = A( ICOL1*LDA+IROW1+1 )
- ELSE
- IF( NPROW.GT.1 ) THEN
- CALL DGERV2D( CONTXT, 1, 1, H21, 1, DOWN, MYCOL )
- ELSE
- H21 = A( ( ICOL1-1 )*LDA+IROW1+1 )
- END IF
- IF( NPCOL.GT.1 ) THEN
- CALL DGERV2D( CONTXT, 1, 1, H12, 1, MYROW, RIGHT )
- ELSE
- H12 = A( ICOL1*LDA+IROW1 )
- END IF
- IF( NUM.GT.1 ) THEN
- CALL DGERV2D( CONTXT, 1, 1, H22, 1, DOWN, RIGHT )
- ELSE
- H22 = A( ICOL1*LDA+IROW1+1 )
- END IF
- END IF
- H00 = HALF*( H11+H22 )
- H10 = H11*H22 - H12*H21
+ CALL PDELGET( 'All', ' ', H11, A, L, L, DESCA )
+ CALL PDELGET( 'All', ' ', H21, A, I, L, DESCA )
+ CALL PDELGET( 'All', ' ', H12, A, L, I, DESCA )
+ CALL PDELGET( 'All', ' ', H22, A, I, I, DESCA )
+ CALL DLANV2( H11, H12, H21, H22, WR( L ), WI( L ), WR( I ),
+ $ WI( I ), CS, SN )
+ CALL PDELSET( A, L, L, DESCA, H11 )
+ CALL PDELSET( A, I, L, DESCA, H21 )
+ CALL PDELSET( A, L, I, DESCA, H12 )
+ CALL PDELSET( A, I, I, DESCA, H22 )
+*
+* Transform H to the standard Schur form
+*
+ IF( WANTT ) THEN
+ IF(I .LT. N) CALL PDROT( N-I, A, L, I+1, DESCA, DESCA( M_ ),
+ $ A, I, I+1, DESCA, DESCA( M_ ), CS,
+ $ SN, WORK( VECSIDX+1 ),
+ $ LWORK-VECSIDX, IERR )
+ LTOP = 1
ELSE
- IF( MODKM1.EQ.0 ) THEN
- IF( ( NPROW.GT.1 ) .AND. ( MYCOL.EQ.JJ ) .AND.
- $ ( UP.EQ.II ) ) THEN
- CALL INFOG2L( I, I-1, DESCA, NPROW, NPCOL, MYROW,
- $ MYCOL, IROW1, ICOL1, ITMP1, ITMP2 )
- CALL DGESD2D( CONTXT, 1, 1,
- $ A( ( ICOL1-1 )*LDA+IROW1 ), 1, II, JJ )
- END IF
- IF( ( NPCOL.GT.1 ) .AND. ( LEFT.EQ.JJ ) .AND.
- $ ( MYROW.EQ.II ) ) THEN
- CALL INFOG2L( I-1, I, DESCA, NPROW, NPCOL, MYROW,
- $ MYCOL, IROW1, ICOL1, ITMP1, ITMP2 )
- CALL DGESD2D( CONTXT, 1, 1,
- $ A( ( ICOL1-1 )*LDA+IROW1 ), 1, II, JJ )
- END IF
- IF( ( NUM.GT.1 ) .AND. ( LEFT.EQ.JJ ) .AND.
- $ ( UP.EQ.II ) ) THEN
- CALL INFOG2L( I, I, DESCA, NPROW, NPCOL, MYROW, MYCOL,
- $ IROW1, ICOL1, ITMP1, ITMP2 )
- CALL DGESD2D( CONTXT, 1, 1,
- $ A( ( ICOL1-1 )*LDA+IROW1 ), 1, II, JJ )
- END IF
- END IF
- H00 = ZERO
- H10 = ZERO
+ LTOP = I1
END IF
- H21 = H00*H00 - H10
- IF( H21.GE.ZERO ) THEN
- H21 = SQRT( H21 )
- WR( I-1 ) = H00 + H21
- WI( I-1 ) = ZERO
- WR( I ) = H00 - H21
- WI( I ) = ZERO
- ELSE
- H21 = SQRT( ABS( H21 ) )
- WR( I-1 ) = H00
- WI( I-1 ) = H21
- WR( I ) = H00
- WI( I ) = -H21
+ IF (L .GT. LTOP) CALL PDROT( L-LTOP, A, LTOP, L, DESCA, 1, A,
+ $ LTOP, I, DESCA, 1, CS, SN,
+ $ WORK( VECSIDX+1 ), LWORK-VECSIDX,
+ $ IERR )
+ IF( WANTZ ) THEN
+ CALL PDROT( IHIZ-ILOZ+1, Z, ILOZ, L, DESCZ, 1, Z, ILOZ, I,
+ $ DESCZ, 1, CS, SN, WORK( VECSIDX+1 ),
+ $ LWORK-VECSIDX, IERR )
END IF
+ IF( NODE .NE. 0 ) THEN
+ WR( L ) = ZERO
+ WR( I ) = ZERO
+ WI( L ) = ZERO
+ WI( I ) = ZERO
+ ENDIF
ELSE
*
* Find the eigenvalues in H(L:I,L:I), L < I-1
*
- JBLK = I - L + 1
- IF( JBLK.LE.2*IBLK ) THEN
- CALL PDLACP3( I-L+1, L, A, DESCA, S1, 2*IBLK, 0, 0, 0 )
- CALL DLAHQR( .FALSE., .FALSE., JBLK, 1, JBLK, S1, 2*IBLK,
- $ WR( L ), WI( L ), 1, JBLK, Z, LDZ, IERR )
+ NH = I - L + 1
+ IF( NH .LE. LDS ) THEN
+ CALL PDLAQR4( WANTT, WANTZ, N, L, I, A, DESCA, WR, WI,
+ $ ILOZ, IHIZ, Z, DESCZ, WORK( S1+1 ), NH,
+ $ WORK( S2+1 ), NH, WORK( S3+1 ), 4*LDS*LDS,
+ $ INFO )
+ IF( INFO.NE.0 ) THEN
+ WORK( 1 ) = DBLE( LWKOPT )
+ RETURN
+ END IF
IF( NODE.NE.0 ) THEN
*
* Erase the eigenvalues
@@ -2123,10 +2226,20 @@
GO TO 10
*
450 CONTINUE
- CALL DGSUM2D( CONTXT, 'All', ' ', N, 1, WR, N, -1, -1 )
- CALL DGSUM2D( CONTXT, 'All', ' ', N, 1, WI, N, -1, -1 )
+*
+ IF( NUM.GT.1 ) THEN
+ CALL DGSUM2D( CONTXT, 'All', ' ', IHI-ILO+1, 1, WR(ILO), N,
+ $ -1, -1 )
+ CALL DGSUM2D( CONTXT, 'All', ' ', IHI-ILO+1, 1, WI(ILO), N,
+ $ -1, -1 )
+ END IF
+*
+ WORK( 1 ) = DBLE( LWKOPT )
+ IWORK( 1 ) = TOTIT
+ IWORK( 2 ) = TOTSW
+ IWORK( 3 ) = TOTNS
RETURN
*
-* END OF PDLAHQR
+* END OF PDLAQR1
*
END
diff --git a/SRC/pdlaqr2.f b/SRC/pdlaqr2.f
new file mode 100644
index 0000000..bae5fb2
--- /dev/null
+++ b/SRC/pdlaqr2.f
@@ -0,0 +1,671 @@
+ SUBROUTINE PDLAQR2( WANTT, WANTZ, N, KTOP, KBOT, NW, A, DESCA,
+ $ ILOZ, IHIZ, Z, DESCZ, NS, ND, SR, SI, T, LDT,
+ $ V, LDV, WR, WI, WORK, LWORK )
+*
+* Contribution from the Department of Computing Science and HPC2N,
+* Umea University, Sweden
+*
+* -- ScaLAPACK routine (version 2.0.2) --
+* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver
+* May 1 2012
+*
+ IMPLICIT NONE
+*
+* .. Scalar Arguments ..
+ INTEGER IHIZ, ILOZ, KBOT, KTOP, LDT, LDV, LWORK, N, ND,
+ $ NS, NW
+ LOGICAL WANTT, WANTZ
+* ..
+* .. Array Arguments ..
+ INTEGER DESCA( * ), DESCZ( * )
+ DOUBLE PRECISION A( * ), SI( KBOT ), SR( KBOT ), T( LDT, * ),
+ $ V( LDV, * ), WORK( * ), WI( * ), WR( * ),
+ $ Z( * )
+* ..
+*
+* Purpose
+* =======
+*
+* Aggressive early deflation:
+*
+* PDLAQR2 accepts as input an upper Hessenberg matrix A and performs an
+* orthogonal similarity transformation designed to detect and deflate
+* fully converged eigenvalues from a trailing principal submatrix. On
+* output A has been overwritten by a new Hessenberg matrix that is a
+* perturbation of an orthogonal similarity transformation of A. It is
+* to be hoped that the final version of H has many zero subdiagonal
+* entries.
+*
+* This routine handles small deflation windows which is affordable by
+* one processor. Normally, it is called by PDLAQR1. All the inputs are
+* assumed to be valid without checking.
+*
+* Notes
+* =====
+*
+* Each global data object is described by an associated description
+* vector. This vector stores the information required to establish
+* the mapping between an object element and its corresponding process
+* and memory location.
+*
+* Let A be a generic term for any 2D block cyclicly distributed array.
+* Such a global array has an associated description vector DESCA.
+* In the following comments, the character _ should be read as
+* "of the global array".
+*
+* NOTATION STORED IN EXPLANATION
+* --------------- -------------- --------------------------------------
+* DTYPE_A(global) DESCA( DTYPE_ )The descriptor type. In this case,
+* DTYPE_A = 1.
+* CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating
+* the BLACS process grid A is distribu-
+* ted over. The context itself is glo-
+* bal, but the handle (the integer
+* value) may vary.
+* M_A (global) DESCA( M_ ) The number of rows in the global
+* array A.
+* N_A (global) DESCA( N_ ) The number of columns in the global
+* array A.
+* MB_A (global) DESCA( MB_ ) The blocking factor used to distribute
+* the rows of the array.
+* NB_A (global) DESCA( NB_ ) The blocking factor used to distribute
+* the columns of the array.
+* RSRC_A (global) DESCA( RSRC_ ) The process row over which the first
+* row of the array A is distributed.
+* CSRC_A (global) DESCA( CSRC_ ) The process column over which the
+* first column of the array A is
+* distributed.
+* LLD_A (local) DESCA( LLD_ ) The leading dimension of the local
+* array. LLD_A >= MAX(1,LOCr(M_A)).
+*
+* Let K be the number of rows or columns of a distributed matrix,
+* and assume that its process grid has dimension p x q.
+* LOCr( K ) denotes the number of elements of K that a process
+* would receive if K were distributed over the p processes of its
+* process column.
+* Similarly, LOCc( K ) denotes the number of elements of K that a
+* process would receive if K were distributed over the q processes of
+* its process row.
+* The values of LOCr() and LOCc() may be determined via a call to the
+* ScaLAPACK tool function, NUMROC:
+* LOCr( M ) = NUMROC( M, MB_A, MYROW, RSRC_A, NPROW ),
+* LOCc( N ) = NUMROC( N, NB_A, MYCOL, CSRC_A, NPCOL ).
+* An upper bound for these quantities may be computed by:
+* LOCr( M ) <= ceil( ceil(M/MB_A)/NPROW )*MB_A
+* LOCc( N ) <= ceil( ceil(N/NB_A)/NPCOL )*NB_A
+*
+* Arguments
+* =========
+*
+* WANTT (global input) LOGICAL
+* If .TRUE., then the Hessenberg matrix H is fully updated
+* so that the quasi-triangular Schur factor may be
+* computed (in cooperation with the calling subroutine).
+* If .FALSE., then only enough of H is updated to preserve
+* the eigenvalues.
+*
+* WANTZ (global input) LOGICAL
+* If .TRUE., then the orthogonal matrix Z is updated so
+* so that the orthogonal Schur factor may be computed
+* (in cooperation with the calling subroutine).
+* If .FALSE., then Z is not referenced.
+*
+* N (global input) INTEGER
+* The order of the matrix H and (if WANTZ is .TRUE.) the
+* order of the orthogonal matrix Z.
+*
+* KTOP (global input) INTEGER
+* KBOT (global input) INTEGER
+* It is assumed without a check that either
+* KBOT = N or H(KBOT+1,KBOT)=0. KBOT and KTOP together
+* determine an isolated block along the diagonal of the
+* Hessenberg matrix. However, H(KTOP,KTOP-1)=0 is not
+* essentially necessary if WANTT is .TRUE. .
+*
+* NW (global input) INTEGER
+* Deflation window size. 1 .LE. NW .LE. (KBOT-KTOP+1).
+* Normally NW .GE. 3 if PDLAQR2 is called by PDLAQR1.
+*
+* A (local input/output) DOUBLE PRECISION array, dimension
+* (DESCH(LLD_),*)
+* On input the initial N-by-N section of A stores the
+* Hessenberg matrix undergoing aggressive early deflation.
+* On output A 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.
+*
+* DESCA (global and local input) INTEGER array of dimension DLEN_.
+* The array descriptor for the distributed matrix A.
+*
+* ILOZ (global input) INTEGER
+* IHIZ (global input) INTEGER
+* Specify the rows of Z to which transformations must be
+* applied if WANTZ is .TRUE.. 1 .LE. ILOZ .LE. IHIZ .LE. N.
+*
+* Z (input/output) DOUBLE PRECISION array, dimension
+* (DESCH(LLD_),*)
+* IF WANTZ is .TRUE., then on output, the orthogonal
+* similarity transformation mentioned above has been
+* accumulated into Z(ILOZ:IHIZ,ILO:IHI) from the right.
+* If WANTZ is .FALSE., then Z is unreferenced.
+*
+* DESCZ (global and local input) INTEGER array of dimension DLEN_.
+* The array descriptor for the distributed matrix Z.
+*
+* NS (global output) INTEGER
+* The number of unconverged (ie approximate) eigenvalues
+* returned in SR and SI that may be used as shifts by the
+* calling subroutine.
+*
+* ND (global output) INTEGER
+* The number of converged eigenvalues uncovered by this
+* subroutine.
+*
+* SR (global output) DOUBLE PRECISION array, dimension KBOT
+* SI (global output) DOUBLE PRECISION array, dimension KBOT
+* On output, the real and imaginary parts of approximate
+* eigenvalues that may be used for shifts are stored in
+* SR(KBOT-ND-NS+1) through SR(KBOT-ND) and
+* SI(KBOT-ND-NS+1) through SI(KBOT-ND), respectively.
+* On proc #0, 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. On other
+* processors, these entries are set to zero.
+*
+* T (local workspace) DOUBLE PRECISION array, dimension LDT*NW.
+*
+* LDT (local input) INTEGER
+* The leading dimension of the array T.
+* LDT >= NW.
+*
+* V (local workspace) DOUBLE PRECISION array, dimension LDV*NW.
+*
+* LDV (local input) INTEGER
+* The leading dimension of the array V.
+* LDV >= NW.
+*
+* WR (local workspace) DOUBLE PRECISION array, dimension KBOT.
+* WI (local workspace) DOUBLE PRECISION array, dimension KBOT.
+*
+* WORK (local workspace) DOUBLE PRECISION array, dimension LWORK.
+*
+* LWORK (local input) INTEGER
+* WORK(LWORK) is a local array and LWORK is assumed big enough
+* so that LWORK >= NW*NW.
+*
+* ================================================================
+* Implemented by
+* Meiyue Shao, Department of Computing Science and HPC2N,
+* Umea University, Sweden
+*
+* ================================================================
+* References:
+* B. Kagstrom, D. Kressner, and M. Shao,
+* On Aggressive Early Deflation in Parallel Variants of the QR
+* Algorithm.
+* Para 2010, to appear.
+*
+* ================================================================
+* .. Parameters ..
+ INTEGER BLOCK_CYCLIC_2D, CSRC_, CTXT_, DLEN_, DTYPE_,
+ $ LLD_, MB_, M_, NB_, N_, RSRC_
+ PARAMETER ( BLOCK_CYCLIC_2D = 1, DLEN_ = 9, DTYPE_ = 1,
+ $ CTXT_ = 2, M_ = 3, N_ = 4, MB_ = 5, NB_ = 6,
+ $ RSRC_ = 7, CSRC_ = 8, LLD_ = 9 )
+ DOUBLE PRECISION ZERO, ONE
+ PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
+* ..
+* .. Local Scalars ..
+ INTEGER CONTXT, HBL, I, I1, I2, IAFIRST, ICOL, ICOL1,
+ $ ICOL2, INFO, II, IROW, IROW1, IROW2, ITMP1,
+ $ ITMP2, J, JAFIRST, JJ, K, L, LDA, LDZ, LLDTMP,
+ $ MYCOL, MYROW, NODE, NPCOL, NPROW, DBLK,
+ $ HSTEP, VSTEP, KKROW, KKCOL, KLN, LTOP, LEFT,
+ $ RIGHT, UP, DOWN, D1, D2
+* ..
+* .. Local Arrays ..
+ INTEGER DESCT( 9 ), DESCV( 9 ), DESCWH( 9 ),
+ $ DESCWV( 9 )
+* ..
+* .. External Functions ..
+ INTEGER NUMROC
+ EXTERNAL NUMROC
+* ..
+* .. External Subroutines ..
+ EXTERNAL BLACS_GRIDINFO, INFOG2L, DLASET,
+ $ DLAQR3, DESCINIT, PDGEMM, PDGEMR2D, DGEMM,
+ $ DLAMOV, DGESD2D, DGERV2D, DGEBS2D, DGEBR2D,
+ $ IGEBS2D, IGEBR2D
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, MIN, MOD
+* ..
+* .. Executable Statements ..
+*
+ INFO = 0
+*
+ IF( N.EQ.0 )
+ $ RETURN
+*
+* NODE (IAFIRST,JAFIRST) OWNS A(1,1)
+*
+ HBL = DESCA( MB_ )
+ CONTXT = DESCA( CTXT_ )
+ LDA = DESCA( LLD_ )
+ IAFIRST = DESCA( RSRC_ )
+ JAFIRST = DESCA( CSRC_ )
+ LDZ = DESCZ( LLD_ )
+ CALL BLACS_GRIDINFO( CONTXT, NPROW, NPCOL, MYROW, MYCOL )
+ NODE = MYROW*NPCOL + MYCOL
+ LEFT = MOD( MYCOL+NPCOL-1, NPCOL )
+ RIGHT = MOD( MYCOL+1, NPCOL )
+ UP = MOD( MYROW+NPROW-1, NPROW )
+ DOWN = MOD( MYROW+1, NPROW )
+*
+* I1 and I2 are the indices of the first row and last column of A
+* to which transformations must be applied.
+*
+ I = KBOT
+ L = KTOP
+ IF( WANTT ) THEN
+ I1 = 1
+ I2 = N
+ LTOP = 1
+ ELSE
+ I1 = L
+ I2 = I
+ LTOP = L
+ END IF
+*
+* Begin Aggressive Early Deflation.
+*
+ DBLK = NW
+ CALL INFOG2L( I-DBLK+1, I-DBLK+1, DESCA, NPROW, NPCOL, MYROW,
+ $ MYCOL, IROW, ICOL, II, JJ )
+ IF ( MYROW .EQ. II ) THEN
+ CALL DESCINIT( DESCT, DBLK, DBLK, DBLK, DBLK, II, JJ, CONTXT,
+ $ LDT, INFO )
+ CALL DESCINIT( DESCV, DBLK, DBLK, DBLK, DBLK, II, JJ, CONTXT,
+ $ LDV, INFO )
+ ELSE
+ CALL DESCINIT( DESCT, DBLK, DBLK, DBLK, DBLK, II, JJ, CONTXT,
+ $ 1, INFO )
+ CALL DESCINIT( DESCV, DBLK, DBLK, DBLK, DBLK, II, JJ, CONTXT,
+ $ 1, INFO )
+ END IF
+ CALL PDGEMR2D( DBLK, DBLK, A, I-DBLK+1, I-DBLK+1, DESCA, T, 1, 1,
+ $ DESCT, CONTXT )
+ IF ( MYROW .EQ. II .AND. MYCOL .EQ. JJ ) THEN
+ CALL DLASET( 'All', DBLK, DBLK, ZERO, ONE, V, LDV )
+ CALL DLAQR3( .TRUE., .TRUE., DBLK, 1, DBLK, DBLK-1, T, LDT, 1,
+ $ DBLK, V, LDV, NS, ND, WR, WI, WORK, DBLK, DBLK,
+ $ WORK( DBLK*DBLK+1 ), DBLK, DBLK, WORK( 2*DBLK*DBLK+1 ),
+ $ DBLK, WORK( 3*DBLK*DBLK+1 ), LWORK-3*DBLK*DBLK )
+ CALL DGEBS2D( CONTXT, 'All', ' ', DBLK, DBLK, V, LDV )
+ CALL IGEBS2D( CONTXT, 'All', ' ', 1, 1, ND, 1 )
+ ELSE
+ CALL DGEBR2D( CONTXT, 'All', ' ', DBLK, DBLK, V, LDV, II, JJ )
+ CALL IGEBR2D( CONTXT, 'All', ' ', 1, 1, ND, 1, II, JJ )
+ END IF
+*
+ IF( ND .GT. 0 ) THEN
+*
+* Copy the local matrix back to the diagonal block.
+*
+ CALL PDGEMR2D( DBLK, DBLK, T, 1, 1, DESCT, A, I-DBLK+1,
+ $ I-DBLK+1, DESCA, CONTXT )
+*
+* Update T and Z.
+*
+ IF( MOD( I-DBLK, HBL )+DBLK .LE. HBL ) THEN
+*
+* Simplest case: the deflation window is located on one
+* processor.
+* Call DGEMM directly to perform the update.
+*
+ HSTEP = LWORK / DBLK
+ VSTEP = HSTEP
+*
+* Update horizontal slab in A.
+*
+ IF( WANTT ) THEN
+ CALL INFOG2L( I-DBLK+1, I+1, DESCA, NPROW, NPCOL, MYROW,
+ $ MYCOL, IROW, ICOL, II, JJ )
+ IF( MYROW .EQ. II ) THEN
+ ICOL1 = NUMROC( N, HBL, MYCOL, JAFIRST, NPCOL )
+ DO 10 KKCOL = ICOL, ICOL1, HSTEP
+ KLN = MIN( HSTEP, ICOL1-KKCOL+1 )
+ CALL DGEMM( 'T', 'N', DBLK, KLN, DBLK, ONE, V,
+ $ LDV, A( IROW+(KKCOL-1)*LDA ), LDA, ZERO, WORK,
+ $ DBLK )
+ CALL DLAMOV( 'A', DBLK, KLN, WORK, DBLK,
+ $ A( IROW+(KKCOL-1)*LDA ), LDA )
+ 10 CONTINUE
+ END IF
+ END IF
+*
+* Update vertical slab in A.
+*
+ CALL INFOG2L( LTOP, I-DBLK+1, DESCA, NPROW, NPCOL, MYROW,
+ $ MYCOL, IROW, ICOL, II, JJ )
+ IF( MYCOL .EQ. JJ ) THEN
+ CALL INFOG2L( I-DBLK, I-DBLK+1, DESCA, NPROW, NPCOL,
+ $ MYROW, MYCOL, IROW1, ICOL1, ITMP1, ITMP2 )
+ IF( MYROW .NE. ITMP1 ) IROW1 = IROW1-1
+ DO 20 KKROW = IROW, IROW1, VSTEP
+ KLN = MIN( VSTEP, IROW1-KKROW+1 )
+ CALL DGEMM( 'N', 'N', KLN, DBLK, DBLK, ONE,
+ $ A( KKROW+(ICOL-1)*LDA ), LDA, V, LDV, ZERO, WORK,
+ $ KLN )
+ CALL DLAMOV( 'A', KLN, DBLK, WORK, KLN,
+ $ A( KKROW+(ICOL-1)*LDA ), LDA )
+ 20 CONTINUE
+ END IF
+*
+* Update vertical slab in Z.
+*
+ IF( WANTZ ) THEN
+ CALL INFOG2L( ILOZ, I-DBLK+1, DESCZ, NPROW, NPCOL, MYROW,
+ $ MYCOL, IROW, ICOL, II, JJ )
+ IF( MYCOL .EQ. JJ ) THEN
+ CALL INFOG2L( IHIZ, I-DBLK+1, DESCZ, NPROW, NPCOL,
+ $ MYROW, MYCOL, IROW1, ICOL1, ITMP1, ITMP2 )
+ IF( MYROW .NE. ITMP1 ) IROW1 = IROW1-1
+ DO 30 KKROW = IROW, IROW1, VSTEP
+ KLN = MIN( VSTEP, IROW1-KKROW+1 )
+ CALL DGEMM( 'N', 'N', KLN, DBLK, DBLK, ONE,
+ $ Z( KKROW+(ICOL-1)*LDZ ), LDZ, V, LDV, ZERO,
+ $ WORK, KLN )
+ CALL DLAMOV( 'A', KLN, DBLK, WORK, KLN,
+ $ Z( KKROW+(ICOL-1)*LDZ ), LDZ )
+ 30 CONTINUE
+ END IF
+ END IF
+*
+ ELSE IF( MOD( I-DBLK, HBL )+DBLK .LE. 2*HBL ) THEN
+*
+* More complicated case: the deflation window lay on a 2x2
+* processor mesh.
+* Call DGEMM locally and communicate by pair.
+*
+ D1 = HBL - MOD( I-DBLK, HBL )
+ D2 = DBLK - D1
+ HSTEP = LWORK / DBLK
+ VSTEP = HSTEP
+*
+* Update horizontal slab in A.
+*
+ IF( WANTT ) THEN
+ CALL INFOG2L( I-DBLK+1, I+1, DESCA, NPROW, NPCOL, MYROW,
+ $ MYCOL, IROW, ICOL, II, JJ )
+ IF( MYROW .EQ. UP ) THEN
+ IF( MYROW .EQ. II ) THEN
+ ICOL1 = NUMROC( N, HBL, MYCOL, JAFIRST, NPCOL )
+ DO 40 KKCOL = ICOL, ICOL1, HSTEP
+ KLN = MIN( HSTEP, ICOL1-KKCOL+1 )
+ CALL DGEMM( 'T', 'N', DBLK, KLN, DBLK, ONE, V,
+ $ DBLK, A( IROW+(KKCOL-1)*LDA ), LDA, ZERO,
+ $ WORK, DBLK )
+ CALL DLAMOV( 'A', DBLK, KLN, WORK, DBLK,
+ $ A( IROW+(KKCOL-1)*LDA ), LDA )
+ 40 CONTINUE
+ END IF
+ ELSE
+ IF( MYROW .EQ. II ) THEN
+ ICOL1 = NUMROC( N, HBL, MYCOL, JAFIRST, NPCOL )
+ DO 50 KKCOL = ICOL, ICOL1, HSTEP
+ KLN = MIN( HSTEP, ICOL1-KKCOL+1 )
+ CALL DGEMM( 'T', 'N', D2, KLN, D1, ONE,
+ $ V( 1, D1+1 ), LDV, A( IROW+(KKCOL-1)*LDA ),
+ $ LDA, ZERO, WORK( D1+1 ), DBLK )
+ CALL DGESD2D( CONTXT, D2, KLN, WORK( D1+1 ),
+ $ DBLK, DOWN, MYCOL )
+ CALL DGERV2D( CONTXT, D1, KLN, WORK, DBLK, DOWN,
+ $ MYCOL )
+ CALL DGEMM( 'T', 'N', D1, KLN, D1, ONE,
+ $ V, LDV, A( IROW+(KKCOL-1)*LDA ), LDA, ONE,
+ $ WORK, DBLK )
+ CALL DLAMOV( 'A', D1, KLN, WORK, DBLK,
+ $ A( IROW+(KKCOL-1)*LDA ), LDA )
+ 50 CONTINUE
+ ELSE IF( UP .EQ. II ) THEN
+ ICOL1 = NUMROC( N, HBL, MYCOL, JAFIRST, NPCOL )
+ DO 60 KKCOL = ICOL, ICOL1, HSTEP
+ KLN = MIN( HSTEP, ICOL1-KKCOL+1 )
+ CALL DGEMM( 'T', 'N', D1, KLN, D2, ONE,
+ $ V( D1+1, 1 ), LDV, A( IROW+(KKCOL-1)*LDA ),
+ $ LDA, ZERO, WORK, DBLK )
+ CALL DGESD2D( CONTXT, D1, KLN, WORK, DBLK, UP,
+ $ MYCOL )
+ CALL DGERV2D( CONTXT, D2, KLN, WORK( D1+1 ),
+ $ DBLK, UP, MYCOL )
+ CALL DGEMM( 'T', 'N', D2, KLN, D2, ONE,
+ $ V( D1+1, D1+1 ), LDV,
+ $ A( IROW+(KKCOL-1)*LDA ), LDA, ONE,
+ $ WORK( D1+1 ), DBLK )
+ CALL DLAMOV( 'A', D2, KLN, WORK( D1+1 ), DBLK,
+ $ A( IROW+(KKCOL-1)*LDA ), LDA )
+ 60 CONTINUE
+ END IF
+ END IF
+ END IF
+*
+* Update vertical slab in A.
+*
+ CALL INFOG2L( LTOP, I-DBLK+1, DESCA, NPROW, NPCOL, MYROW,
+ $ MYCOL, IROW, ICOL, II, JJ )
+ IF( MYCOL .EQ. LEFT ) THEN
+ IF( MYCOL .EQ. JJ ) THEN
+ CALL INFOG2L( I-DBLK, I-DBLK+1, DESCA, NPROW, NPCOL,
+ $ MYROW, MYCOL, IROW1, ICOL1, ITMP1, ITMP2 )
+ IF( MYROW .NE. ITMP1 ) IROW1 = IROW1-1
+ DO 70 KKROW = IROW, IROW1, VSTEP
+ KLN = MIN( VSTEP, IROW1-KKROW+1 )
+ CALL DGEMM( 'N', 'N', KLN, DBLK, DBLK, ONE,
+ $ A( KKROW+(ICOL-1)*LDA ), LDA, V, LDV, ZERO,
+ $ WORK, KLN )
+ CALL DLAMOV( 'A', KLN, DBLK, WORK, KLN,
+ $ A( KKROW+(ICOL-1)*LDA ), LDA )
+ 70 CONTINUE
+ END IF
+ ELSE
+ IF( MYCOL .EQ. JJ ) THEN
+ CALL INFOG2L( I-DBLK, I-DBLK+1, DESCA, NPROW, NPCOL,
+ $ MYROW, MYCOL, IROW1, ICOL1, ITMP1, ITMP2 )
+ IF( MYROW .NE. ITMP1 ) IROW1 = IROW1-1
+ DO 80 KKROW = IROW, IROW1, VSTEP
+ KLN = MIN( VSTEP, IROW1-KKROW+1 )
+ CALL DGEMM( 'N', 'N', KLN, D2, D1, ONE,
+ $ A( KKROW+(ICOL-1)*LDA ), LDA,
+ $ V( 1, D1+1 ), LDV, ZERO, WORK( 1+D1*KLN ),
+ $ KLN )
+ CALL DGESD2D( CONTXT, KLN, D2, WORK( 1+D1*KLN ),
+ $ KLN, MYROW, RIGHT )
+ CALL DGERV2D( CONTXT, KLN, D1, WORK, KLN, MYROW,
+ $ RIGHT )
+ CALL DGEMM( 'N', 'N', KLN, D1, D1, ONE,
+ $ A( KKROW+(ICOL-1)*LDA ), LDA, V, LDV, ONE,
+ $ WORK, KLN )
+ CALL DLAMOV( 'A', KLN, D1, WORK, KLN,
+ $ A( KKROW+(ICOL-1)*LDA ), LDA )
+ 80 CONTINUE
+ ELSE IF ( LEFT .EQ. JJ ) THEN
+ CALL INFOG2L( I-DBLK, I-DBLK+1, DESCA, NPROW, NPCOL,
+ $ MYROW, MYCOL, IROW1, ICOL1, ITMP1, ITMP2 )
+ IF( MYROW .NE. ITMP1 ) IROW1 = IROW1-1
+ DO 90 KKROW = IROW, IROW1, VSTEP
+ KLN = MIN( VSTEP, IROW1-KKROW+1 )
+ CALL DGEMM( 'N', 'N', KLN, D1, D2, ONE,
+ $ A( KKROW+(ICOL-1)*LDA ), LDA, V( D1+1, 1 ),
+ $ LDV, ZERO, WORK, KLN )
+ CALL DGESD2D( CONTXT, KLN, D1, WORK, KLN, MYROW,
+ $ LEFT )
+ CALL DGERV2D( CONTXT, KLN, D2, WORK( 1+D1*KLN ),
+ $ KLN, MYROW, LEFT )
+ CALL DGEMM( 'N', 'N', KLN, D2, D2, ONE,
+ $ A( KKROW+(ICOL-1)*LDA ), LDA, V( D1+1, D1+1 ),
+ $ LDV, ONE, WORK( 1+D1*KLN ), KLN )
+ CALL DLAMOV( 'A', KLN, D2, WORK( 1+D1*KLN ), KLN,
+ $ A( KKROW+(ICOL-1)*LDA ), LDA )
+ 90 CONTINUE
+ END IF
+ END IF
+*
+* Update vertical slab in Z.
+*
+ IF( WANTZ ) THEN
+ CALL INFOG2L( ILOZ, I-DBLK+1, DESCZ, NPROW, NPCOL, MYROW,
+ $ MYCOL, IROW, ICOL, II, JJ )
+ IF( MYCOL .EQ. LEFT ) THEN
+ IF( MYCOL .EQ. JJ ) THEN
+ CALL INFOG2L( IHIZ, I-DBLK+1, DESCZ, NPROW, NPCOL,
+ $ MYROW, MYCOL, IROW1, ICOL1, ITMP1, ITMP2 )
+ IF( MYROW .NE. ITMP1 ) IROW1 = IROW1-1
+ DO 100 KKROW = IROW, IROW1, VSTEP
+ KLN = MIN( VSTEP, IROW1-KKROW+1 )
+ CALL DGEMM( 'N', 'N', KLN, DBLK, DBLK, ONE,
+ $ Z( KKROW+(ICOL-1)*LDZ ), LDZ, V, LDV, ZERO,
+ $ WORK, KLN )
+ CALL DLAMOV( 'A', KLN, DBLK, WORK, KLN,
+ $ Z( KKROW+(ICOL-1)*LDZ ), LDZ )
+ 100 CONTINUE
+ END IF
+ ELSE
+ IF( MYCOL .EQ. JJ ) THEN
+ CALL INFOG2L( IHIZ, I-DBLK+1, DESCZ, NPROW, NPCOL,
+ $ MYROW, MYCOL, IROW1, ICOL1, ITMP1, ITMP2 )
+ IF( MYROW .NE. ITMP1 ) IROW1 = IROW1-1
+ DO 110 KKROW = IROW, IROW1, VSTEP
+ KLN = MIN( VSTEP, IROW1-KKROW+1 )
+ CALL DGEMM( 'N', 'N', KLN, D2, D1, ONE,
+ $ Z( KKROW+(ICOL-1)*LDZ ), LDZ,
+ $ V( 1, D1+1 ), LDV, ZERO, WORK( 1+D1*KLN ),
+ $ KLN )
+ CALL DGESD2D( CONTXT, KLN, D2, WORK( 1+D1*KLN ),
+ $ KLN, MYROW, RIGHT )
+ CALL DGERV2D( CONTXT, KLN, D1, WORK, KLN, MYROW,
+ $ RIGHT )
+ CALL DGEMM( 'N', 'N', KLN, D1, D1, ONE,
+ $ Z( KKROW+(ICOL-1)*LDZ ), LDZ, V, LDV, ONE,
+ $ WORK, KLN )
+ CALL DLAMOV( 'A', KLN, D1, WORK, KLN,
+ $ Z( KKROW+(ICOL-1)*LDZ ), LDZ )
+ 110 CONTINUE
+ ELSE IF( LEFT .EQ. JJ ) THEN
+ CALL INFOG2L( IHIZ, I-DBLK+1, DESCZ, NPROW, NPCOL,
+ $ MYROW, MYCOL, IROW1, ICOL1, ITMP1, ITMP2 )
+ IF( MYROW .NE. ITMP1 ) IROW1 = IROW1-1
+ DO 120 KKROW = IROW, IROW1, VSTEP
+ KLN = MIN( VSTEP, IROW1-KKROW+1 )
+ CALL DGEMM( 'N', 'N', KLN, D1, D2, ONE,
+ $ Z( KKROW+(ICOL-1)*LDZ ), LDZ,
+ $ V( D1+1, 1 ), LDV, ZERO, WORK, KLN )
+ CALL DGESD2D( CONTXT, KLN, D1, WORK, KLN, MYROW,
+ $ LEFT )
+ CALL DGERV2D( CONTXT, KLN, D2, WORK( 1+D1*KLN ),
+ $ KLN, MYROW, LEFT )
+ CALL DGEMM( 'N', 'N', KLN, D2, D2, ONE,
+ $ Z( KKROW+(ICOL-1)*LDZ ), LDZ,
+ $ V( D1+1, D1+1 ), LDV, ONE,
+ $ WORK( 1+D1*KLN ), KLN )
+ CALL DLAMOV( 'A', KLN, D2, WORK( 1+D1*KLN ),
+ $ KLN, Z( KKROW+(ICOL-1)*LDZ ), LDZ )
+ 120 CONTINUE
+ END IF
+ END IF
+ END IF
+*
+ ELSE
+*
+* Most complicated case: the deflation window lay across the
+* border of the processor mesh.
+* Treat V as a distributed matrix and call PDGEMM.
+*
+ HSTEP = LWORK / DBLK * NPCOL
+ VSTEP = LWORK / DBLK * NPROW
+ LLDTMP = NUMROC( DBLK, DBLK, MYROW, 0, NPROW )
+ LLDTMP = MAX( 1, LLDTMP )
+ CALL DESCINIT( DESCV, DBLK, DBLK, DBLK, DBLK, 0, 0, CONTXT,
+ $ LLDTMP, INFO )
+ CALL DESCINIT( DESCWH, DBLK, HSTEP, DBLK, LWORK / DBLK, 0,
+ $ 0, CONTXT, LLDTMP, INFO )
+*
+* Update horizontal slab in A.
+*
+ IF( WANTT ) THEN
+ DO 130 KKCOL = I+1, N, HSTEP
+ KLN = MIN( HSTEP, N-KKCOL+1 )
+ CALL PDGEMM( 'T', 'N', DBLK, KLN, DBLK, ONE, V, 1, 1,
+ $ DESCV, A, I-DBLK+1, KKCOL, DESCA, ZERO, WORK, 1,
+ $ 1, DESCWH )
+ CALL PDGEMR2D( DBLK, KLN, WORK, 1, 1, DESCWH, A,
+ $ I-DBLK+1, KKCOL, DESCA, CONTXT )
+ 130 CONTINUE
+ END IF
+*
+* Update vertical slab in A.
+*
+ DO 140 KKROW = LTOP, I-DBLK, VSTEP
+ KLN = MIN( VSTEP, I-DBLK-KKROW+1 )
+ LLDTMP = NUMROC( KLN, LWORK / DBLK, MYROW, 0, NPROW )
+ LLDTMP = MAX( 1, LLDTMP )
+ CALL DESCINIT( DESCWV, KLN, DBLK, LWORK / DBLK, DBLK, 0,
+ $ 0, CONTXT, LLDTMP, INFO )
+ CALL PDGEMM( 'N', 'N', KLN, DBLK, DBLK, ONE, A, KKROW,
+ $ I-DBLK+1, DESCA, V, 1, 1, DESCV, ZERO, WORK, 1, 1,
+ $ DESCWV )
+ CALL PDGEMR2D( KLN, DBLK, WORK, 1, 1, DESCWV, A, KKROW,
+ $ I-DBLK+1, DESCA, CONTXT )
+ 140 CONTINUE
+*
+* Update vertical slab in Z.
+*
+ IF( WANTZ ) THEN
+ DO 150 KKROW = ILOZ, IHIZ, VSTEP
+ KLN = MIN( VSTEP, IHIZ-KKROW+1 )
+ LLDTMP = NUMROC( KLN, LWORK / DBLK, MYROW, 0, NPROW )
+ LLDTMP = MAX( 1, LLDTMP )
+ CALL DESCINIT( DESCWV, KLN, DBLK, LWORK / DBLK, DBLK,
+ $ 0, 0, CONTXT, LLDTMP, INFO )
+ CALL PDGEMM( 'N', 'N', KLN, DBLK, DBLK, ONE, Z, KKROW,
+ $ I-DBLK+1, DESCZ, V, 1, 1, DESCV, ZERO, WORK, 1,
+ $ 1, DESCWV )
+ CALL PDGEMR2D( KLN, DBLK, WORK, 1, 1, DESCWV, Z,
+ $ KKROW, I-DBLK+1, DESCZ, CONTXT )
+ 150 CONTINUE
+ END IF
+ END IF
+*
+* Extract converged eigenvalues.
+*
+ II = 0
+ 160 CONTINUE
+ IF( II .EQ. ND-1 .OR. WI( DBLK-II ) .EQ. ZERO ) THEN
+ IF( NODE .EQ. 0 ) THEN
+ SR( I-II ) = WR( DBLK-II )
+ ELSE
+ SR( I-II ) = ZERO
+ END IF
+ SI( I-II ) = ZERO
+ II = II + 1
+ ELSE
+ IF( NODE .EQ. 0 ) THEN
+ SR( I-II-1 ) = WR( DBLK-II-1 )
+ SR( I-II ) = WR( DBLK-II )
+ SI( I-II-1 ) = WI( DBLK-II-1 )
+ SI( I-II ) = WI( DBLK-II )
+ ELSE
+ SR( I-II-1 ) = ZERO
+ SR( I-II ) = ZERO
+ SI( I-II-1 ) = ZERO
+ SI( I-II ) = ZERO
+ END IF
+ II = II + 2
+ END IF
+ IF( II .LT. ND ) GOTO 160
+ END IF
+*
+* END OF PDLAQR2
+*
+ END
diff --git a/SRC/pdlaqr3.f b/SRC/pdlaqr3.f
new file mode 100644
index 0000000..caa0975
--- /dev/null
+++ b/SRC/pdlaqr3.f
@@ -0,0 +1,1154 @@
+ RECURSIVE SUBROUTINE PDLAQR3( WANTT, WANTZ, N, KTOP, KBOT, NW, H,
+ $ DESCH, ILOZ, IHIZ, Z, DESCZ, NS, ND,
+ $ SR, SI, V, DESCV, NH, T, DESCT, NV,
+ $ WV, DESCW, WORK, LWORK, IWORK,
+ $ LIWORK, RECLEVEL )
+*
+* Contribution from the Department of Computing Science and HPC2N,
+* Umea University, Sweden
+*
+* -- ScaLAPACK auxiliary routine (version 2.0.1) --
+* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
+* Univ. of Colorado Denver and University of California, Berkeley.
+* January, 2012
+*
+ IMPLICIT NONE
+*
+* .. Scalar Arguments ..
+ INTEGER IHIZ, ILOZ, KBOT, KTOP, LWORK, N, ND, NH, NS,
+ $ NV, NW, LIWORK, RECLEVEL
+ LOGICAL WANTT, WANTZ
+* ..
+* .. Array Arguments ..
+ INTEGER DESCH( * ), DESCZ( * ), DESCT( * ), DESCV( * ),
+ $ DESCW( * ), IWORK( * )
+ DOUBLE PRECISION H( * ), SI( KBOT ), SR( KBOT ), T( * ),
+ $ V( * ), WORK( * ), WV( * ),
+ $ Z( * )
+* ..
+*
+* Purpose
+* =======
+*
+* 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 overwritten 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.
+*
+* Notes
+* =====
+*
+* Each global data object is described by an associated description
+* vector. This vector stores the information required to establish
+* the mapping between an object element and its corresponding process
+* and memory location.
+*
+* Let A be a generic term for any 2D block cyclicly distributed array.
+* Such a global array has an associated description vector DESCA.
+* In the following comments, the character _ should be read as
+* "of the global array".
+*
+* NOTATION STORED IN EXPLANATION
+* --------------- -------------- --------------------------------------
+* DTYPE_A(global) DESCA( DTYPE_ )The descriptor type. In this case,
+* DTYPE_A = 1.
+* CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating
+* the BLACS process grid A is distribu-
+* ted over. The context itself is glo-
+* bal, but the handle (the integer
+* value) may vary.
+* M_A (global) DESCA( M_ ) The number of rows in the global
+* array A.
+* N_A (global) DESCA( N_ ) The number of columns in the global
+* array A.
+* MB_A (global) DESCA( MB_ ) The blocking factor used to distribute
+* the rows of the array.
+* NB_A (global) DESCA( NB_ ) The blocking factor used to distribute
+* the columns of the array.
+* RSRC_A (global) DESCA( RSRC_ ) The process row over which the first
+* row of the array A is distributed.
+* CSRC_A (global) DESCA( CSRC_ ) The process column over which the
+* first column of the array A is
+* distributed.
+* LLD_A (local) DESCA( LLD_ ) The leading dimension of the local
+* array. LLD_A >= MAX(1,LOCr(M_A)).
+*
+* Let K be the number of rows or columns of a distributed matrix,
+* and assume that its process grid has dimension p x q.
+* LOCr( K ) denotes the number of elements of K that a process
+* would receive if K were distributed over the p processes of its
+* process column.
+* Similarly, LOCc( K ) denotes the number of elements of K that a
+* process would receive if K were distributed over the q processes of
+* its process row.
+* The values of LOCr() and LOCc() may be determined via a call to the
+* ScaLAPACK tool function, NUMROC:
+* LOCr( M ) = NUMROC( M, MB_A, MYROW, RSRC_A, NPROW ),
+* LOCc( N ) = NUMROC( N, NB_A, MYCOL, CSRC_A, NPCOL ).
+* An upper bound for these quantities may be computed by:
+* LOCr( M ) <= ceil( ceil(M/MB_A)/NPROW )*MB_A
+* LOCc( N ) <= ceil( ceil(N/NB_A)/NPCOL )*NB_A
+*
+* Arguments
+* =========
+*
+* WANTT (global input) LOGICAL
+* If .TRUE., then the Hessenberg matrix H is fully updated
+* so that the quasi-triangular Schur factor may be
+* computed (in cooperation with the calling subroutine).
+* If .FALSE., then only enough of H is updated to preserve
+* the eigenvalues.
+*
+* WANTZ (global input) LOGICAL
+* If .TRUE., then the orthogonal matrix Z is updated so
+* so that the orthogonal Schur factor may be computed
+* (in cooperation with the calling subroutine).
+* If .FALSE., then Z is not referenced.
+*
+* N (global input) INTEGER
+* The order of the matrix H and (if WANTZ is .TRUE.) the
+* order of the orthogonal matrix Z.
+*
+* KTOP (global input) INTEGER
+* It is assumed that either KTOP = 1 or H(KTOP,KTOP-1)=0.
+* KBOT and KTOP together determine an isolated block
+* along the diagonal of the Hessenberg matrix.
+*
+* KBOT (global input) INTEGER
+* It is assumed without a check that either
+* KBOT = N or H(KBOT+1,KBOT)=0. KBOT and KTOP together
+* determine an isolated block along the diagonal of the
+* Hessenberg matrix.
+*
+* NW (global input) INTEGER
+* Deflation window size. 1 .LE. NW .LE. (KBOT-KTOP+1).
+*
+* H (local input/output) DOUBLE PRECISION array, dimension
+* (DESCH(LLD_),*)
+* 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.
+*
+* DESCH (global and local input) INTEGER array of dimension DLEN_.
+* The array descriptor for the distributed matrix H.
+*
+* ILOZ (global input) INTEGER
+* IHIZ (global input) INTEGER
+* Specify the rows of Z to which transformations must be
+* applied if WANTZ is .TRUE.. 1 .LE. ILOZ .LE. IHIZ .LE. N.
+*
+* Z (input/output) DOUBLE PRECISION array, dimension
+* (DESCH(LLD_),*)
+* IF WANTZ is .TRUE., then on output, the orthogonal
+* similarity transformation mentioned above has been
+* accumulated into Z(ILOZ:IHIZ,ILO:IHI) from the right.
+* If WANTZ is .FALSE., then Z is unreferenced.
+*
+* DESCZ (global and local input) INTEGER array of dimension DLEN_.
+* The array descriptor for the distributed matrix Z.
+*
+* NS (global output) INTEGER
+* The number of unconverged (ie approximate) eigenvalues
+* returned in SR and SI that may be used as shifts by the
+* calling subroutine.
+*
+* ND (global output) INTEGER
+* The number of converged eigenvalues uncovered by this
+* subroutine.
+*
+* SR (global output) DOUBLE PRECISION array, dimension KBOT
+* SI (global output) DOUBLE PRECISION array, dimension KBOT
+* On output, the real and imaginary parts of approximate
+* eigenvalues that may be used for shifts are stored in
+* SR(KBOT-ND-NS+1) through SR(KBOT-ND) and
+* SI(KBOT-ND-NS+1) through SI(KBOT-ND), respectively.
+* The real and imaginary parts of converged eigenvalues
+* are stored in SR(KBOT-ND+1) through SR(KBOT) and
+* SI(KBOT-ND+1) through SI(KBOT), respectively.
+*
+* V (global workspace) DOUBLE PRECISION array, dimension
+* (DESCV(LLD_),*)
+* An NW-by-NW distributed work array.
+*
+* DESCV (global and local input) INTEGER array of dimension DLEN_.
+* The array descriptor for the distributed matrix V.
+*
+* NH (input) INTEGER scalar
+* The number of columns of T. NH.GE.NW.
+*
+* T (global workspace) DOUBLE PRECISION array, dimension
+* (DESCV(LLD_),*)
+*
+* DESCT (global and local input) INTEGER array of dimension DLEN_.
+* The array descriptor for the distributed matrix T.
+*
+* NV (global input) INTEGER
+* The number of rows of work array WV available for
+* workspace. NV.GE.NW.
+*
+* WV (global workspace) DOUBLE PRECISION array, dimension
+* (DESCW(LLD_),*)
+*
+* DESCW (global and local input) INTEGER array of dimension DLEN_.
+* The array descriptor for the distributed matrix WV.
+*
+* WORK (local workspace) DOUBLE PRECISION array, dimension LWORK.
+* On exit, WORK(1) is set to an estimate of the optimal value
+* of LWORK for the given values of N, NW, KTOP and KBOT.
+*
+* LWORK (local input) INTEGER
+* The dimension of the work array WORK. LWORK = 2*NW
+* suffices, but greater efficiency may result from larger
+* values of LWORK.
+*
+* If LWORK = -1, then a workspace query is assumed; PDLAQR3
+* 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.
+*
+* IWORK (local workspace) INTEGER array, dimension (LIWORK)
+*
+* LIWORK (local input) INTEGER
+* The length of the workspace array IWORK
+*
+* ================================================================
+* Based on contributions by
+* Robert Granat and Meiyue Shao,
+* Department of Computing Science and HPC2N,
+* Umea University, Sweden
+*
+* ================================================================
+* .. Parameters ..
+ INTEGER BLOCK_CYCLIC_2D, CSRC_, CTXT_, DLEN_, DTYPE_,
+ $ LLD_, MB_, M_, NB_, N_, RSRC_
+ INTEGER RECMAX
+ LOGICAL SORTGRAD
+ PARAMETER ( BLOCK_CYCLIC_2D = 1, DLEN_ = 9, DTYPE_ = 1,
+ $ CTXT_ = 2, M_ = 3, N_ = 4, MB_ = 5, NB_ = 6,
+ $ RSRC_ = 7, CSRC_ = 8, LLD_ = 9, RECMAX = 3,
+ $ SORTGRAD = .FALSE. )
+ 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,
+ $ ELEM, ELEM1, ELEM2, ELEM3, R1, ANORM, RNORM,
+ $ RESAED
+ INTEGER I, IFST, ILST, INFO, INFQR, J, JW, K, KCOL,
+ $ KEND, KLN, KROW, KWTOP, LTOP, LWK1, LWK2, LWK3,
+ $ LWKOPT, NMIN, LLDH, LLDZ, LLDT, LLDV, LLDWV,
+ $ ICTXT, NPROW, NMAX, NPCOL, MYROW, MYCOL, NB,
+ $ IROFFH, M, RCOLS, TAUROWS, RROWS, TAUCOLS,
+ $ ITAU, IR, IPW, NPROCS, MLOC, IROFFHH,
+ $ ICOFFHH, HHRSRC, HHCSRC, HHROWS, HHCOLS,
+ $ IROFFZZ, ICOFFZZ, ZZRSRC, ZZCSRC, ZZROWS,
+ $ ZZCOLS, IERR, TZROWS0, TZCOLS0, IERR0, IPT0,
+ $ IPZ0, IPW0, NB2, ROUND, LILST, KK, LILST0,
+ $ IWRK1, RSRC, CSRC, LWK4, LWK5, IWRK2, LWK6,
+ $ LWK7, LWK8, ILWKOPT, TZROWS, TZCOLS, NSEL,
+ $ NPMIN, ICTXT_NEW, MYROW_NEW, MYCOL_NEW
+ LOGICAL BULGE, SORTED, LQUERY
+* ..
+* .. Local Arrays ..
+ INTEGER PAR( 6 ), DESCR( DLEN_ ),
+ $ DESCTAU( DLEN_ ), DESCHH( DLEN_ ),
+ $ DESCZZ( DLEN_ ), DESCTZ0( DLEN_ ),
+ $ PMAP( 64*64 )
+ DOUBLE PRECISION DDUM( 1 )
+* ..
+* .. External Functions ..
+ DOUBLE PRECISION DLAMCH, PDLANGE
+ INTEGER PILAENVX, NUMROC, INDXG2P, ICEIL, BLACS_PNUM
+ EXTERNAL DLAMCH, PILAENVX, NUMROC, INDXG2P, PDLANGE,
+ $ MPI_WTIME, ICEIL, BLACS_PNUM
+* ..
+* .. External Subroutines ..
+ EXTERNAL PDCOPY, PDGEHRD, PDGEMM, DLABAD, PDLACPY,
+ $ PDLAQR1, DLANV2, PDLAQR0, PDLARF, PDLARFG,
+ $ PDLASET, PDTRORD, PDELGET, PDELSET,
+ $ PDLAMVE, BLACS_GRIDINFO, BLACS_GRIDMAP,
+ $ BLACS_GRIDEXIT, PDGEMR2D
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, DBLE, INT, MAX, MIN, SQRT
+* ..
+* .. Executable Statements ..
+ ICTXT = DESCH( CTXT_ )
+ CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL )
+ NPROCS = NPROW*NPCOL
+*
+* Extract local leading dimensions, blockfactors, offset for
+* keeping the alignment requirements and size of deflation window.
+*
+ LLDH = DESCH( LLD_ )
+ LLDZ = DESCZ( LLD_ )
+ LLDT = DESCT( LLD_ )
+ LLDV = DESCV( LLD_ )
+ LLDWV = DESCW( LLD_ )
+ NB = DESCH( MB_ )
+ IROFFH = MOD( KTOP - 1, NB )
+ JW = MIN( NW, KBOT-KTOP+1 )
+ NSEL = NB+JW
+*
+* Extract environment variables for parallel eigenvalue reordering.
+*
+ PAR(1) = PILAENVX(ICTXT, 17, 'PDLAQR3', 'SV', JW, NB, -1, -1)
+ PAR(2) = PILAENVX(ICTXT, 18, 'PDLAQR3', 'SV', JW, NB, -1, -1)
+ PAR(3) = PILAENVX(ICTXT, 19, 'PDLAQR3', 'SV', JW, NB, -1, -1)
+ PAR(4) = PILAENVX(ICTXT, 20, 'PDLAQR3', 'SV', JW, NB, -1, -1)
+ PAR(5) = PILAENVX(ICTXT, 21, 'PDLAQR3', 'SV', JW, NB, -1, -1)
+ PAR(6) = PILAENVX(ICTXT, 22, 'PDLAQR3', 'SV', JW, NB, -1, -1)
+*
+* Check if workspace query.
+*
+ LQUERY = LWORK.EQ.-1 .OR. LIWORK.EQ.-1
+*
+* Estimate optimal workspace.
+*
+ IF( JW.LE.2 ) THEN
+ LWKOPT = 1
+ ELSE
+*
+* Workspace query calls to PDGEHRD and PDORMHR.
+*
+ TAUROWS = NUMROC( 1, 1, MYCOL, DESCV(RSRC_), NPROW )
+ TAUCOLS = NUMROC( JW+IROFFH, NB, MYCOL, DESCV(CSRC_),
+ $ NPCOL )
+ CALL PDGEHRD( JW, 1, JW, T, 1, 1, DESCT, WORK, WORK, -1,
+ $ INFO )
+ LWK1 = INT( WORK( 1 ) ) + TAUROWS*TAUCOLS
+*
+* Workspace query call to PDORMHR.
+*
+ CALL PDORMHR( 'Right', 'No', JW, JW, 1, JW, T, 1, 1, DESCT,
+ $ WORK, V, 1, 1, DESCV, WORK, -1, INFO )
+ LWK2 = INT( WORK( 1 ) )
+*
+* Workspace query call to PDLAQR0.
+*
+ NMIN = PILAENVX( ICTXT, 12, 'PDLAQR3', 'SV', JW, 1, JW, LWORK )
+ NMAX = ( N-1 ) / 3
+ IF( JW+IROFFH.GT.NMIN .AND. JW+IROFFH.LE.NMAX
+ $ .AND. RECLEVEL.LT.RECMAX ) THEN
+ CALL PDLAQR0( .TRUE., .TRUE., JW+IROFFH, 1+IROFFH,
+ $ JW+IROFFH, T, DESCT, SR, SI, 1, JW, V, DESCV,
+ $ WORK, -1, IWORK, LIWORK-NSEL, INFQR,
+ $ RECLEVEL+1 )
+ LWK3 = INT( WORK( 1 ) )
+ IWRK1 = IWORK( 1 )
+ ELSE
+ RSRC = DESCT( RSRC_ )
+ CSRC = DESCT( CSRC_ )
+ DESCT( RSRC_ ) = 0
+ DESCT( CSRC_ ) = 0
+ CALL PDLAQR1( .TRUE., .TRUE., JW+IROFFH, 1, JW+IROFFH, T,
+ $ DESCT, SR, SI, 1, JW+IROFFH, V, DESCV, WORK, -1,
+ $ IWORK, LIWORK-NSEL, INFQR )
+ DESCT( RSRC_ ) = RSRC
+ DESCT( CSRC_ ) = CSRC
+ LWK3 = INT( WORK( 1 ) )
+ IWRK1 = IWORK( 1 )
+ END IF
+*
+* Workspace in case of alignment problems.
+*
+ TZROWS0 = NUMROC( JW+IROFFH, NB, MYROW, 0, NPROW )
+ TZCOLS0 = NUMROC( JW+IROFFH, NB, MYCOL, 0, NPCOL )
+ LWK4 = 2 * TZROWS0*TZCOLS0
+*
+* Workspace check for reordering.
+*
+ CALL PDTRORD( 'Vectors', IWORK, PAR, JW+IROFFH, T, 1, 1,
+ $ DESCT, V, 1, 1, DESCV, DDUM, DDUM, MLOC, WORK, -1,
+ $ IWORK, LIWORK-NSEL, INFO )
+ LWK5 = INT( WORK( 1 ) )
+ IWRK2 = IWORK( 1 )
+*
+* Extra workspace for reflecting back spike
+* (workspace for PDLARF approximated for simplicity).
+*
+ RROWS = NUMROC( N+IROFFH, NB, MYROW, DESCV(RSRC_), NPROW )
+ RCOLS = NUMROC( 1, 1, MYCOL, DESCV(CSRC_), NPCOL )
+ LWK6 = RROWS*RCOLS + TAUROWS*TAUCOLS +
+ $ 2*ICEIL(ICEIL(JW+IROFFH,NB),NPROW)*NB
+ $ *ICEIL(ICEIL(JW+IROFFH,NB),NPCOL)*NB
+*
+* Extra workspace needed by PBLAS update calls
+* (also estimated for simplicity).
+*
+ LWK7 = MAX( ICEIL(ICEIL(JW,NB),NPROW)*NB *
+ $ ICEIL(ICEIL(N-KBOT,NB),NPCOL)*NB,
+ $ ICEIL(ICEIL(IHIZ-ILOZ+1,NB),NPROW)*NB *
+ $ ICEIL(ICEIL(JW,NB),NPCOL)*NB,
+ $ ICEIL(ICEIL(KBOT-JW,NB),NPROW)*NB *
+ $ ICEIL(ICEIL(JW,NB),NPCOL)*NB )
+*
+* Residual check workspace.
+*
+ LWK8 = 0
+*
+* Optimal workspace.
+*
+ LWKOPT = MAX( LWK1, LWK2, LWK3+LWK4, LWK5, LWK6, LWK7, LWK8 )
+ ILWKOPT = MAX( IWRK1, IWRK2 )
+ END IF
+*
+* Quick return in case of workspace query.
+*
+ WORK( 1 ) = DBLE( LWKOPT )
+*
+* IWORK(1:NSEL) is used as the array SELECT for PDTRORD.
+*
+ IWORK( 1 ) = ILWKOPT + NSEL
+ IF( LQUERY )
+ $ RETURN
+*
+* Nothing to do for an empty active block ...
+ NS = 0
+ ND = 0
+ IF( KTOP.GT.KBOT )
+ $ RETURN
+* ... nor for an empty deflation window.
+*
+ IF( NW.LT.1 )
+ $ RETURN
+*
+* Machine constants.
+*
+ SAFMIN = DLAMCH( 'SAFE MINIMUM' )
+ SAFMAX = ONE / SAFMIN
+ CALL DLABAD( SAFMIN, SAFMAX )
+ ULP = DLAMCH( 'PRECISION' )
+ SMLNUM = SAFMIN*( DBLE( N ) / ULP )
+*
+* Setup deflation window.
+*
+ JW = MIN( NW, KBOT-KTOP+1 )
+ KWTOP = KBOT - JW + 1
+ IF( KWTOP.EQ.KTOP ) THEN
+ S = ZERO
+ ELSE
+ CALL PDELGET( 'All', '1-Tree', S, H, KWTOP, KWTOP-1, DESCH )
+ END IF
+*
+ IF( KBOT.EQ.KWTOP ) THEN
+*
+* 1-by-1 deflation window: not much to do.
+*
+ CALL PDELGET( 'All', '1-Tree', SR( KWTOP ), H, KWTOP, KWTOP,
+ $ DESCH )
+ SI( KWTOP ) = ZERO
+ NS = 1
+ ND = 0
+ IF( ABS( S ).LE.MAX( SMLNUM, ULP*ABS( SR( KWTOP ) ) ) )
+ $ THEN
+ NS = 0
+ ND = 1
+ IF( KWTOP.GT.KTOP )
+ $ CALL PDELSET( H, KWTOP, KWTOP-1 , DESCH, ZERO )
+ END IF
+ RETURN
+ END IF
+*
+ IF( KWTOP.EQ.KTOP .AND. KBOT-KWTOP.EQ.1 ) THEN
+*
+* 2-by-2 deflation window: a little more to do.
+*
+ CALL PDELGET( 'All', '1-Tree', AA, H, KWTOP, KWTOP, DESCH )
+ CALL PDELGET( 'All', '1-Tree', BB, H, KWTOP, KWTOP+1, DESCH )
+ CALL PDELGET( 'All', '1-Tree', CC, H, KWTOP+1, KWTOP, DESCH )
+ CALL PDELGET( 'All', '1-Tree', DD, H, KWTOP+1, KWTOP+1, DESCH )
+ CALL DLANV2( AA, BB, CC, DD, SR(KWTOP), SI(KWTOP),
+ $ SR(KWTOP+1), SI(KWTOP+1), CS, SN )
+ NS = 0
+ ND = 2
+ IF( CC.EQ.ZERO ) THEN
+ I = KWTOP
+ IF( I+2.LE.N .AND. WANTT )
+ $ CALL PDROT( N-I-1, H, I, I+2, DESCH, DESCH(M_), H, I+1,
+ $ I+2, DESCH, DESCH(M_), CS, SN, WORK, LWORK, INFO )
+ IF( I.GT.1 )
+ $ CALL PDROT( I-1, H, 1, I, DESCH, 1, H, 1, I+1, DESCH, 1,
+ $ CS, SN, WORK, LWORK, INFO )
+ IF( WANTZ )
+ $ CALL PDROT( IHIZ-ILOZ+1, Z, ILOZ, I, DESCZ, 1, Z, ILOZ,
+ $ I+1, DESCZ, 1, CS, SN, WORK, LWORK, INFO )
+ CALL PDELSET( H, I, I, DESCH, AA )
+ CALL PDELSET( H, I, I+1, DESCH, BB )
+ CALL PDELSET( H, I+1, I, DESCH, CC )
+ CALL PDELSET( H, I+1, I+1, DESCH, DD )
+ END IF
+ WORK( 1 ) = DBLE( LWKOPT )
+ RETURN
+ END IF
+*
+* Calculate new value for IROFFH in case deflation window
+* was adjusted.
+*
+ IROFFH = MOD( KWTOP - 1, NB )
+*
+* Adjust number of rows and columns of T matrix descriptor
+* to prepare for call to PDBTRORD.
+*
+ DESCT( M_ ) = JW+IROFFH
+ DESCT( N_ ) = JW+IROFFH
+*
+* 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.)
+*
+* Copy the trailing submatrix to the working space.
+*
+ CALL PDLASET( 'All', IROFFH, JW+IROFFH, ZERO, ONE, T, 1, 1,
+ $ DESCT )
+ CALL PDLASET( 'All', JW, IROFFH, ZERO, ZERO, T, 1+IROFFH, 1,
+ $ DESCT )
+ CALL PDLACPY( 'All', 1, JW, H, KWTOP, KWTOP, DESCH, T, 1+IROFFH,
+ $ 1+IROFFH, DESCT )
+ CALL PDLACPY( 'Upper', JW-1, JW-1, H, KWTOP+1, KWTOP, DESCH, T,
+ $ 1+IROFFH+1, 1+IROFFH, DESCT )
+ IF( JW.GT.2 )
+ $ CALL PDLASET( 'Lower', JW-2, JW-2, ZERO, ZERO, T, 1+IROFFH+2,
+ $ 1+IROFFH, DESCT )
+ CALL PDLACPY( 'All', JW-1, 1, H, KWTOP+1, KWTOP+JW-1, DESCH, T,
+ $ 1+IROFFH+1, 1+IROFFH+JW-1, DESCT )
+*
+* Initialize the working orthogonal matrix.
+*
+ CALL PDLASET( 'All', JW+IROFFH, JW+IROFFH, ZERO, ONE, V, 1, 1,
+ $ DESCV )
+*
+* Compute the Schur form of T.
+*
+ NPMIN = PILAENVX( ICTXT, 23, 'PDLAQR3', 'SV', JW, NB, NPROW,
+ $ NPCOL )
+ NMIN = PILAENVX( ICTXT, 12, 'PDLAQR3', 'SV', JW, 1, JW, LWORK )
+ NMAX = ( N-1 ) / 3
+ IF( MIN(NPROW, NPCOL).LE.NPMIN+1 .OR. RECLEVEL.GE.1 ) THEN
+*
+* The AED window is large enough.
+* Compute the Schur decomposition with all processors.
+*
+ IF( JW+IROFFH.GT.NMIN .AND. JW+IROFFH.LE.NMAX
+ $ .AND. RECLEVEL.LT.RECMAX ) THEN
+ CALL PDLAQR0( .TRUE., .TRUE., JW+IROFFH, 1+IROFFH,
+ $ JW+IROFFH, T, DESCT, SR( KWTOP-IROFFH ),
+ $ SI( KWTOP-IROFFH ), 1+IROFFH, JW+IROFFH, V, DESCV,
+ $ WORK, LWORK, IWORK(NSEL+1), LIWORK-NSEL, INFQR,
+ $ RECLEVEL+1 )
+ ELSE
+ IF( DESCT(RSRC_).EQ.0 .AND. DESCT(CSRC_).EQ.0 ) THEN
+ IF( JW+IROFFH.GT.DESCT( MB_ ) ) THEN
+ CALL PDLAQR1( .TRUE., .TRUE., JW+IROFFH, 1,
+ $ JW+IROFFH, T, DESCT, SR( KWTOP-IROFFH ),
+ $ SI( KWTOP-IROFFH ), 1, JW+IROFFH, V,
+ $ DESCV, WORK, LWORK, IWORK(NSEL+1), LIWORK-NSEL,
+ $ INFQR )
+ ELSE
+ IF( MYROW.EQ.0 .AND. MYCOL.EQ.0 ) THEN
+ CALL DLAHQR( .TRUE., .TRUE., JW+IROFFH, 1+IROFFH,
+ $ JW+IROFFH, T, DESCT(LLD_),
+ $ SR( KWTOP-IROFFH ), SI( KWTOP-IROFFH ),
+ $ 1+IROFFH, JW+IROFFH, V, DESCV(LLD_), INFQR )
+ ELSE
+ INFQR = 0
+ END IF
+ IF( NPROCS.GT.1 )
+ $ CALL IGAMN2D( ICTXT, 'All', '1-Tree', 1, 1, INFQR,
+ $ 1, -1, -1, -1, -1, -1 )
+ END IF
+ ELSEIF( JW+IROFFH.LE.DESCT( MB_ ) ) THEN
+ IF( MYROW.EQ.DESCT(RSRC_) .AND. MYCOL.EQ.DESCT(CSRC_) )
+ $ THEN
+ CALL DLAHQR( .TRUE., .TRUE., JW+IROFFH, 1+IROFFH,
+ $ JW+IROFFH, T, DESCT(LLD_),
+ $ SR( KWTOP-IROFFH ), SI( KWTOP-IROFFH ),
+ $ 1+IROFFH, JW+IROFFH, V, DESCV(LLD_), INFQR )
+ ELSE
+ INFQR = 0
+ END IF
+ IF( NPROCS.GT.1 )
+ $ CALL IGAMN2D( ICTXT, 'All', '1-Tree', 1, 1, INFQR,
+ $ 1, -1, -1, -1, -1, -1 )
+ ELSE
+ TZROWS0 = NUMROC( JW+IROFFH, NB, MYROW, 0, NPROW )
+ TZCOLS0 = NUMROC( JW+IROFFH, NB, MYCOL, 0, NPCOL )
+ CALL DESCINIT( DESCTZ0, JW+IROFFH, JW+IROFFH, NB, NB, 0,
+ $ 0, ICTXT, MAX(1,TZROWS0), IERR0 )
+ IPT0 = 1
+ IPZ0 = IPT0 + MAX(1,TZROWS0)*TZCOLS0
+ IPW0 = IPZ0 + MAX(1,TZROWS0)*TZCOLS0
+ CALL PDLAMVE( 'All', JW+IROFFH, JW+IROFFH, T, 1, 1,
+ $ DESCT, WORK(IPT0), 1, 1, DESCTZ0, WORK(IPW0) )
+ CALL PDLASET( 'All', JW+IROFFH, JW+IROFFH, ZERO, ONE,
+ $ WORK(IPZ0), 1, 1, DESCTZ0 )
+ CALL PDLAQR1( .TRUE., .TRUE., JW+IROFFH, 1,
+ $ JW+IROFFH, WORK(IPT0), DESCTZ0,
+ $ SR( KWTOP-IROFFH ), SI( KWTOP-IROFFH ),
+ $ 1, JW+IROFFH, WORK(IPZ0),
+ $ DESCTZ0, WORK(IPW0), LWORK-IPW0+1, IWORK(NSEL+1),
+ $ LIWORK-NSEL, INFQR )
+ CALL PDLAMVE( 'All', JW+IROFFH, JW+IROFFH, WORK(IPT0), 1,
+ $ 1, DESCTZ0, T, 1, 1, DESCT, WORK(IPW0) )
+ CALL PDLAMVE( 'All', JW+IROFFH, JW+IROFFH, WORK(IPZ0), 1,
+ $ 1, DESCTZ0, V, 1, 1, DESCV, WORK(IPW0) )
+ END IF
+ END IF
+ ELSE
+*
+* The AED window is too small.
+* Redistribute the AED window to a subgrid
+* and do the computation on the subgrid.
+*
+ ICTXT_NEW = ICTXT
+ DO 20 I = 0, NPMIN-1
+ DO 10 J = 0, NPMIN-1
+ PMAP( J+1+I*NPMIN ) = BLACS_PNUM( ICTXT, I, J )
+ 10 CONTINUE
+ 20 CONTINUE
+ CALL BLACS_GRIDMAP( ICTXT_NEW, PMAP, NPMIN, NPMIN, NPMIN )
+ CALL BLACS_GRIDINFO( ICTXT_NEW, NPMIN, NPMIN, MYROW_NEW,
+ $ MYCOL_NEW )
+ IF( MYROW.GE.NPMIN .OR. MYCOL.GE.NPMIN ) ICTXT_NEW = -1
+ IF( ICTXT_NEW.GE.0 ) THEN
+ TZROWS0 = NUMROC( JW, NB, MYROW_NEW, 0, NPMIN )
+ TZCOLS0 = NUMROC( JW, NB, MYCOL_NEW, 0, NPMIN )
+ CALL DESCINIT( DESCTZ0, JW, JW, NB, NB, 0,
+ $ 0, ICTXT_NEW, MAX(1,TZROWS0), IERR0 )
+ IPT0 = 1
+ IPZ0 = IPT0 + MAX(1,TZROWS0)*MAX(1,TZCOLS0)
+ IPW0 = IPZ0 + MAX(1,TZROWS0)*MAX(1,TZCOLS0)
+ ELSE
+ IPT0 = 1
+ IPZ0 = 2
+ IPW0 = 3
+ DESCTZ0( CTXT_ ) = -1
+ INFQR = 0
+ END IF
+ CALL PDGEMR2D( JW, JW, T, 1+IROFFH, 1+IROFFH, DESCT,
+ $ WORK(IPT0), 1, 1, DESCTZ0, ICTXT )
+ IF( ICTXT_NEW.GE.0 ) THEN
+ CALL PDLASET( 'All', JW, JW, ZERO, ONE, WORK(IPZ0), 1, 1,
+ $ DESCTZ0 )
+ NMIN = PILAENVX( ICTXT_NEW, 12, 'PDLAQR3', 'SV', JW, 1, JW,
+ $ LWORK )
+ IF( JW.GT.NMIN .AND. JW.LE.NMAX .AND. RECLEVEL.LT.1 ) THEN
+ CALL PDLAQR0( .TRUE., .TRUE., JW, 1, JW, WORK(IPT0),
+ $ DESCTZ0, SR( KWTOP ), SI( KWTOP ), 1, JW,
+ $ WORK(IPZ0), DESCTZ0, WORK(IPW0), LWORK-IPW0+1,
+ $ IWORK(NSEL+1), LIWORK-NSEL, INFQR,
+ $ RECLEVEL+1 )
+ ELSE
+ CALL PDLAQR1( .TRUE., .TRUE., JW, 1, JW, WORK(IPT0),
+ $ DESCTZ0, SR( KWTOP ), SI( KWTOP ), 1, JW,
+ $ WORK(IPZ0), DESCTZ0, WORK(IPW0), LWORK-IPW0+1,
+ $ IWORK(NSEL+1), LIWORK-NSEL, INFQR )
+ END IF
+ END IF
+ CALL PDGEMR2D( JW, JW, WORK(IPT0), 1, 1, DESCTZ0, T, 1+IROFFH,
+ $ 1+IROFFH, DESCT, ICTXT )
+ CALL PDGEMR2D( JW, JW, WORK(IPZ0), 1, 1, DESCTZ0, V, 1+IROFFH,
+ $ 1+IROFFH, DESCV, ICTXT )
+ IF( ICTXT_NEW.GE.0 )
+ $ CALL BLACS_GRIDEXIT( ICTXT_NEW )
+ IF( MYROW+MYCOL.GT.0 ) THEN
+ DO 40 J = 0, JW-1
+ SR( KWTOP+J ) = ZERO
+ SI( KWTOP+J ) = ZERO
+ 40 CONTINUE
+ END IF
+ CALL IGAMN2D( ICTXT, 'All', '1-Tree', 1, 1, INFQR, 1, -1, -1,
+ $ -1, -1, -1 )
+ CALL DGSUM2D( ICTXT, 'All', ' ', JW, 1, SR(KWTOP), JW, -1, -1 )
+ CALL DGSUM2D( ICTXT, 'All', ' ', JW, 1, SI(KWTOP), JW, -1, -1 )
+ END IF
+*
+* Adjust INFQR for offset from block border in submatrices.
+*
+ IF( INFQR.NE.0 )
+ $ INFQR = INFQR - IROFFH
+*
+* PDTRORD needs a clean margin near the diagonal.
+*
+ DO 50 J = 1, JW - 3
+ CALL PDELSET( T, J+2, J, DESCT, ZERO )
+ CALL PDELSET( T, J+3, J, DESCT, ZERO )
+ 50 CONTINUE
+ IF( JW.GT.2 )
+ $ CALL PDELSET( T, JW, JW-2, DESCT, ZERO )
+*
+* Check local residual for AED Schur decomposition.
+*
+ RESAED = 0.0D+00
+*
+* Clean up the array SELECT for PDTRORD.
+*
+ DO 60 J = 1, NSEL
+ IWORK( J ) = 0
+ 60 CONTINUE
+*
+* Set local M counter to zero.
+*
+ MLOC = 0
+*
+* Outer deflation detection loop (label 80).
+* In this loop a bunch of undeflatable eigenvalues
+* are moved simultaneously.
+*
+ DO 70 J = 1, IROFFH + INFQR
+ IWORK( J ) = 1
+ 70 CONTINUE
+*
+ NS = JW
+ ILST = INFQR + 1 + IROFFH
+ IF( ILST.GT.1 ) THEN
+ CALL PDELGET( 'All', '1-Tree', ELEM, T, ILST, ILST-1, DESCT )
+ BULGE = ELEM.NE.ZERO
+ IF( BULGE ) ILST = ILST+1
+ END IF
+*
+ 80 CONTINUE
+ IF( ILST.LE.NS+IROFFH ) THEN
+*
+* Find the top-left corner of the local window.
+*
+ LILST = MAX(ILST,NS+IROFFH-NB+1)
+ IF( LILST.GT.1 ) THEN
+ CALL PDELGET( 'All', '1-Tree', ELEM, T, LILST, LILST-1,
+ $ DESCT )
+ BULGE = ELEM.NE.ZERO
+ IF( BULGE ) LILST = LILST+1
+ END IF
+*
+* Lock all eigenvalues outside the local window.
+*
+ DO 90 J = IROFFH+1, LILST-1
+ IWORK( J ) = 1
+ 90 CONTINUE
+ LILST0 = LILST
+*
+* Inner deflation detection loop (label 100).
+* In this loop, the undeflatable eigenvalues are moved to the
+* top-left corner of the local window.
+*
+ 100 CONTINUE
+ IF( LILST.LE.NS+IROFFH ) THEN
+ IF( NS.EQ.1 ) THEN
+ BULGE = .FALSE.
+ ELSE
+ CALL PDELGET( 'All', '1-Tree', ELEM, T, NS+IROFFH,
+ $ NS+IROFFH-1, DESCT )
+ BULGE = ELEM.NE.ZERO
+ END IF
+*
+* Small spike tip test for deflation.
+*
+ IF( .NOT.BULGE ) THEN
+*
+* Real eigenvalue.
+*
+ CALL PDELGET( 'All', '1-Tree', ELEM, T, NS+IROFFH,
+ $ NS+IROFFH, DESCT )
+ FOO = ABS( ELEM )
+ IF( FOO.EQ.ZERO )
+ $ FOO = ABS( S )
+ CALL PDELGET( 'All', '1-Tree', ELEM, V, 1+IROFFH,
+ $ NS+IROFFH, DESCV )
+ IF( ABS( S*ELEM ).LE.MAX( SMLNUM, ULP*FOO ) ) THEN
+*
+* Deflatable.
+*
+ NS = NS - 1
+ ELSE
+*
+* Undeflatable: move it up out of the way.
+*
+ IFST = NS
+ DO 110 J = LILST, JW+IROFFH
+ IWORK( J ) = 0
+ 110 CONTINUE
+ IWORK( IFST+IROFFH ) = 1
+ CALL PDTRORD( 'Vectors', IWORK, PAR, JW+IROFFH, T, 1,
+ $ 1, DESCT, V, 1, 1, DESCV, WORK,
+ $ WORK(JW+IROFFH+1), MLOC,
+ $ WORK(2*(JW+IROFFH)+1), LWORK-2*(JW+IROFFH),
+ $ IWORK(NSEL+1), LIWORK-NSEL, INFO )
+*
+* Adjust the array SELECT explicitly so that it does not
+* rely on the output of PDTRORD.
+*
+ IWORK( IFST+IROFFH ) = 0
+ IWORK( LILST ) = 1
+ LILST = LILST + 1
+*
+* In case of a rare exchange failure, adjust the
+* pointers ILST and LILST to the current place to avoid
+* unexpected behaviors.
+*
+ IF( INFO.NE.0 ) THEN
+ LILST = MAX(INFO, LILST)
+ ILST = MAX(INFO, ILST)
+ END IF
+ END IF
+ ELSE
+*
+* Complex conjugate pair.
+*
+ CALL PDELGET( 'All', '1-Tree', ELEM1, T, NS+IROFFH,
+ $ NS+IROFFH, DESCT )
+ CALL PDELGET( 'All', '1-Tree', ELEM2, T, NS+IROFFH,
+ $ NS+IROFFH-1, DESCT )
+ CALL PDELGET( 'All', '1-Tree', ELEM3, T, NS+IROFFH-1,
+ $ NS+IROFFH, DESCT )
+ FOO = ABS( ELEM1 ) + SQRT( ABS( ELEM2 ) )*
+ $ SQRT( ABS( ELEM3 ) )
+ IF( FOO.EQ.ZERO )
+ $ FOO = ABS( S )
+ CALL PDELGET( 'All', '1-Tree', ELEM1, V, 1+IROFFH,
+ $ NS+IROFFH, DESCV )
+ CALL PDELGET( 'All', '1-Tree', ELEM2, V, 1+IROFFH,
+ $ NS+IROFFH-1, DESCV )
+ IF( MAX( ABS( S*ELEM1 ), ABS( S*ELEM2 ) ).LE.
+ $ MAX( SMLNUM, ULP*FOO ) ) THEN
+*
+* Deflatable.
+*
+ NS = NS - 2
+ ELSE
+*
+* Undeflatable: move them up out of the way.
+*
+ IFST = NS
+ DO 120 J = LILST, JW+IROFFH
+ IWORK( J ) = 0
+ 120 CONTINUE
+ IWORK( IFST+IROFFH ) = 1
+ IWORK( IFST+IROFFH-1 ) = 1
+ CALL PDTRORD( 'Vectors', IWORK, PAR, JW+IROFFH, T, 1,
+ $ 1, DESCT, V, 1, 1, DESCV, WORK,
+ $ WORK(JW+IROFFH+1), MLOC,
+ $ WORK(2*(JW+IROFFH)+1), LWORK-2*(JW+IROFFH),
+ $ IWORK(NSEL+1), LIWORK-NSEL, INFO )
+*
+* Adjust the array SELECT explicitly so that it does not
+* rely on the output of PDTRORD.
+*
+ IWORK( IFST+IROFFH ) = 0
+ IWORK( IFST+IROFFH-1 ) = 0
+ IWORK( LILST ) = 1
+ IWORK( LILST+1 ) = 1
+ LILST = LILST + 2
+*
+* In case of a rare exchange failure, adjust the
+* pointers ILST and LILST to the current place to avoid
+* unexpected behaviors.
+*
+ IF( INFO.NE.0 ) THEN
+ LILST = MAX(INFO, LILST)
+ ILST = MAX(INFO, ILST)
+ END IF
+ END IF
+ END IF
+*
+* End of inner deflation detection loop.
+*
+ GO TO 100
+ END IF
+*
+* Unlock the eigenvalues outside the local window.
+* Then undeflatable eigenvalues are moved to the proper position.
+*
+ DO 130 J = ILST, LILST0-1
+ IWORK( J ) = 0
+ 130 CONTINUE
+ CALL PDTRORD( 'Vectors', IWORK, PAR, JW+IROFFH, T, 1, 1,
+ $ DESCT, V, 1, 1, DESCV, WORK, WORK(JW+IROFFH+1),
+ $ M, WORK(2*(JW+IROFFH)+1), LWORK-2*(JW+IROFFH),
+ $ IWORK(NSEL+1), LIWORK-NSEL, INFO )
+ ILST = M + 1
+*
+* In case of a rare exchange failure, adjust the pointer ILST to
+* the current place to avoid unexpected behaviors.
+*
+ IF( INFO.NE.0 )
+ $ ILST = MAX(INFO, ILST)
+*
+* End of outer deflation detection loop.
+*
+ GO TO 80
+ END IF
+
+*
+* Post-reordering step: copy output eigenvalues to output.
+*
+ CALL DCOPY( JW, WORK(1+IROFFH), 1, SR( KWTOP ), 1 )
+ CALL DCOPY( JW, WORK(JW+2*IROFFH+1), 1, SI( KWTOP ), 1 )
+*
+* Check local residual for reordered AED Schur decomposition.
+*
+ RESAED = 0.0D+00
+*
+* Return to Hessenberg form.
+*
+ IF( NS.EQ.0 )
+ $ S = ZERO
+*
+ IF( NS.LT.JW .AND. SORTGRAD ) THEN
+*
+* Sorting diagonal blocks of T improves accuracy for
+* graded matrices. Bubble sort deals well with exchange
+* failures. Eigenvalues/shifts from T are also restored.
+*
+ ROUND = 0
+ SORTED = .FALSE.
+ I = NS + 1 + IROFFH
+ 140 CONTINUE
+ IF( SORTED )
+ $ GO TO 180
+ SORTED = .TRUE.
+ ROUND = ROUND + 1
+*
+ KEND = I - 1
+ I = INFQR + 1 + IROFFH
+ IF( I.EQ.NS+IROFFH ) THEN
+ K = I + 1
+ ELSE IF( SI( KWTOP-IROFFH + I-1 ).EQ.ZERO ) THEN
+ K = I + 1
+ ELSE
+ K = I + 2
+ END IF
+ 150 CONTINUE
+ IF( K.LE.KEND ) THEN
+ IF( K.EQ.I+1 ) THEN
+ EVI = ABS( SR( KWTOP-IROFFH+I-1 ) )
+ ELSE
+ EVI = ABS( SR( KWTOP-IROFFH+I-1 ) ) +
+ $ ABS( SI( KWTOP-IROFFH+I-1 ) )
+ END IF
+*
+ IF( K.EQ.KEND ) THEN
+ EVK = ABS( SR( KWTOP-IROFFH+K-1 ) )
+ ELSEIF( SI( KWTOP-IROFFH+K-1 ).EQ.ZERO ) THEN
+ EVK = ABS( SR( KWTOP-IROFFH+K-1 ) )
+ ELSE
+ EVK = ABS( SR( KWTOP-IROFFH+K-1 ) ) +
+ $ ABS( SI( KWTOP-IROFFH+K-1 ) )
+ END IF
+*
+ IF( EVI.GE.EVK ) THEN
+ I = K
+ ELSE
+ MLOC = 0
+ SORTED = .FALSE.
+ IFST = I
+ ILST = K
+ DO 160 J = 1, I-1
+ IWORK( J ) = 1
+ MLOC = MLOC + 1
+ 160 CONTINUE
+ IF( K.EQ.I+2 ) THEN
+ IWORK( I ) = 0
+ IWORK(I+1) = 0
+ ELSE
+ IWORK( I ) = 0
+ END IF
+ IF( K.NE.KEND .AND. SI( KWTOP-IROFFH+K-1 ).NE.ZERO ) THEN
+ IWORK( K ) = 1
+ IWORK(K+1) = 1
+ MLOC = MLOC + 2
+ ELSE
+ IWORK( K ) = 1
+ IF( K.LT.KEND ) IWORK(K+1) = 0
+ MLOC = MLOC + 1
+ END IF
+ DO 170 J = K+2, JW+IROFFH
+ IWORK( J ) = 0
+ 170 CONTINUE
+ CALL PDTRORD( 'Vectors', IWORK, PAR, JW+IROFFH, T, 1, 1,
+ $ DESCT, V, 1, 1, DESCV, WORK, WORK(JW+IROFFH+1), M,
+ $ WORK(2*(JW+IROFFH)+1), LWORK-2*(JW+IROFFH),
+ $ IWORK(NSEL+1), LIWORK-NSEL, IERR )
+ CALL DCOPY( JW, WORK(1+IROFFH), 1, SR( KWTOP ), 1 )
+ CALL DCOPY( JW, WORK(JW+2*IROFFH+1), 1, SI( KWTOP ), 1 )
+ IF( IERR.EQ.0 ) THEN
+ I = ILST
+ ELSE
+ I = K
+ END IF
+ END IF
+ IF( I.EQ.KEND ) THEN
+ K = I + 1
+ ELSE IF( SI( KWTOP-IROFFH+I-1 ).EQ.ZERO ) THEN
+ K = I + 1
+ ELSE
+ K = I + 2
+ END IF
+ GO TO 150
+ END IF
+ GO TO 140
+ 180 CONTINUE
+ END IF
+*
+* Restore number of rows and columns of T matrix descriptor.
+*
+ DESCT( M_ ) = NW+IROFFH
+ DESCT( N_ ) = NH+IROFFH
+*
+ IF( NS.LT.JW .OR. S.EQ.ZERO ) THEN
+ IF( NS.GT.1 .AND. S.NE.ZERO ) THEN
+*
+* Reflect spike back into lower triangle.
+*
+ RROWS = NUMROC( NS+IROFFH, NB, MYROW, DESCV(RSRC_), NPROW )
+ RCOLS = NUMROC( 1, 1, MYCOL, DESCV(CSRC_), NPCOL )
+ CALL DESCINIT( DESCR, NS+IROFFH, 1, NB, 1, DESCV(RSRC_),
+ $ DESCV(CSRC_), ICTXT, MAX(1, RROWS), INFO )
+ TAUROWS = NUMROC( 1, 1, MYCOL, DESCV(RSRC_), NPROW )
+ TAUCOLS = NUMROC( JW+IROFFH, NB, MYCOL, DESCV(CSRC_),
+ $ NPCOL )
+ CALL DESCINIT( DESCTAU, 1, JW+IROFFH, 1, NB, DESCV(RSRC_),
+ $ DESCV(CSRC_), ICTXT, MAX(1, TAUROWS), INFO )
+*
+ IR = 1
+ ITAU = IR + DESCR( LLD_ ) * RCOLS
+ IPW = ITAU + DESCTAU( LLD_ ) * TAUCOLS
+*
+ CALL PDLASET( 'All', NS+IROFFH, 1, ZERO, ZERO, WORK(ITAU),
+ $ 1, 1, DESCTAU )
+*
+ CALL PDCOPY( NS, V, 1+IROFFH, 1+IROFFH, DESCV, DESCV(M_),
+ $ WORK(IR), 1+IROFFH, 1, DESCR, 1 )
+ CALL PDLARFG( NS, BETA, 1+IROFFH, 1, WORK(IR), 2+IROFFH, 1,
+ $ DESCR, 1, WORK(ITAU+IROFFH) )
+ CALL PDELSET( WORK(IR), 1+IROFFH, 1, DESCR, ONE )
+*
+ CALL PDLASET( 'Lower', JW-2, JW-2, ZERO, ZERO, T, 3+IROFFH,
+ $ 1+IROFFH, DESCT )
+*
+ CALL PDLARF( 'Left', NS, JW, WORK(IR), 1+IROFFH, 1, DESCR,
+ $ 1, WORK(ITAU+IROFFH), T, 1+IROFFH, 1+IROFFH,
+ $ DESCT, WORK( IPW ) )
+ CALL PDLARF( 'Right', NS, NS, WORK(IR), 1+IROFFH, 1, DESCR,
+ $ 1, WORK(ITAU+IROFFH), T, 1+IROFFH, 1+IROFFH,
+ $ DESCT, WORK( IPW ) )
+ CALL PDLARF( 'Right', JW, NS, WORK(IR), 1+IROFFH, 1, DESCR,
+ $ 1, WORK(ITAU+IROFFH), V, 1+IROFFH, 1+IROFFH,
+ $ DESCV, WORK( IPW ) )
+*
+ ITAU = 1
+ IPW = ITAU + DESCTAU( LLD_ ) * TAUCOLS
+ CALL PDGEHRD( JW+IROFFH, 1+IROFFH, NS+IROFFH, T, 1, 1,
+ $ DESCT, WORK(ITAU), WORK( IPW ), LWORK-IPW+1, INFO )
+ END IF
+*
+* Copy updated reduced window into place.
+*
+ IF( KWTOP.GT.1 ) THEN
+ CALL PDELGET( 'All', '1-Tree', ELEM, V, 1+IROFFH,
+ $ 1+IROFFH, DESCV )
+ CALL PDELSET( H, KWTOP, KWTOP-1, DESCH, S*ELEM )
+ END IF
+ CALL PDLACPY( 'Upper', JW-1, JW-1, T, 1+IROFFH+1, 1+IROFFH,
+ $ DESCT, H, KWTOP+1, KWTOP, DESCH )
+ CALL PDLACPY( 'All', 1, JW, T, 1+IROFFH, 1+IROFFH, DESCT, H,
+ $ KWTOP, KWTOP, DESCH )
+ CALL PDLACPY( 'All', JW-1, 1, T, 1+IROFFH+1, 1+IROFFH+JW-1,
+ $ DESCT, H, KWTOP+1, KWTOP+JW-1, DESCH )
+*
+* Accumulate orthogonal matrix in order to update
+* H and Z, if requested.
+*
+ IF( NS.GT.1 .AND. S.NE.ZERO ) THEN
+ CALL PDORMHR( 'Right', 'No', JW+IROFFH, NS+IROFFH, 1+IROFFH,
+ $ NS+IROFFH, T, 1, 1, DESCT, WORK(ITAU), V, 1,
+ $ 1, DESCV, WORK( IPW ), LWORK-IPW+1, INFO )
+ END IF
+*
+* Update vertical slab in H.
+*
+ IF( WANTT ) THEN
+ LTOP = 1
+ ELSE
+ LTOP = KTOP
+ END IF
+ KLN = MAX( 0, KWTOP-LTOP )
+ IROFFHH = MOD( LTOP-1, NB )
+ ICOFFHH = MOD( KWTOP-1, NB )
+ HHRSRC = INDXG2P( LTOP, NB, MYROW, DESCH(RSRC_), NPROW )
+ HHCSRC = INDXG2P( KWTOP, NB, MYCOL, DESCH(CSRC_), NPCOL )
+ HHROWS = NUMROC( KLN+IROFFHH, NB, MYROW, HHRSRC, NPROW )
+ HHCOLS = NUMROC( JW+ICOFFHH, NB, MYCOL, HHCSRC, NPCOL )
+ CALL DESCINIT( DESCHH, KLN+IROFFHH, JW+ICOFFHH, NB, NB,
+ $ HHRSRC, HHCSRC, ICTXT, MAX(1, HHROWS), IERR )
+ CALL PDGEMM( 'No', 'No', KLN, JW, JW, ONE, H, LTOP,
+ $ KWTOP, DESCH, V, 1+IROFFH, 1+IROFFH, DESCV, ZERO,
+ $ WORK, 1+IROFFHH, 1+ICOFFHH, DESCHH )
+ CALL PDLACPY( 'All', KLN, JW, WORK, 1+IROFFHH, 1+ICOFFHH,
+ $ DESCHH, H, LTOP, KWTOP, DESCH )
+*
+* Update horizontal slab in H.
+*
+ IF( WANTT ) THEN
+ KLN = N-KBOT
+ IROFFHH = MOD( KWTOP-1, NB )
+ ICOFFHH = MOD( KBOT, NB )
+ HHRSRC = INDXG2P( KWTOP, NB, MYROW, DESCH(RSRC_), NPROW )
+ HHCSRC = INDXG2P( KBOT+1, NB, MYCOL, DESCH(CSRC_), NPCOL )
+ HHROWS = NUMROC( JW+IROFFHH, NB, MYROW, HHRSRC, NPROW )
+ HHCOLS = NUMROC( KLN+ICOFFHH, NB, MYCOL, HHCSRC, NPCOL )
+ CALL DESCINIT( DESCHH, JW+IROFFHH, KLN+ICOFFHH, NB, NB,
+ $ HHRSRC, HHCSRC, ICTXT, MAX(1, HHROWS), IERR )
+ CALL PDGEMM( 'Tr', 'No', JW, KLN, JW, ONE, V,
+ $ 1+IROFFH, 1+IROFFH, DESCV, H, KWTOP, KBOT+1,
+ $ DESCH, ZERO, WORK, 1+IROFFHH, 1+ICOFFHH, DESCHH )
+ CALL PDLACPY( 'All', JW, KLN, WORK, 1+IROFFHH, 1+ICOFFHH,
+ $ DESCHH, H, KWTOP, KBOT+1, DESCH )
+ END IF
+*
+* Update vertical slab in Z.
+*
+ IF( WANTZ ) THEN
+ KLN = IHIZ-ILOZ+1
+ IROFFZZ = MOD( ILOZ-1, NB )
+ ICOFFZZ = MOD( KWTOP-1, NB )
+ ZZRSRC = INDXG2P( ILOZ, NB, MYROW, DESCZ(RSRC_), NPROW )
+ ZZCSRC = INDXG2P( KWTOP, NB, MYCOL, DESCZ(CSRC_), NPCOL )
+ ZZROWS = NUMROC( KLN+IROFFZZ, NB, MYROW, ZZRSRC, NPROW )
+ ZZCOLS = NUMROC( JW+ICOFFZZ, NB, MYCOL, ZZCSRC, NPCOL )
+ CALL DESCINIT( DESCZZ, KLN+IROFFZZ, JW+ICOFFZZ, NB, NB,
+ $ ZZRSRC, ZZCSRC, ICTXT, MAX(1, ZZROWS), IERR )
+ CALL PDGEMM( 'No', 'No', KLN, JW, JW, ONE, Z, ILOZ,
+ $ KWTOP, DESCZ, V, 1+IROFFH, 1+IROFFH, DESCV,
+ $ ZERO, WORK, 1+IROFFZZ, 1+ICOFFZZ, DESCZZ )
+ CALL PDLACPY( 'All', KLN, JW, WORK, 1+IROFFZZ, 1+ICOFFZZ,
+ $ DESCZZ, Z, ILOZ, KWTOP, DESCZ )
+ END IF
+ END IF
+*
+* Return the number of deflations (ND) and the number of shifts (NS).
+* (Subtracting INFQR from the spike length takes care of the case of
+* a rare QR failure while calculating eigenvalues of the deflation
+* window.)
+*
+ ND = JW - NS
+ NS = NS - INFQR
+*
+* Return optimal workspace.
+*
+ WORK( 1 ) = DBLE( LWKOPT )
+ IWORK( 1 ) = ILWKOPT + NSEL
+*
+* End of PDLAQR3
+*
+ END
diff --git a/SRC/pdlaqr4.f b/SRC/pdlaqr4.f
new file mode 100644
index 0000000..105deaa
--- /dev/null
+++ b/SRC/pdlaqr4.f
@@ -0,0 +1,633 @@
+ SUBROUTINE PDLAQR4( WANTT, WANTZ, N, ILO, IHI, A, DESCA, WR, WI,
+ $ ILOZ, IHIZ, Z, DESCZ, T, LDT, V, LDV, WORK,
+ $ LWORK, INFO )
+*
+* Contribution from the Department of Computing Science and HPC2N,
+* Umea University, Sweden
+*
+* -- ScaLAPACK routine (version 2.0.2) --
+* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver
+* May 1 2012
+*
+ IMPLICIT NONE
+*
+* .. Scalar Arguments ..
+ LOGICAL WANTT, WANTZ
+ INTEGER IHI, IHIZ, ILO, ILOZ, INFO, LDT, LDV, LWORK, N
+* ..
+* .. Array Arguments ..
+ INTEGER DESCA( * ), DESCZ( * )
+ DOUBLE PRECISION A( * ), T( LDT, * ), V( LDV, * ), WI( * ),
+ $ WORK( * ), WR( * ), Z( * )
+* ..
+*
+* Purpose
+* =======
+*
+* PDLAQR4 is an auxiliary routine used to find the Schur decomposition
+* and or eigenvalues of a matrix already in Hessenberg form from cols
+* ILO to IHI. This routine requires that the active block is small
+* enough, i.e. IHI-ILO+1 .LE. LDT, so that it can be solved by LAPACK.
+* Normally, it is called by PDLAQR1. All the inputs are assumed to be
+* valid without checking.
+*
+* Notes
+* =====
+*
+* Each global data object is described by an associated description
+* vector. This vector stores the information required to establish
+* the mapping between an object element and its corresponding process
+* and memory location.
+*
+* Let A be a generic term for any 2D block cyclicly distributed array.
+* Such a global array has an associated description vector DESCA.
+* In the following comments, the character _ should be read as
+* "of the global array".
+*
+* NOTATION STORED IN EXPLANATION
+* --------------- -------------- --------------------------------------
+* DTYPE_A(global) DESCA( DTYPE_ )The descriptor type. In this case,
+* DTYPE_A = 1.
+* CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating
+* the BLACS process grid A is distribu-
+* ted over. The context itself is glo-
+* bal, but the handle (the integer
+* value) may vary.
+* M_A (global) DESCA( M_ ) The number of rows in the global
+* array A.
+* N_A (global) DESCA( N_ ) The number of columns in the global
+* array A.
+* MB_A (global) DESCA( MB_ ) The blocking factor used to distribute
+* the rows of the array.
+* NB_A (global) DESCA( NB_ ) The blocking factor used to distribute
+* the columns of the array.
+* RSRC_A (global) DESCA( RSRC_ ) The process row over which the first
+* row of the array A is distributed.
+* CSRC_A (global) DESCA( CSRC_ ) The process column over which the
+* first column of the array A is
+* distributed.
+* LLD_A (local) DESCA( LLD_ ) The leading dimension of the local
+* array. LLD_A >= MAX(1,LOCr(M_A)).
+*
+* Let K be the number of rows or columns of a distributed matrix,
+* and assume that its process grid has dimension p x q.
+* LOCr( K ) denotes the number of elements of K that a process
+* would receive if K were distributed over the p processes of its
+* process column.
+* Similarly, LOCc( K ) denotes the number of elements of K that a
+* process would receive if K were distributed over the q processes of
+* its process row.
+* The values of LOCr() and LOCc() may be determined via a call to the
+* ScaLAPACK tool function, NUMROC:
+* LOCr( M ) = NUMROC( M, MB_A, MYROW, RSRC_A, NPROW ),
+* LOCc( N ) = NUMROC( N, NB_A, MYCOL, CSRC_A, NPCOL ).
+* An upper bound for these quantities may be computed by:
+* LOCr( M ) <= ceil( ceil(M/MB_A)/NPROW )*MB_A
+* LOCc( N ) <= ceil( ceil(N/NB_A)/NPCOL )*NB_A
+*
+* Arguments
+* =========
+*
+* WANTT (global input) LOGICAL
+* = .TRUE. : the full Schur form T is required;
+* = .FALSE.: only eigenvalues are required.
+*
+* WANTZ (global input) LOGICAL
+* = .TRUE. : the matrix of Schur vectors Z is required;
+* = .FALSE.: Schur vectors are not required.
+*
+* N (global input) INTEGER
+* The order of the Hessenberg matrix A (and Z if WANTZ).
+* N >= 0.
+*
+* ILO (global input) INTEGER
+* IHI (global input) INTEGER
+* It is assumed that A is already upper quasi-triangular in
+* rows and columns IHI+1:N, and that A(ILO,ILO-1) = 0 (unless
+* ILO = 1). PDLAQR4 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.
+*
+* A (global input/output) DOUBLE PRECISION array, dimension
+* (DESCA(LLD_),*)
+* On entry, the upper Hessenberg matrix A.
+* On exit, if WANTT is .TRUE., A is upper quasi-triangular in
+* rows and columns ILO:IHI, with any 2-by-2 or larger diagonal
+* blocks not yet in standard form. If WANTT is .FALSE., the
+* contents of A are unspecified on exit.
+*
+* DESCA (global and local input) INTEGER array of dimension DLEN_.
+* The array descriptor for the distributed matrix A.
+*
+* WR (global replicated output) DOUBLE PRECISION array,
+* dimension (N)
+* WI (global replicated output) DOUBLE PRECISION array,
+* dimension (N)
+* The real and imaginary parts, respectively, of the computed
+* eigenvalues ILO to IHI are stored in the corresponding
+* elements of WR and WI. If two eigenvalues are computed as a
+* complex conjugate pair, they are stored in consecutive
+* elements of WR and WI, say the i-th and (i+1)th, with
+* WI(i) > 0 and WI(i+1) < 0. If WANTT is .TRUE., the
+* eigenvalues are stored in the same order as on the diagonal
+* of the Schur form returned in A. A may be returned with
+* larger diagonal blocks until the next release.
+*
+* ILOZ (global input) INTEGER
+* IHIZ (global input) INTEGER
+* Specify the rows of Z to which transformations must be
+* applied if WANTZ is .TRUE..
+* 1 <= ILOZ <= ILO; IHI <= IHIZ <= N.
+*
+* Z (global input/output) DOUBLE PRECISION array.
+* If WANTZ is .TRUE., on entry Z must contain the current
+* matrix Z of transformations accumulated by PDHSEQR, 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.
+*
+* DESCZ (global and local input) INTEGER array of dimension DLEN_.
+* The array descriptor for the distributed matrix Z.
+*
+* T (local workspace) DOUBLE PRECISION array, dimension LDT*NW.
+*
+* LDT (local input) INTEGER
+* The leading dimension of the array T.
+* LDT >= IHI-ILO+1.
+*
+* V (local workspace) DOUBLE PRECISION array, dimension LDV*NW.
+*
+* LDV (local input) INTEGER
+* The leading dimension of the array V.
+* LDV >= IHI-ILO+1.
+*
+* WORK (local workspace) DOUBLE PRECISION array, dimension LWORK.
+*
+* LWORK (local input) INTEGER
+* The dimension of the work array WORK.
+* LWORK >= IHI-ILO+1.
+* WORK(LWORK) is a local array and LWORK is assumed big enough.
+* Typically LWORK >= 4*LDS*LDS if this routine is called by
+* PDLAQR1. (LDS = 385, see PDLAQR1)
+*
+* INFO (global output) INTEGER
+* < 0: parameter number -INFO incorrect or inconsistent;
+* = 0: successful exit;
+* > 0: PDLAQR4 failed to compute all the eigenvalues ILO to IHI
+* in a total of 30*(IHI-ILO+1) iterations; if INFO = i,
+* elements i+1:ihi of WR and WI contain those eigenvalues
+* which have been successfully computed.
+*
+* ================================================================
+* Implemented by
+* Meiyue Shao, Department of Computing Science and HPC2N,
+* Umea University, Sweden
+*
+* ================================================================
+* References:
+* B. Kagstrom, D. Kressner, and M. Shao,
+* On Aggressive Early Deflation in Parallel Variants of the QR
+* Algorithm.
+* Para 2010, to appear.
+*
+* ================================================================
+* .. Parameters ..
+ INTEGER BLOCK_CYCLIC_2D, CSRC_, CTXT_, DLEN_, DTYPE_,
+ $ LLD_, MB_, M_, NB_, N_, RSRC_
+ PARAMETER ( BLOCK_CYCLIC_2D = 1, DLEN_ = 9, DTYPE_ = 1,
+ $ CTXT_ = 2, M_ = 3, N_ = 4, MB_ = 5, NB_ = 6,
+ $ RSRC_ = 7, CSRC_ = 8, LLD_ = 9 )
+ DOUBLE PRECISION ZERO, ONE
+ PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
+* ..
+* .. Local Scalars ..
+ INTEGER CONTXT, HBL, I, I1, I2, IAFIRST, ICOL, ICOL1,
+ $ ICOL2, II, IROW, IROW1, IROW2, ITMP1, ITMP2,
+ $ IERR, J, JAFIRST, JJ, K, L, LDA, LDZ, LLDTMP,
+ $ MYCOL, MYROW, NODE, NPCOL, NPROW, NH, NMIN, NZ,
+ $ HSTEP, VSTEP, KKROW, KKCOL, KLN, LTOP, LEFT,
+ $ RIGHT, UP, DOWN, D1, D2
+* ..
+* .. Local Arrays ..
+ INTEGER DESCT( 9 ), DESCV( 9 ), DESCWH( 9 ),
+ $ DESCWV( 9 )
+* ..
+* .. External Functions ..
+ INTEGER NUMROC, ILAENV
+ EXTERNAL NUMROC, ILAENV
+* ..
+* .. External Subroutines ..
+ EXTERNAL BLACS_GRIDINFO, INFOG2L, DLASET,
+ $ DLAHQR, DLAQR4, DESCINIT, PDGEMM, PDGEMR2D,
+ $ DGEMM, DLAMOV, DGESD2D, DGERV2D,
+ $ DGEBS2D, DGEBR2D, IGEBS2D, IGEBR2D
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, MIN, MOD
+* ..
+* .. Executable Statements ..
+*
+ INFO = 0
+*
+ NH = IHI - ILO + 1
+ NZ = IHIZ - ILOZ + 1
+ IF( N.EQ.0 .OR. NH.EQ.0 )
+ $ RETURN
+*
+* NODE (IAFIRST,JAFIRST) OWNS A(1,1)
+*
+ HBL = DESCA( MB_ )
+ CONTXT = DESCA( CTXT_ )
+ LDA = DESCA( LLD_ )
+ IAFIRST = DESCA( RSRC_ )
+ JAFIRST = DESCA( CSRC_ )
+ LDZ = DESCZ( LLD_ )
+ CALL BLACS_GRIDINFO( CONTXT, NPROW, NPCOL, MYROW, MYCOL )
+ NODE = MYROW*NPCOL + MYCOL
+ LEFT = MOD( MYCOL+NPCOL-1, NPCOL )
+ RIGHT = MOD( MYCOL+1, NPCOL )
+ UP = MOD( MYROW+NPROW-1, NPROW )
+ DOWN = MOD( MYROW+1, NPROW )
+*
+* I1 and I2 are the indices of the first row and last column of A
+* to which transformations must be applied.
+*
+ I = IHI
+ L = ILO
+ IF( WANTT ) THEN
+ I1 = 1
+ I2 = N
+ LTOP = 1
+ ELSE
+ I1 = L
+ I2 = I
+ LTOP = L
+ END IF
+*
+* Copy the diagonal block to local and call LAPACK.
+*
+ CALL INFOG2L( ILO, ILO, DESCA, NPROW, NPCOL, MYROW, MYCOL,
+ $ IROW, ICOL, II, JJ )
+ IF ( MYROW .EQ. II ) THEN
+ CALL DESCINIT( DESCT, NH, NH, NH, NH, II, JJ, CONTXT,
+ $ LDT, IERR )
+ CALL DESCINIT( DESCV, NH, NH, NH, NH, II, JJ, CONTXT,
+ $ LDV, IERR )
+ ELSE
+ CALL DESCINIT( DESCT, NH, NH, NH, NH, II, JJ, CONTXT,
+ $ 1, IERR )
+ CALL DESCINIT( DESCV, NH, NH, NH, NH, II, JJ, CONTXT,
+ $ 1, IERR )
+ END IF
+ CALL PDGEMR2D( NH, NH, A, ILO, ILO, DESCA, T, 1, 1, DESCT,
+ $ CONTXT )
+ IF ( MYROW .EQ. II .AND. MYCOL .EQ. JJ ) THEN
+ CALL DLASET( 'All', NH, NH, ZERO, ONE, V, LDV )
+ NMIN = ILAENV( 12, 'DLAQR3', 'SV', NH, 1, NH, LWORK )
+ IF( NH .GT. NMIN ) THEN
+ CALL DLAQR4( .TRUE., .TRUE., NH, 1, NH, T, LDT, WR( ILO ),
+ $ WI( ILO ), 1, NH, V, LDV, WORK, LWORK, INFO )
+* Clean up the scratch used by DLAQR4.
+ CALL DLASET( 'L', NH-2, NH-2, ZERO, ZERO, T( 3, 1 ), LDT )
+ ELSE
+ CALL DLAHQR( .TRUE., .TRUE., NH, 1, NH, T, LDT, WR( ILO ),
+ $ WI( ILO ), 1, NH, V, LDV, INFO )
+ END IF
+ CALL DGEBS2D( CONTXT, 'All', ' ', NH, NH, V, LDV )
+ CALL IGEBS2D( CONTXT, 'All', ' ', 1, 1, INFO, 1 )
+ ELSE
+ CALL DGEBR2D( CONTXT, 'All', ' ', NH, NH, V, LDV, II, JJ )
+ CALL IGEBR2D( CONTXT, 'All', ' ', 1, 1, INFO, 1, II, JJ )
+ END IF
+ IF( INFO .NE. 0 ) INFO = INFO+ILO-1
+*
+* Copy the local matrix back to the diagonal block.
+*
+ CALL PDGEMR2D( NH, NH, T, 1, 1, DESCT, A, ILO, ILO, DESCA,
+ $ CONTXT )
+*
+* Update T and Z.
+*
+ IF( MOD( ILO-1, HBL )+NH .LE. HBL ) THEN
+*
+* Simplest case: the diagonal block is located on one processor.
+* Call DGEMM directly to perform the update.
+*
+ HSTEP = LWORK / NH
+ VSTEP = HSTEP
+*
+ IF( WANTT ) THEN
+*
+* Update horizontal slab in A.
+*
+ CALL INFOG2L( ILO, I+1, DESCA, NPROW, NPCOL, MYROW,
+ $ MYCOL, IROW, ICOL, II, JJ )
+ IF( MYROW .EQ. II ) THEN
+ ICOL1 = NUMROC( N, HBL, MYCOL, JAFIRST, NPCOL )
+ DO 10 KKCOL = ICOL, ICOL1, HSTEP
+ KLN = MIN( HSTEP, ICOL1-KKCOL+1 )
+ CALL DGEMM( 'T', 'N', NH, KLN, NH, ONE, V,
+ $ LDV, A( IROW+(KKCOL-1)*LDA ), LDA, ZERO, WORK,
+ $ NH )
+ CALL DLAMOV( 'A', NH, KLN, WORK, NH,
+ $ A( IROW+(KKCOL-1)*LDA ), LDA )
+ 10 CONTINUE
+ END IF
+*
+* Update vertical slab in A.
+*
+ CALL INFOG2L( LTOP, ILO, DESCA, NPROW, NPCOL, MYROW,
+ $ MYCOL, IROW, ICOL, II, JJ )
+ IF( MYCOL .EQ. JJ ) THEN
+ CALL INFOG2L( ILO-1, ILO, DESCA, NPROW, NPCOL,
+ $ MYROW, MYCOL, IROW1, ICOL1, ITMP1, ITMP2 )
+ IF( MYROW .NE. ITMP1 ) IROW1 = IROW1-1
+ DO 20 KKROW = IROW, IROW1, VSTEP
+ KLN = MIN( VSTEP, IROW1-KKROW+1 )
+ CALL DGEMM( 'N', 'N', KLN, NH, NH, ONE,
+ $ A( KKROW+(ICOL-1)*LDA ), LDA, V, LDV, ZERO,
+ $ WORK, KLN )
+ CALL DLAMOV( 'A', KLN, NH, WORK, KLN,
+ $ A( KKROW+(ICOL-1)*LDA ), LDA )
+ 20 CONTINUE
+ END IF
+ END IF
+*
+* Update vertical slab in Z.
+*
+ IF( WANTZ ) THEN
+ CALL INFOG2L( ILOZ, ILO, DESCZ, NPROW, NPCOL, MYROW,
+ $ MYCOL, IROW, ICOL, II, JJ )
+ IF( MYCOL .EQ. JJ ) THEN
+ CALL INFOG2L( IHIZ, ILO, DESCZ, NPROW, NPCOL,
+ $ MYROW, MYCOL, IROW1, ICOL1, ITMP1, ITMP2 )
+ IF( MYROW .NE. ITMP1 ) IROW1 = IROW1-1
+ DO 30 KKROW = IROW, IROW1, VSTEP
+ KLN = MIN( VSTEP, IROW1-KKROW+1 )
+ CALL DGEMM( 'N', 'N', KLN, NH, NH, ONE,
+ $ Z( KKROW+(ICOL-1)*LDZ ), LDZ, V, LDV, ZERO,
+ $ WORK, KLN )
+ CALL DLAMOV( 'A', KLN, NH, WORK, KLN,
+ $ Z( KKROW+(ICOL-1)*LDZ ), LDZ )
+ 30 CONTINUE
+ END IF
+ END IF
+*
+ ELSE IF( MOD( ILO-1, HBL )+NH .LE. 2*HBL ) THEN
+*
+* More complicated case: the diagonal block lay on a 2x2
+* processor mesh.
+* Call DGEMM locally and communicate by pair.
+*
+ D1 = HBL - MOD( ILO-1, HBL )
+ D2 = NH - D1
+ HSTEP = LWORK / NH
+ VSTEP = HSTEP
+*
+ IF( WANTT ) THEN
+*
+* Update horizontal slab in A.
+*
+ CALL INFOG2L( ILO, I+1, DESCA, NPROW, NPCOL, MYROW,
+ $ MYCOL, IROW, ICOL, II, JJ )
+ IF( MYROW .EQ. UP ) THEN
+ IF( MYROW .EQ. II ) THEN
+ ICOL1 = NUMROC( N, HBL, MYCOL, JAFIRST, NPCOL )
+ DO 40 KKCOL = ICOL, ICOL1, HSTEP
+ KLN = MIN( HSTEP, ICOL1-KKCOL+1 )
+ CALL DGEMM( 'T', 'N', NH, KLN, NH, ONE, V,
+ $ NH, A( IROW+(KKCOL-1)*LDA ), LDA, ZERO,
+ $ WORK, NH )
+ CALL DLAMOV( 'A', NH, KLN, WORK, NH,
+ $ A( IROW+(KKCOL-1)*LDA ), LDA )
+ 40 CONTINUE
+ END IF
+ ELSE
+ IF( MYROW .EQ. II ) THEN
+ ICOL1 = NUMROC( N, HBL, MYCOL, JAFIRST, NPCOL )
+ DO 50 KKCOL = ICOL, ICOL1, HSTEP
+ KLN = MIN( HSTEP, ICOL1-KKCOL+1 )
+ CALL DGEMM( 'T', 'N', D2, KLN, D1, ONE,
+ $ V( 1, D1+1 ), LDV, A( IROW+(KKCOL-1)*LDA ),
+ $ LDA, ZERO, WORK( D1+1 ), NH )
+ CALL DGESD2D( CONTXT, D2, KLN, WORK( D1+1 ),
+ $ NH, DOWN, MYCOL )
+ CALL DGERV2D( CONTXT, D1, KLN, WORK, NH, DOWN,
+ $ MYCOL )
+ CALL DGEMM( 'T', 'N', D1, KLN, D1, ONE,
+ $ V, LDV, A( IROW+(KKCOL-1)*LDA ), LDA, ONE,
+ $ WORK, NH )
+ CALL DLAMOV( 'A', D1, KLN, WORK, NH,
+ $ A( IROW+(KKCOL-1)*LDA ), LDA )
+ 50 CONTINUE
+ ELSE IF( UP .EQ. II ) THEN
+ ICOL1 = NUMROC( N, HBL, MYCOL, JAFIRST, NPCOL )
+ DO 60 KKCOL = ICOL, ICOL1, HSTEP
+ KLN = MIN( HSTEP, ICOL1-KKCOL+1 )
+ CALL DGEMM( 'T', 'N', D1, KLN, D2, ONE,
+ $ V( D1+1, 1 ), LDV, A( IROW+(KKCOL-1)*LDA ),
+ $ LDA, ZERO, WORK, NH )
+ CALL DGESD2D( CONTXT, D1, KLN, WORK, NH, UP,
+ $ MYCOL )
+ CALL DGERV2D( CONTXT, D2, KLN, WORK( D1+1 ),
+ $ NH, UP, MYCOL )
+ CALL DGEMM( 'T', 'N', D2, KLN, D2, ONE,
+ $ V( D1+1, D1+1 ), LDV,
+ $ A( IROW+(KKCOL-1)*LDA ), LDA, ONE,
+ $ WORK( D1+1 ), NH )
+ CALL DLAMOV( 'A', D2, KLN, WORK( D1+1 ), NH,
+ $ A( IROW+(KKCOL-1)*LDA ), LDA )
+ 60 CONTINUE
+ END IF
+ END IF
+*
+* Update vertical slab in A.
+*
+ CALL INFOG2L( LTOP, ILO, DESCA, NPROW, NPCOL, MYROW,
+ $ MYCOL, IROW, ICOL, II, JJ )
+ IF( MYCOL .EQ. LEFT ) THEN
+ IF( MYCOL .EQ. JJ ) THEN
+ CALL INFOG2L( ILO-1, ILO, DESCA, NPROW, NPCOL,
+ $ MYROW, MYCOL, IROW1, ICOL1, ITMP1, ITMP2 )
+ IF( MYROW .NE. ITMP1 ) IROW1 = IROW1-1
+ DO 70 KKROW = IROW, IROW1, VSTEP
+ KLN = MIN( VSTEP, IROW1-KKROW+1 )
+ CALL DGEMM( 'N', 'N', KLN, NH, NH, ONE,
+ $ A( KKROW+(ICOL-1)*LDA ), LDA, V, LDV,
+ $ ZERO, WORK, KLN )
+ CALL DLAMOV( 'A', KLN, NH, WORK, KLN,
+ $ A( KKROW+(ICOL-1)*LDA ), LDA )
+ 70 CONTINUE
+ END IF
+ ELSE
+ IF( MYCOL .EQ. JJ ) THEN
+ CALL INFOG2L( ILO-1, ILO, DESCA, NPROW, NPCOL,
+ $ MYROW, MYCOL, IROW1, ICOL1, ITMP1, ITMP2 )
+ IF( MYROW .NE. ITMP1 ) IROW1 = IROW1-1
+ DO 80 KKROW = IROW, IROW1, VSTEP
+ KLN = MIN( VSTEP, IROW1-KKROW+1 )
+ CALL DGEMM( 'N', 'N', KLN, D2, D1, ONE,
+ $ A( KKROW+(ICOL-1)*LDA ), LDA, V( 1, D1+1 ),
+ $ LDV, ZERO, WORK( 1+D1*KLN ), KLN )
+ CALL DGESD2D( CONTXT, KLN, D2, WORK( 1+D1*KLN ),
+ $ KLN, MYROW, RIGHT )
+ CALL DGERV2D( CONTXT, KLN, D1, WORK, KLN, MYROW,
+ $ RIGHT )
+ CALL DGEMM( 'N', 'N', KLN, D1, D1, ONE,
+ $ A( KKROW+(ICOL-1)*LDA ), LDA, V, LDV, ONE,
+ $ WORK, KLN )
+ CALL DLAMOV( 'A', KLN, D1, WORK, KLN,
+ $ A( KKROW+(ICOL-1)*LDA ), LDA )
+ 80 CONTINUE
+ ELSE IF ( LEFT .EQ. JJ ) THEN
+ CALL INFOG2L( ILO-1, ILO, DESCA, NPROW, NPCOL,
+ $ MYROW, MYCOL, IROW1, ICOL1, ITMP1, ITMP2 )
+ IF( MYROW .NE. ITMP1 ) IROW1 = IROW1-1
+ DO 90 KKROW = IROW, IROW1, VSTEP
+ KLN = MIN( VSTEP, IROW1-KKROW+1 )
+ CALL DGEMM( 'N', 'N', KLN, D1, D2, ONE,
+ $ A( KKROW+(ICOL-1)*LDA ), LDA, V( D1+1, 1 ),
+ $ LDV, ZERO, WORK, KLN )
+ CALL DGESD2D( CONTXT, KLN, D1, WORK, KLN, MYROW,
+ $ LEFT )
+ CALL DGERV2D( CONTXT, KLN, D2, WORK( 1+D1*KLN ),
+ $ KLN, MYROW, LEFT )
+ CALL DGEMM( 'N', 'N', KLN, D2, D2, ONE,
+ $ A( KKROW+(ICOL-1)*LDA ), LDA, V( D1+1, D1+1 ),
+ $ LDV, ONE, WORK( 1+D1*KLN ), KLN )
+ CALL DLAMOV( 'A', KLN, D2, WORK( 1+D1*KLN ), KLN,
+ $ A( KKROW+(ICOL-1)*LDA ), LDA )
+ 90 CONTINUE
+ END IF
+ END IF
+ END IF
+*
+* Update vertical slab in Z.
+*
+ IF( WANTZ ) THEN
+ CALL INFOG2L( ILOZ, ILO, DESCZ, NPROW, NPCOL, MYROW,
+ $ MYCOL, IROW, ICOL, II, JJ )
+ IF( MYCOL .EQ. LEFT ) THEN
+ IF( MYCOL .EQ. JJ ) THEN
+ CALL INFOG2L( IHIZ, ILO, DESCZ, NPROW, NPCOL,
+ $ MYROW, MYCOL, IROW1, ICOL1, ITMP1, ITMP2 )
+ IF( MYROW .NE. ITMP1 ) IROW1 = IROW1-1
+ DO 100 KKROW = IROW, IROW1, VSTEP
+ KLN = MIN( VSTEP, IROW1-KKROW+1 )
+ CALL DGEMM( 'N', 'N', KLN, NH, NH, ONE,
+ $ Z( KKROW+(ICOL-1)*LDZ ), LDZ, V, LDV, ZERO,
+ $ WORK, KLN )
+ CALL DLAMOV( 'A', KLN, NH, WORK, KLN,
+ $ Z( KKROW+(ICOL-1)*LDZ ), LDZ )
+ 100 CONTINUE
+ END IF
+ ELSE
+ IF( MYCOL .EQ. JJ ) THEN
+ CALL INFOG2L( IHIZ, ILO, DESCZ, NPROW, NPCOL,
+ $ MYROW, MYCOL, IROW1, ICOL1, ITMP1, ITMP2 )
+ IF( MYROW .NE. ITMP1 ) IROW1 = IROW1-1
+ DO 110 KKROW = IROW, IROW1, VSTEP
+ KLN = MIN( VSTEP, IROW1-KKROW+1 )
+ CALL DGEMM( 'N', 'N', KLN, D2, D1, ONE,
+ $ Z( KKROW+(ICOL-1)*LDZ ), LDZ, V( 1, D1+1 ),
+ $ LDV, ZERO, WORK( 1+D1*KLN ), KLN )
+ CALL DGESD2D( CONTXT, KLN, D2, WORK( 1+D1*KLN ),
+ $ KLN, MYROW, RIGHT )
+ CALL DGERV2D( CONTXT, KLN, D1, WORK, KLN, MYROW,
+ $ RIGHT )
+ CALL DGEMM( 'N', 'N', KLN, D1, D1, ONE,
+ $ Z( KKROW+(ICOL-1)*LDZ ), LDZ, V, LDV, ONE,
+ $ WORK, KLN )
+ CALL DLAMOV( 'A', KLN, D1, WORK, KLN,
+ $ Z( KKROW+(ICOL-1)*LDZ ), LDZ )
+ 110 CONTINUE
+ ELSE IF( LEFT .EQ. JJ ) THEN
+ CALL INFOG2L( IHIZ, ILO, DESCZ, NPROW, NPCOL,
+ $ MYROW, MYCOL, IROW1, ICOL1, ITMP1, ITMP2 )
+ IF( MYROW .NE. ITMP1 ) IROW1 = IROW1-1
+ DO 120 KKROW = IROW, IROW1, VSTEP
+ KLN = MIN( VSTEP, IROW1-KKROW+1 )
+ CALL DGEMM( 'N', 'N', KLN, D1, D2, ONE,
+ $ Z( KKROW+(ICOL-1)*LDZ ), LDZ, V( D1+1, 1 ),
+ $ LDV, ZERO, WORK, KLN )
+ CALL DGESD2D( CONTXT, KLN, D1, WORK, KLN, MYROW,
+ $ LEFT )
+ CALL DGERV2D( CONTXT, KLN, D2, WORK( 1+D1*KLN ),
+ $ KLN, MYROW, LEFT )
+ CALL DGEMM( 'N', 'N', KLN, D2, D2, ONE,
+ $ Z( KKROW+(ICOL-1)*LDZ ), LDZ,
+ $ V( D1+1, D1+1 ), LDV, ONE, WORK( 1+D1*KLN ),
+ $ KLN )
+ CALL DLAMOV( 'A', KLN, D2, WORK( 1+D1*KLN ),
+ $ KLN, Z( KKROW+(ICOL-1)*LDZ ), LDZ )
+ 120 CONTINUE
+ END IF
+ END IF
+ END IF
+*
+ ELSE
+*
+* Most complicated case: the diagonal block lay across the border
+* of the processor mesh.
+* Treat V as a distributed matrix and call PDGEMM.
+*
+ HSTEP = LWORK / NH * NPCOL
+ VSTEP = LWORK / NH * NPROW
+ LLDTMP = NUMROC( NH, NH, MYROW, 0, NPROW )
+ LLDTMP = MAX( 1, LLDTMP )
+ CALL DESCINIT( DESCV, NH, NH, NH, NH, 0, 0, CONTXT,
+ $ LLDTMP, IERR )
+ CALL DESCINIT( DESCWH, NH, HSTEP, NH, LWORK / NH, 0, 0,
+ $ CONTXT, LLDTMP, IERR )
+*
+ IF( WANTT ) THEN
+*
+* Update horizontal slab in A.
+*
+ DO 130 KKCOL = I+1, N, HSTEP
+ KLN = MIN( HSTEP, N-KKCOL+1 )
+ CALL PDGEMM( 'T', 'N', NH, KLN, NH, ONE, V, 1, 1,
+ $ DESCV, A, ILO, KKCOL, DESCA, ZERO, WORK, 1, 1,
+ $ DESCWH )
+ CALL PDGEMR2D( NH, KLN, WORK, 1, 1, DESCWH, A,
+ $ ILO, KKCOL, DESCA, CONTXT )
+ 130 CONTINUE
+*
+* Update vertical slab in A.
+*
+ DO 140 KKROW = LTOP, ILO-1, VSTEP
+ KLN = MIN( VSTEP, ILO-KKROW )
+ LLDTMP = NUMROC( KLN, LWORK / NH, MYROW, 0, NPROW )
+ LLDTMP = MAX( 1, LLDTMP )
+ CALL DESCINIT( DESCWV, KLN, NH, LWORK / NH, NH, 0, 0,
+ $ CONTXT, LLDTMP, IERR )
+ CALL PDGEMM( 'N', 'N', KLN, NH, NH, ONE, A, KKROW,
+ $ ILO, DESCA, V, 1, 1, DESCV, ZERO, WORK, 1, 1,
+ $ DESCWV )
+ CALL PDGEMR2D( KLN, NH, WORK, 1, 1, DESCWV, A, KKROW,
+ $ ILO, DESCA, CONTXT )
+ 140 CONTINUE
+ END IF
+*
+* Update vertical slab in Z.
+*
+ IF( WANTZ ) THEN
+ DO 150 KKROW = ILOZ, IHIZ, VSTEP
+ KLN = MIN( VSTEP, IHIZ-KKROW+1 )
+ LLDTMP = NUMROC( KLN, LWORK / NH, MYROW, 0, NPROW )
+ LLDTMP = MAX( 1, LLDTMP )
+ CALL DESCINIT( DESCWV, KLN, NH, LWORK / NH, NH, 0, 0,
+ $ CONTXT, LLDTMP, IERR )
+ CALL PDGEMM( 'N', 'N', KLN, NH, NH, ONE, Z, KKROW,
+ $ ILO, DESCZ, V, 1, 1, DESCV, ZERO, WORK, 1, 1,
+ $ DESCWV )
+ CALL PDGEMR2D( KLN, NH, WORK, 1, 1, DESCWV, Z,
+ $ KKROW, ILO, DESCZ, CONTXT )
+ 150 CONTINUE
+ END IF
+ END IF
+*
+* END OF PDLAQR4
+*
+ END
diff --git a/SRC/pdlaqr5.f b/SRC/pdlaqr5.f
new file mode 100644
index 0000000..25c36d9
--- /dev/null
+++ b/SRC/pdlaqr5.f
@@ -0,0 +1,2275 @@
+ SUBROUTINE PDLAQR5( WANTT, WANTZ, KACC22, N, KTOP, KBOT, NSHFTS,
+ $ SR, SI, H, DESCH, ILOZ, IHIZ, Z, DESCZ, WORK,
+ $ LWORK, IWORK, LIWORK )
+*
+* Contribution from the Department of Computing Science and HPC2N,
+* Umea University, Sweden
+*
+* -- ScaLAPACK routine (version 2.0.2) --
+* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver
+* May 1 2012
+*
+ IMPLICIT NONE
+*
+* .. Scalar Arguments ..
+ INTEGER IHIZ, ILOZ, KACC22, KBOT, KTOP, N, NSHFTS,
+ $ LWORK, LIWORK
+ LOGICAL WANTT, WANTZ
+* ..
+* .. Array Arguments ..
+ INTEGER DESCH( * ), DESCZ( * ), IWORK( * )
+ DOUBLE PRECISION H( * ), SI( * ), SR( * ), Z( * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* This auxiliary subroutine called by PDLAQR0 performs a
+* single small-bulge multi-shift QR sweep by chasing separated
+* groups of bulges along the main block diagonal of H.
+*
+* WANTT (global input) logical scalar
+* WANTT = .TRUE. if the quasi-triangular Schur factor
+* is being computed. WANTT is set to .FALSE. otherwise.
+*
+* WANTZ (global input) logical scalar
+* WANTZ = .TRUE. if the orthogonal Schur factor is being
+* computed. WANTZ is set to .FALSE. otherwise.
+*
+* KACC22 (global input) integer with value 0, 1, or 2.
+* Specifies the computation mode of far-from-diagonal
+* orthogonal updates.
+* = 1: PDLAQR5 accumulates reflections and uses matrix-matrix
+* multiply to update the far-from-diagonal matrix entries.
+* = 2: PDLAQR5 accumulates reflections, uses matrix-matrix
+* multiply to update the far-from-diagonal matrix entries,
+* and takes advantage of 2-by-2 block structure during
+* matrix multiplies.
+*
+* N (global input) integer scalar
+* N is the order of the Hessenberg matrix H upon which this
+* subroutine operates.
+*
+* KTOP (global input) integer scalar
+* KBOT (global input) integer scalar
+* These are the first and last rows and columns of an
+* isolated diagonal block upon which the QR sweep is to be
+* applied. It is assumed without a check that
+* either KTOP = 1 or H(KTOP,KTOP-1) = 0
+* and
+* either KBOT = N or H(KBOT+1,KBOT) = 0.
+*
+* NSHFTS (global input) integer scalar
+* NSHFTS gives the number of simultaneous shifts. NSHFTS
+* must be positive and even.
+*
+* SR (global input) DOUBLE PRECISION array of size (NSHFTS)
+* SI (global input) DOUBLE PRECISION array of size (NSHFTS)
+* SR contains the real parts and SI contains the imaginary
+* parts of the NSHFTS shifts of origin that define the
+* multi-shift QR sweep.
+*
+* H (local input/output) DOUBLE PRECISION array of size
+* (DESCH(LLD_),*)
+* 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.
+*
+* DESCH (global and local input) INTEGER array of dimension DLEN_.
+* The array descriptor for the distributed matrix H.
+*
+* ILOZ (global input) INTEGER
+* IHIZ (global input) INTEGER
+* Specify the rows of Z to which transformations must be
+* applied if WANTZ is .TRUE.. 1 .LE. ILOZ .LE. IHIZ .LE. N
+*
+* Z (local input/output) DOUBLE PRECISION array of size
+* (DESCZ(LLD_),*)
+* If WANTZ = .TRUE., then the QR Sweep orthogonal
+* similarity transformation is accumulated into
+* Z(ILOZ:IHIZ,ILO:IHI) from the right.
+* If WANTZ = .FALSE., then Z is unreferenced.
+*
+* DESCZ (global and local input) INTEGER array of dimension DLEN_.
+* The array descriptor for the distributed matrix Z.
+*
+* WORK (local workspace) DOUBLE PRECISION array, dimension(DWORK)
+*
+* LWORK (local input) INTEGER
+* The length of the workspace array WORK.
+*
+* IWORK (local workspace) INTEGER array, dimension (LIWORK)
+*
+* LIWORK (local input) INTEGER
+* The length of the workspace array IWORK.
+*
+* ================================================================
+* Based on contributions by
+* Robert Granat, Department of Computing Science and HPC2N,
+* University of Umea, Sweden.
+*
+* ============================================================
+* References:
+* K. Braman, R. Byers, and R. Mathias,
+* The Multi-Shift QR Algorithm Part I: Maintaining Well Focused
+* Shifts, and Level 3 Performance.
+* SIAM J. Matrix Anal. Appl., 23(4):929--947, 2002.
+*
+* R. Granat, B. Kagstrom, and D. Kressner,
+* A Novel Parallel QR Algorithm for Hybrid Distributed Momory HPC
+* Systems.
+* SIAM J. Sci. Comput., 32(4):2345--2378, 2010.
+*
+* ============================================================
+* .. Parameters ..
+ INTEGER BLOCK_CYCLIC_2D, CSRC_, CTXT_, DLEN_, DTYPE_,
+ $ LLD_, MB_, M_, NB_, N_, RSRC_
+ PARAMETER ( BLOCK_CYCLIC_2D = 1, DLEN_ = 9, DTYPE_ = 1,
+ $ CTXT_ = 2, M_ = 3, N_ = 4, MB_ = 5, NB_ = 6,
+ $ RSRC_ = 7, CSRC_ = 8, LLD_ = 9 )
+ DOUBLE PRECISION ZERO, ONE
+ PARAMETER ( ZERO = 0.0d0, ONE = 1.0d0 )
+ INTEGER NTINY
+ PARAMETER ( NTINY = 11 )
+* ..
+* .. Local Scalars ..
+ DOUBLE PRECISION ALPHA, BETA, H11, H12, H21, H22, REFSUM,
+ $ SAFMAX, SAFMIN, SCL, SMLNUM, SWAP, TST1, TST2,
+ $ ULP, TAU, ELEM, STAMP, DDUM, ORTH
+ 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, LLDH, LLDZ, LLDU, LLDV, LLDW, LLDWH,
+ $ INFO, ICTXT, NPROW, NPCOL, NB, IROFFH, ITOP,
+ $ NWIN, MYROW, MYCOL, LNS, NUMWIN, LKACC22,
+ $ LCHAIN, WIN, IDONEJOB, IPNEXT, ANMWIN, LENRBUF,
+ $ LENCBUF, ICHOFF, LRSRC, LCSRC, LKTOP, LKBOT,
+ $ II, JJ, SWIN, EWIN, LNWIN, DIM, LLKTOP, LLKBOT,
+ $ IPV, IPU, IPH, IPW, KU, KWH, KWV, NVE, LKS,
+ $ IDUM, NHO, DIR, WINID, INDX, ILOC, JLOC, RSRC1,
+ $ CSRC1, RSRC2, CSRC2, RSRC3, CSRC3, RSRC4, IPUU,
+ $ CSRC4, LROWS, LCOLS, INDXS, KS, JLOC1, ILOC1,
+ $ LKTOP1, LKTOP2, WCHUNK, NUMCHUNK, ODDEVEN,
+ $ CHUNKNUM, DIM1, DIM4, IPW3, HROWS, ZROWS,
+ $ HCOLS, IPW1, IPW2, RSRC, EAST, JLOC4, ILOC4,
+ $ WEST, CSRC, SOUTH, NORHT, INDXE, NORTH,
+ $ IHH, IPIW, LKBOT1, NPROCS, LIROFFH,
+ $ WINFIN, RWS3, CLS3, INDX2, HROWS2,
+ $ ZROWS2, HCOLS2, MNRBUF,
+ $ MXRBUF, MNCBUF, MXCBUF, LWKOPT
+ LOGICAL BLK22, BMP22, INTRO, DONEJOB, ODDNPROW,
+ $ ODDNPCOL, LQUERY, BCDONE
+ CHARACTER JBCMPZ*2, JOB
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ INTEGER PILAENVX, ICEIL, INDXG2P, INDXG2L, NUMROC
+ DOUBLE PRECISION DLAMCH, DLANGE
+ EXTERNAL DLAMCH, PILAENVX, ICEIL, INDXG2P, INDXG2L,
+ $ NUMROC, LSAME, DLANGE
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, DBLE, MAX, MIN, MOD
+* ..
+* .. Local Arrays ..
+ DOUBLE PRECISION VT( 3 )
+* ..
+* .. External Subroutines ..
+ EXTERNAL DGEMM, DLABAD, DLAMOV, DLAQR1, DLARFG, DLASET,
+ $ DTRMM, DLAQR6
+* ..
+* .. Executable Statements ..
+*
+ INFO = 0
+ ICTXT = DESCH( CTXT_ )
+ CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL )
+ NPROCS = NPROW*NPCOL
+ LLDH = DESCH( LLD_ )
+ LLDZ = DESCZ( LLD_ )
+ NB = DESCH( MB_ )
+ IROFFH = MOD( KTOP - 1, NB )
+ LQUERY = LWORK.EQ.-1 .OR. LIWORK.EQ.-1
+*
+* If there are no shifts, then there is nothing to do.
+*
+ IF( .NOT. LQUERY .AND. NSHFTS.LT.2 )
+ $ RETURN
+*
+* If the active block is empty or 1-by-1, then there
+* is nothing to do.
+*
+ IF( .NOT. LQUERY .AND. 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.
+*
+ IF( .NOT. LQUERY ) THEN
+ 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
+ END IF
+*
+* NSHFTS is supposed to be even, but if is odd,
+* then simply reduce it by one. The shuffle above
+* ensures that the dropped shift is real and that
+* the remaining shifts are paired.
+*
+ NS = NSHFTS - MOD( NSHFTS, 2 )
+*
+* Extract the size of the computational window.
+*
+ NWIN = PILAENVX( ICTXT, 19, 'PDLAQR5', JBCMPZ, N, NB, NB, NB )
+ NWIN = MIN( NWIN, KBOT-KTOP+1 )
+*
+* Adjust number of simultaneous shifts if it exceeds the limit
+* set by the number of diagonal blocks in the active submatrix
+* H(KTOP:KBOT,KTOP:KBOT).
+*
+ NS = MAX( 2, MIN( NS, ICEIL( KBOT-KTOP+1, NB )*NWIN/3 ) )
+ NS = NS - MOD( NS, 2 )
+
+*
+* Decide the number of simultaneous computational windows
+* from the number of shifts - each window should contain up to
+* (NWIN / 3) shifts. Also compute the number of shifts per
+* window and make sure that number is even.
+*
+ LNS = MIN( MAX( 2, NWIN / 3 ), MAX( 2, NS / MIN(NPROW,NPCOL) ) )
+ LNS = LNS - MOD( LNS, 2 )
+ NUMWIN = MAX( 1, MIN( ICEIL( NS, LNS ),
+ $ ICEIL( KBOT-KTOP+1, NB ) - 1 ) )
+ IF( NPROW.NE.NPCOL ) THEN
+ NUMWIN = MIN( NUMWIN, MIN(NPROW,NPCOL) )
+ LNS = MIN( LNS, MAX( 2, NS / MIN(NPROW,NPCOL) ) )
+ LNS = LNS - MOD( LNS, 2 )
+ END IF
+*
+* 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 on a local level?
+*
+ IF( LNS.LT.14 ) THEN
+ LKACC22 = 1
+ ELSE
+ LKACC22 = 2
+ END IF
+*
+* If so, exploit the 2-by-2 block structure?
+* ( Usually it is not efficient to exploit the 2-by-2 structure
+* because the block size is too small. )
+*
+ BLK22 = ( LNS.GT.2 ) .AND. ( KACC22.EQ.2 )
+*
+* Clear trash.
+*
+ IF( .NOT. LQUERY .AND. KTOP+2.LE.KBOT )
+ $ CALL PDELSET( H, KTOP+2, KTOP, DESCH, ZERO )
+*
+* NBMPS = number of 2-shift bulges in each chain
+*
+ NBMPS = LNS / 2
+*
+* KDU = width of slab
+*
+ KDU = 6*NBMPS - 3
+*
+* LCHAIN = length of each chain
+*
+ LCHAIN = 3 * NBMPS + 1
+*
+* Check if workspace query.
+*
+ IF( LQUERY ) THEN
+ HROWS = NUMROC( N, NB, MYROW, DESCH(RSRC_), NPROW )
+ HCOLS = NUMROC( N, NB, MYCOL, DESCH(CSRC_), NPCOL )
+ LWKOPT = (5+2*NUMWIN)*NB**2 + 2*HROWS*NB + HCOLS*NB +
+ $ MAX( HROWS*NB, HCOLS*NB )
+ WORK(1) = DBLE(LWKOPT)
+ IWORK(1) = 5*NUMWIN
+ RETURN
+ END IF
+*
+* Check if KTOP and KBOT are valid.
+*
+ IF( KTOP.LT.1 .OR. KBOT.GT.N ) STOP
+*
+* Create and chase NUMWIN chains of NBMPS bulges.
+*
+* Set up window introduction.
+*
+ ANMWIN = 0
+ INTRO = .TRUE.
+ IPIW = 1
+*
+* Main loop:
+* While-loop over the computational windows which is
+* terminated when all windows have been introduced,
+* chased down to the bottom of the considered submatrix
+* and chased off.
+*
+ 20 CONTINUE
+*
+* Set up next window as long as we have less than the prescribed
+* number of windows. Each window is described an integer quadruple:
+* 1. Local value of KTOP (below denoted by LKTOP)
+* 2. Local value of KBOT (below denoted by LKBOT)
+* 3-4. Processor indices (LRSRC,LCSRC) associated with the window.
+* (5. Mark that decides if a window is fully processed or not)
+*
+* Notice - the next window is only introduced if the first block
+* in the active submatrix does not contain any other windows.
+*
+ IF( ANMWIN.GT.0 ) THEN
+ LKTOP = IWORK( 1+(ANMWIN-1)*5 )
+ ELSE
+ LKTOP = KTOP
+ END IF
+ IF( INTRO .AND. (ANMWIN.EQ.0 .OR. LKTOP.GT.ICEIL(KTOP,NB)*NB) )
+ $ THEN
+ ANMWIN = ANMWIN + 1
+*
+* Structure of IWORK:
+* IWORK( 1+(WIN-1)*5 ): start position
+* IWORK( 2+(WIN-1)*5 ): stop position
+* IWORK( 3+(WIN-1)*5 ): processor row id
+* IWORK( 4+(WIN-1)*5 ): processor col id
+* IWORK( 5+(WIN-1)*5 ): window status (0, 1, or 2)
+*
+ IWORK( 1+(ANMWIN-1)*5 ) = KTOP
+ IWORK( 2+(ANMWIN-1)*5 ) = KTOP +
+ $ MIN( NWIN,NB-IROFFH,KBOT-KTOP+1 ) - 1
+ IWORK( 3+(ANMWIN-1)*5 ) = INDXG2P( IWORK(1+(ANMWIN-1)*5), NB,
+ $ MYROW, DESCH(RSRC_), NPROW )
+ IWORK( 4+(ANMWIN-1)*5 ) = INDXG2P( IWORK(2+(ANMWIN-1)*5), NB,
+ $ MYCOL, DESCH(CSRC_), NPCOL )
+ IWORK( 5+(ANMWIN-1)*5 ) = 0
+ IPIW = 6+(ANMWIN-1)*5
+ IF( ANMWIN.EQ.NUMWIN ) INTRO = .FALSE.
+ END IF
+*
+* Do-loop over the number of windows.
+*
+ IPNEXT = 1
+ DONEJOB = .FALSE.
+ IDONEJOB = 0
+ LENRBUF = 0
+ LENCBUF = 0
+ ICHOFF = 0
+ DO 40 WIN = 1, ANMWIN
+*
+* Extract window information to simplify the rest.
+*
+ LRSRC = IWORK( 3+(WIN-1)*5 )
+ LCSRC = IWORK( 4+(WIN-1)*5 )
+ LKTOP = IWORK( 1+(WIN-1)*5 )
+ LKBOT = IWORK( 2+(WIN-1)*5 )
+ LNWIN = LKBOT - LKTOP + 1
+*
+* Check if anything to do for current window, i.e., if the local
+* chain of bulges has reached the next block border etc.
+*
+ IF( IWORK(5+(WIN-1)*5).LT.2 .AND. LNWIN.GT.1 .AND.
+ $ (LNWIN.GT.LCHAIN .OR. LKBOT.EQ.KBOT ) ) THEN
+ LIROFFH = MOD(LKTOP-1,NB)
+ SWIN = LKTOP-LIROFFH
+ EWIN = MIN(KBOT,LKTOP-LIROFFH+NB-1)
+ DIM = EWIN-SWIN+1
+ IF( DIM.LE.NTINY .AND. .NOT.LKBOT.EQ.KBOT ) THEN
+ IWORK( 5+(WIN-1)*5 ) = 2
+ GO TO 45
+ END IF
+ IDONEJOB = 1
+ IF( IWORK(5+(WIN-1)*5).EQ.0 ) THEN
+ IWORK(5+(WIN-1)*5) = 1
+ END IF
+*
+* Let the process that owns the corresponding window do the
+* local bulge chase.
+*
+ IF( MYROW.EQ.LRSRC .AND. MYCOL.EQ.LCSRC ) THEN
+*
+* Set the kind of job to do in DLAQR6:
+* 1. JOB = 'I': Introduce and chase bulges in window WIN
+* 2. JOB = 'C': Chase bulges from top to bottom of window WIN
+* 3. JOB = 'O': Chase bulges off window WIN
+* 4. JOB = 'A': All of 1-3 above is done - this will for
+* example happen for very small active
+* submatrices (like 2-by-2)
+*
+ LLKBOT = LLKTOP + LNWIN - 1
+ IF( LKTOP.EQ.KTOP .AND. LKBOT.EQ.KBOT ) THEN
+ JOB = 'All steps'
+ ICHOFF = 1
+ ELSEIF( LKTOP.EQ.KTOP ) THEN
+ JOB = 'Introduce and chase'
+ ELSEIF( LKBOT.EQ.KBOT ) THEN
+ JOB = 'Off-chase bulges'
+ ICHOFF = 1
+ ELSE
+ JOB = 'Chase bulges'
+ END IF
+*
+* Copy submatrix of H corresponding to window WIN into
+* workspace and set out additional workspace for storing
+* orthogonal transformations. This submatrix must be at
+* least (NTINY+1)-by-(NTINY+1) to fit into DLAQR6 - if not,
+* abort and go for cross border bulge chasing with this
+* particular window.
+*
+ II = INDXG2L( SWIN, NB, MYROW, DESCH(RSRC_), NPROW )
+ JJ = INDXG2L( SWIN, NB, MYCOL, DESCH(CSRC_), NPCOL )
+ LLKTOP = 1 + LIROFFH
+ LLKBOT = LLKTOP + LNWIN - 1
+*
+ IPU = IPNEXT
+ IPH = IPU + LNWIN**2
+ IPUU = IPH + MAX(NTINY+1,DIM)**2
+ IPV = IPUU + MAX(NTINY+1,DIM)**2
+ IPNEXT = IPH
+*
+ IF( LSAME( JOB, 'A' ) .OR. LSAME( JOB, 'O' ) .AND.
+ $ DIM.LT.NTINY+1 ) THEN
+ CALL DLASET( 'All', NTINY+1, NTINY+1, ZERO, ONE,
+ $ WORK(IPH), NTINY+1 )
+ END IF
+ CALL DLAMOV( 'Upper', DIM, DIM, H(II+(JJ-1)*LLDH), LLDH,
+ $ WORK(IPH), MAX(NTINY+1,DIM) )
+ CALL DCOPY( DIM-1, H(II+(JJ-1)*LLDH+1), LLDH+1,
+ $ WORK(IPH+1), MAX(NTINY+1,DIM)+1 )
+ IF( LSAME( JOB, 'C' ) .OR. LSAME( JOB, 'O') ) THEN
+ CALL DCOPY( DIM-2, H(II+(JJ-1)*LLDH+2), LLDH+1,
+ $ WORK(IPH+2), MAX(NTINY+1,DIM)+1 )
+ CALL DCOPY( DIM-3, H(II+(JJ-1)*LLDH+3), LLDH+1,
+ $ WORK(IPH+3), MAX(NTINY+1,DIM)+1 )
+ CALL DLASET( 'Lower', DIM-4, DIM-4, ZERO,
+ $ ZERO, WORK(IPH+4), MAX(NTINY+1,DIM) )
+ ELSE
+ CALL DLASET( 'Lower', DIM-2, DIM-2, ZERO,
+ $ ZERO, WORK(IPH+2), MAX(NTINY+1,DIM) )
+ END IF
+*
+ KU = MAX(NTINY+1,DIM) - KDU + 1
+ KWH = KDU + 1
+ NHO = ( MAX(NTINY+1,DIM)-KDU+1-4 ) - ( KDU+1 ) + 1
+ KWV = KDU + 4
+ NVE = MAX(NTINY+1,DIM) - KDU - KWV + 1
+ CALL DLASET( 'All', MAX(NTINY+1,DIM),
+ $ MAX(NTINY+1,DIM), ZERO, ONE, WORK(IPUU),
+ $ MAX(NTINY+1,DIM) )
+*
+* Small-bulge multi-shift QR sweep.
+*
+ LKS = MAX( 1, NS - WIN*LNS + 1 )
+ CALL DLAQR6( JOB, WANTT, .TRUE., LKACC22,
+ $ MAX(NTINY+1,DIM), LLKTOP, LLKBOT, LNS, SR( LKS ),
+ $ SI( LKS ), WORK(IPH), MAX(NTINY+1,DIM), LLKTOP,
+ $ LLKBOT, WORK(IPUU), MAX(NTINY+1,DIM), WORK(IPU),
+ $ 3, WORK( IPH+KU-1 ),
+ $ MAX(NTINY+1,DIM), NVE, WORK( IPH+KWV-1 ),
+ $ MAX(NTINY+1,DIM), NHO, WORK( IPH-1+KU+(KWH-1)*
+ $ MAX(NTINY+1,DIM) ), MAX(NTINY+1,DIM) )
+*
+* Copy submatrix of H back.
+*
+ CALL DLAMOV( 'Upper', DIM, DIM, WORK(IPH),
+ $ MAX(NTINY+1,DIM), H(II+(JJ-1)*LLDH), LLDH )
+ CALL DCOPY( DIM-1, WORK(IPH+1), MAX(NTINY+1,DIM)+1,
+ $ H(II+(JJ-1)*LLDH+1), LLDH+1 )
+ IF( LSAME( JOB, 'I' ) .OR. LSAME( JOB, 'C' ) ) THEN
+ CALL DCOPY( DIM-2, WORK(IPH+2), DIM+1,
+ $ H(II+(JJ-1)*LLDH+2), LLDH+1 )
+ CALL DCOPY( DIM-3, WORK(IPH+3), DIM+1,
+ $ H(II+(JJ-1)*LLDH+3), LLDH+1 )
+ ELSE
+ CALL DLASET( 'Lower', DIM-2, DIM-2, ZERO,
+ $ ZERO, H(II+(JJ-1)*LLDH+2), LLDH )
+ END IF
+*
+* Copy actual submatrix of U to the correct place
+* of the buffer.
+*
+ CALL DLAMOV( 'All', LNWIN, LNWIN,
+ $ WORK(IPUU+(MAX(NTINY+1,DIM)*LIROFFH)+LIROFFH),
+ $ MAX(NTINY+1,DIM), WORK(IPU), LNWIN )
+ END IF
+*
+* In case the local submatrix was smaller than
+* (NTINY+1)-by-(NTINY+1) we go here and proceed.
+*
+ 45 CONTINUE
+ ELSE
+ IWORK( 5+(WIN-1)*5 ) = 2
+ END IF
+*
+* Increment counter for buffers of orthogonal transformations.
+*
+ IF( MYROW.EQ.LRSRC .OR. MYCOL.EQ.LCSRC ) THEN
+ IF( IDONEJOB.EQ.1 .AND. IWORK(5+(WIN-1)*5).LT.2 ) THEN
+ IF( MYROW.EQ.LRSRC ) LENRBUF = LENRBUF + LNWIN*LNWIN
+ IF( MYCOL.EQ.LCSRC ) LENCBUF = LENCBUF + LNWIN*LNWIN
+ END IF
+ END IF
+ 40 CONTINUE
+*
+* Did some work in the above do-loop?
+*
+ CALL IGSUM2D( ICTXT, 'All', '1-Tree', 1, 1, IDONEJOB, 1, -1, -1 )
+ DONEJOB = IDONEJOB.GT.0
+*
+* Chased off bulges from first window?
+*
+ IF( NPROCS.GT.1 )
+ $ CALL IGAMX2D( ICTXT, 'All', '1-Tree', 1, 1, ICHOFF, 1, -1,
+ $ -1, -1, -1, -1 )
+*
+* If work was done in the do-loop over local windows, perform
+* updates, otherwise go for cross border bulge chasing and updates.
+*
+ IF( DONEJOB ) THEN
+*
+* Broadcast orthogonal transformations.
+*
+ 49 CONTINUE
+ IF( LENRBUF.GT.0 .OR. LENCBUF.GT.0 ) THEN
+ DO 50 DIR = 1, 2
+ BCDONE = .FALSE.
+ DO 60 WIN = 1, ANMWIN
+ IF( ( LENRBUF.EQ.0 .AND. LENCBUF.EQ.0 ) .OR.
+ $ BCDONE ) GO TO 62
+ LRSRC = IWORK( 3+(WIN-1)*5 )
+ LCSRC = IWORK( 4+(WIN-1)*5 )
+ IF( MYROW.EQ.LRSRC .AND. MYCOL.EQ.LCSRC ) THEN
+ IF( DIR.EQ.1 .AND. LENRBUF.GT.0 .AND.
+ $ NPCOL.GT.1 ) THEN
+ CALL DGEBS2D( ICTXT, 'Row', '1-Tree', LENRBUF,
+ $ 1, WORK, LENRBUF )
+ ELSEIF( DIR.EQ.2 .AND. LENCBUF.GT.0 .AND.
+ $ NPROW.GT.1 ) THEN
+ CALL DGEBS2D( ICTXT, 'Col', '1-Tree', LENCBUF,
+ $ 1, WORK, LENCBUF )
+ END IF
+ IF( LENRBUF.GT.0 )
+ $ CALL DLAMOV( 'All', LENRBUF, 1, WORK, LENRBUF,
+ $ WORK(1+LENRBUF), LENCBUF )
+ BCDONE = .TRUE.
+ ELSEIF( MYROW.EQ.LRSRC .AND. DIR.EQ.1 ) THEN
+ IF( LENRBUF.GT.0 .AND. NPCOL.GT.1 ) THEN
+ CALL DGEBR2D( ICTXT, 'Row', '1-Tree', LENRBUF,
+ $ 1, WORK, LENRBUF, LRSRC, LCSRC )
+ BCDONE = .TRUE.
+ END IF
+ ELSEIF( MYCOL.EQ.LCSRC .AND. DIR.EQ.2 ) THEN
+ IF( LENCBUF.GT.0 .AND. NPROW.GT.1 ) THEN
+ CALL DGEBR2D( ICTXT, 'Col', '1-Tree', LENCBUF,
+ $ 1, WORK(1+LENRBUF), LENCBUF, LRSRC, LCSRC )
+ BCDONE = .TRUE.
+ END IF
+ END IF
+ 62 CONTINUE
+ 60 CONTINUE
+ 50 CONTINUE
+ END IF
+*
+* Compute updates - make sure to skip windows that was skipped
+* regarding local bulge chasing.
+*
+ DO 65 DIR = 1, 2
+ WINID = 0
+ IF( DIR.EQ.1 ) THEN
+ IPNEXT = 1
+ ELSE
+ IPNEXT = 1 + LENRBUF
+ END IF
+ DO 70 WIN = 1, ANMWIN
+ IF( IWORK( 5+(WIN-1)*5 ).EQ.2 ) GO TO 75
+ LRSRC = IWORK( 3+(WIN-1)*5 )
+ LCSRC = IWORK( 4+(WIN-1)*5 )
+ LKTOP = IWORK( 1+(WIN-1)*5 )
+ LKBOT = IWORK( 2+(WIN-1)*5 )
+ LNWIN = LKBOT - LKTOP + 1
+ IF( (MYROW.EQ.LRSRC.AND.LENRBUF.GT.0.AND.DIR.EQ.1) .OR.
+ $ (MYCOL.EQ.LCSRC.AND.LENCBUF.GT.0.AND.DIR.EQ.2 ) )
+ $ THEN
+*
+* Set up workspaces.
+*
+ IPU = IPNEXT
+ IPNEXT = IPU + LNWIN*LNWIN
+ IPW = 1 + LENRBUF + LENCBUF
+ LIROFFH = MOD(LKTOP-1,NB)
+ WINID = WINID + 1
+*
+* Recompute JOB to see if block structure of U could
+* possibly be exploited or not.
+*
+ IF( LKTOP.EQ.KTOP .AND. LKBOT.EQ.KBOT ) THEN
+ JOB = 'All steps'
+ ELSEIF( LKTOP.EQ.KTOP ) THEN
+ JOB = 'Introduce and chase'
+ ELSEIF( LKBOT.EQ.KBOT ) THEN
+ JOB = 'Off-chase bulges'
+ ELSE
+ JOB = 'Chase bulges'
+ END IF
+ END IF
+*
+* Use U to update far-from-diagonal entries in H.
+* If required, use U to update Z as well.
+*
+ IF( .NOT. BLK22 .OR. .NOT. LSAME(JOB,'C')
+ $ .OR. LNS.LE.2 ) THEN
+*
+ IF( DIR.EQ.2 .AND. LENCBUF.GT.0 .AND.
+ $ MYCOL.EQ.LCSRC ) THEN
+ IF( WANTT ) THEN
+ DO 80 INDX = 1, LKTOP-LIROFFH-1, NB
+ CALL INFOG2L( INDX, LKTOP, DESCH, NPROW,
+ $ NPCOL, MYROW, MYCOL, ILOC, JLOC, RSRC1,
+ $ CSRC1 )
+ IF( MYROW.EQ.RSRC1.AND.MYCOL.EQ.CSRC1 ) THEN
+ LROWS = MIN( NB, LKTOP-INDX )
+ CALL DGEMM('No transpose', 'No transpose',
+ $ LROWS, LNWIN, LNWIN, ONE,
+ $ H((JLOC-1)*LLDH+ILOC), LLDH,
+ $ WORK( IPU ), LNWIN, ZERO,
+ $ WORK(IPW),
+ $ LROWS )
+ CALL DLAMOV( 'All', LROWS, LNWIN,
+ $ WORK(IPW), LROWS,
+ $ H((JLOC-1)*LLDH+ILOC), LLDH )
+ END IF
+ 80 CONTINUE
+ END IF
+ IF( WANTZ ) THEN
+ DO 90 INDX = 1, N, NB
+ CALL INFOG2L( INDX, LKTOP, DESCZ, NPROW,
+ $ NPCOL, MYROW, MYCOL, ILOC, JLOC, RSRC1,
+ $ CSRC1 )
+ IF( MYROW.EQ.RSRC1.AND.MYCOL.EQ.CSRC1 ) THEN
+ LROWS = MIN(NB,N-INDX+1)
+ CALL DGEMM( 'No transpose',
+ $ 'No transpose', LROWS, LNWIN, LNWIN,
+ $ ONE, Z((JLOC-1)*LLDZ+ILOC), LLDZ,
+ $ WORK( IPU ), LNWIN, ZERO,
+ $ WORK(IPW), LROWS )
+ CALL DLAMOV( 'All', LROWS, LNWIN,
+ $ WORK(IPW), LROWS,
+ $ Z((JLOC-1)*LLDZ+ILOC), LLDZ )
+ END IF
+ 90 CONTINUE
+ END IF
+ END IF
+*
+* Update the rows of H affected by the bulge-chase.
+*
+ IF( DIR.EQ.1 .AND. LENRBUF.GT.0 .AND.
+ $ MYROW.EQ.LRSRC ) THEN
+ IF( WANTT ) THEN
+ IF( ICEIL(LKBOT,NB).EQ.ICEIL(KBOT,NB) ) THEN
+ LCOLS = MIN(ICEIL(KBOT,NB)*NB,N) - KBOT
+ ELSE
+ LCOLS = 0
+ END IF
+ IF( LCOLS.GT.0 ) THEN
+ INDX = KBOT + 1
+ CALL INFOG2L( LKTOP, INDX, DESCH, NPROW,
+ $ NPCOL, MYROW, MYCOL, ILOC, JLOC,
+ $ RSRC1, CSRC1 )
+ IF( MYROW.EQ.RSRC1.AND.MYCOL.EQ.CSRC1 ) THEN
+ CALL DGEMM( 'Transpose', 'No Transpose',
+ $ LNWIN, LCOLS, LNWIN, ONE, WORK(IPU),
+ $ LNWIN, H((JLOC-1)*LLDH+ILOC), LLDH,
+ $ ZERO, WORK(IPW), LNWIN )
+ CALL DLAMOV( 'All', LNWIN, LCOLS,
+ $ WORK(IPW), LNWIN,
+ $ H((JLOC-1)*LLDH+ILOC), LLDH )
+ END IF
+ END IF
+ 93 CONTINUE
+ INDXS = ICEIL(LKBOT,NB)*NB + 1
+ DO 95 INDX = INDXS, N, NB
+ CALL INFOG2L( LKTOP, INDX,
+ $ DESCH, NPROW, NPCOL, MYROW, MYCOL,
+ $ ILOC, JLOC, RSRC1, CSRC1 )
+ IF( MYROW.EQ.RSRC1.AND.MYCOL.EQ.CSRC1 ) THEN
+ LCOLS = MIN( NB, N-INDX+1 )
+ CALL DGEMM( 'Transpose', 'No Transpose',
+ $ LNWIN, LCOLS, LNWIN, ONE, WORK(IPU),
+ $ LNWIN, H((JLOC-1)*LLDH+ILOC), LLDH,
+ $ ZERO, WORK(IPW),
+ $ LNWIN )
+ CALL DLAMOV( 'All', LNWIN, LCOLS,
+ $ WORK(IPW), LNWIN,
+ $ H((JLOC-1)*LLDH+ILOC), LLDH )
+ END IF
+ 95 CONTINUE
+ END IF
+ END IF
+ ELSE
+ KS = LNWIN-LNS/2*3
+*
+* The LNWIN-by-LNWIN matrix U containing the accumulated
+* orthogonal transformations has the following structure:
+*
+* [ U11 U12 ]
+* U = [ ],
+* [ U21 U22 ]
+*
+* where U21 is KS-by-KS upper triangular and U12 is
+* (LNWIN-KS)-by-(LNWIN-KS) lower triangular.
+* Here, KS = LNS.
+*
+* Update the columns of H and Z affected by the bulge
+* chasing.
+*
+* Compute H2*U21 + H1*U11 in workspace.
+*
+ IF( DIR.EQ.2 .AND. LENCBUF.GT.0 .AND.
+ $ MYCOL.EQ.LCSRC ) THEN
+ IF( WANTT ) THEN
+ DO 100 INDX = 1, LKTOP-LIROFFH-1, NB
+ CALL INFOG2L( INDX, LKTOP, DESCH, NPROW,
+ $ NPCOL, MYROW, MYCOL, ILOC, JLOC, RSRC1,
+ $ CSRC1 )
+ IF( MYROW.EQ.RSRC1.AND.MYCOL.EQ.CSRC1 ) THEN
+ JLOC1 = INDXG2L( LKTOP+LNWIN-KS, NB,
+ $ MYCOL, DESCH( CSRC_ ), NPCOL )
+ LROWS = MIN( NB, LKTOP-INDX )
+ CALL DLAMOV( 'All', LROWS, KS,
+ $ H((JLOC1-1)*LLDH+ILOC ), LLDH,
+ $ WORK(IPW), LROWS )
+ CALL DTRMM( 'Right', 'Upper',
+ $ 'No transpose','Non-unit', LROWS,
+ $ KS, ONE, WORK( IPU+LNWIN-KS ), LNWIN,
+ $ WORK(IPW), LROWS )
+ CALL DGEMM('No transpose', 'No transpose',
+ $ LROWS, KS, LNWIN-KS, ONE,
+ $ H((JLOC-1)*LLDH+ILOC), LLDH,
+ $ WORK( IPU ), LNWIN, ONE, WORK(IPW),
+ $ LROWS )
+*
+* Compute H1*U12 + H2*U22 in workspace.
+*
+ CALL DLAMOV( 'All', LROWS, LNWIN-KS,
+ $ H((JLOC-1)*LLDH+ILOC), LLDH,
+ $ WORK( IPW+KS*LROWS ), LROWS )
+ CALL DTRMM( 'Right', 'Lower',
+ $ 'No transpose', 'Non-Unit',
+ $ LROWS, LNWIN-KS, ONE,
+ $ WORK( IPU+LNWIN*KS ), LNWIN,
+ $ WORK( IPW+KS*LROWS ), LROWS )
+ CALL DGEMM('No transpose', 'No transpose',
+ $ LROWS, LNWIN-KS, KS, ONE,
+ $ H((JLOC1-1)*LLDH+ILOC), LLDH,
+ $ WORK( IPU+LNWIN*KS+LNWIN-KS ), LNWIN,
+ $ ONE, WORK( IPW+KS*LROWS ), LROWS )
+*
+* Copy workspace to H.
+*
+ CALL DLAMOV( 'All', LROWS, LNWIN,
+ $ WORK(IPW), LROWS,
+ $ H((JLOC-1)*LLDH+ILOC), LLDH )
+ END IF
+ 100 CONTINUE
+ END IF
+*
+ IF( WANTZ ) THEN
+*
+* Compute Z2*U21 + Z1*U11 in workspace.
+*
+ DO 110 INDX = 1, N, NB
+ CALL INFOG2L( INDX, LKTOP, DESCZ, NPROW,
+ $ NPCOL, MYROW, MYCOL, ILOC, JLOC, RSRC1,
+ $ CSRC1 )
+ IF( MYROW.EQ.RSRC1.AND.MYCOL.EQ.CSRC1 ) THEN
+ JLOC1 = INDXG2L( LKTOP+LNWIN-KS, NB,
+ $ MYCOL, DESCZ( CSRC_ ), NPCOL )
+ LROWS = MIN(NB,N-INDX+1)
+ CALL DLAMOV( 'All', LROWS, KS,
+ $ Z((JLOC1-1)*LLDZ+ILOC ), LLDZ,
+ $ WORK(IPW), LROWS )
+ CALL DTRMM( 'Right', 'Upper',
+ $ 'No transpose', 'Non-unit',
+ $ LROWS, KS, ONE, WORK( IPU+LNWIN-KS ),
+ $ LNWIN, WORK(IPW), LROWS )
+ CALL DGEMM( 'No transpose',
+ $ 'No transpose', LROWS, KS, LNWIN-KS,
+ $ ONE, Z((JLOC-1)*LLDZ+ILOC), LLDZ,
+ $ WORK( IPU ), LNWIN, ONE, WORK(IPW),
+ $ LROWS )
+*
+* Compute Z1*U12 + Z2*U22 in workspace.
+*
+ CALL DLAMOV( 'All', LROWS, LNWIN-KS,
+ $ Z((JLOC-1)*LLDZ+ILOC), LLDZ,
+ $ WORK( IPW+KS*LROWS ), LROWS)
+ CALL DTRMM( 'Right', 'Lower',
+ $ 'No transpose', 'Non-unit',
+ $ LROWS, LNWIN-KS, ONE,
+ $ WORK( IPU+LNWIN*KS ), LNWIN,
+ $ WORK( IPW+KS*LROWS ), LROWS )
+ CALL DGEMM( 'No transpose',
+ $ 'No transpose', LROWS, LNWIN-KS, KS,
+ $ ONE, Z((JLOC1-1)*LLDZ+ILOC), LLDZ,
+ $ WORK( IPU+LNWIN*KS+LNWIN-KS ), LNWIN,
+ $ ONE, WORK( IPW+KS*LROWS ),
+ $ LROWS )
+*
+* Copy workspace to Z.
+*
+ CALL DLAMOV( 'All', LROWS, LNWIN,
+ $ WORK(IPW), LROWS,
+ $ Z((JLOC-1)*LLDZ+ILOC), LLDZ )
+ END IF
+ 110 CONTINUE
+ END IF
+ END IF
+*
+ IF( DIR.EQ.1 .AND. LENRBUF.GT.0 .AND.
+ $ MYROW.EQ.LRSRC ) THEN
+ IF( WANTT ) THEN
+ INDXS = ICEIL(LKBOT,NB)*NB + 1
+ DO 120 INDX = INDXS, N, NB
+ CALL INFOG2L( LKTOP, INDX,
+ $ DESCH, NPROW, NPCOL, MYROW, MYCOL, ILOC,
+ $ JLOC, RSRC1, CSRC1 )
+ IF( MYROW.EQ.RSRC1.AND.MYCOL.EQ.CSRC1 ) THEN
+*
+* Compute U21**T*H2 + U11**T*H1 in workspace.
+*
+ ILOC1 = INDXG2L( LKTOP+LNWIN-KS, NB,
+ $ MYROW, DESCH( RSRC_ ), NPROW )
+ LCOLS = MIN( NB, N-INDX+1 )
+ CALL DLAMOV( 'All', KS, LCOLS,
+ $ H((JLOC-1)*LLDH+ILOC1), LLDH,
+ $ WORK(IPW), LNWIN )
+ CALL DTRMM( 'Left', 'Upper', 'Transpose',
+ $ 'Non-unit', KS, LCOLS, ONE,
+ $ WORK( IPU+LNWIN-KS ), LNWIN,
+ $ WORK(IPW), LNWIN )
+ CALL DGEMM( 'Transpose', 'No transpose',
+ $ KS, LCOLS, LNWIN-KS, ONE, WORK(IPU),
+ $ LNWIN, H((JLOC-1)*LLDH+ILOC), LLDH,
+ $ ONE, WORK(IPW), LNWIN )
+*
+* Compute U12**T*H1 + U22**T*H2 in workspace.
+*
+ CALL DLAMOV( 'All', LNWIN-KS, LCOLS,
+ $ H((JLOC-1)*LLDH+ILOC), LLDH,
+ $ WORK( IPW+KS ), LNWIN )
+ CALL DTRMM( 'Left', 'Lower', 'Transpose',
+ $ 'Non-unit', LNWIN-KS, LCOLS, ONE,
+ $ WORK( IPU+LNWIN*KS ), LNWIN,
+ $ WORK( IPW+KS ), LNWIN )
+ CALL DGEMM( 'Transpose', 'No Transpose',
+ $ LNWIN-KS, LCOLS, KS, ONE,
+ $ WORK( IPU+LNWIN*KS+LNWIN-KS ), LNWIN,
+ $ H((JLOC-1)*LLDH+ILOC1), LLDH,
+ $ ONE, WORK( IPW+KS ), LNWIN )
+*
+* Copy workspace to H.
+*
+ CALL DLAMOV( 'All', LNWIN, LCOLS,
+ $ WORK(IPW), LNWIN,
+ $ H((JLOC-1)*LLDH+ILOC), LLDH )
+ END IF
+ 120 CONTINUE
+ END IF
+ END IF
+ END IF
+*
+* Update position information about current window.
+*
+ IF( DIR.EQ.2 ) THEN
+ IF( LKBOT.EQ.KBOT ) THEN
+ LKTOP = KBOT+1
+ LKBOT = KBOT+1
+ IWORK( 1+(WIN-1)*5 ) = LKTOP
+ IWORK( 2+(WIN-1)*5 ) = LKBOT
+ IWORK( 5+(WIN-1)*5 ) = 2
+ ELSE
+ LKTOP = MIN( LKTOP + LNWIN - LCHAIN,
+ $ ICEIL( LKTOP, NB )*NB - LCHAIN + 1,
+ $ KBOT )
+ IWORK( 1+(WIN-1)*5 ) = LKTOP
+ LKBOT = MIN( LKBOT + LNWIN - LCHAIN,
+ $ ICEIL( LKBOT, NB )*NB, KBOT )
+ IWORK( 2+(WIN-1)*5 ) = LKBOT
+ LNWIN = LKBOT-LKTOP+1
+ IF( LNWIN.EQ.LCHAIN ) IWORK(5+(WIN-1)*5) = 2
+ END IF
+ END IF
+ 75 CONTINUE
+ 70 CONTINUE
+ 65 CONTINUE
+*
+* If bulges were chasen off from first window, the window is
+* removed.
+*
+ IF( ICHOFF.GT.0 ) THEN
+ DO 128 WIN = 2, ANMWIN
+ IWORK( 1+(WIN-2)*5 ) = IWORK( 1+(WIN-1)*5 )
+ IWORK( 2+(WIN-2)*5 ) = IWORK( 2+(WIN-1)*5 )
+ IWORK( 3+(WIN-2)*5 ) = IWORK( 3+(WIN-1)*5 )
+ IWORK( 4+(WIN-2)*5 ) = IWORK( 4+(WIN-1)*5 )
+ IWORK( 5+(WIN-2)*5 ) = IWORK( 5+(WIN-1)*5 )
+ 128 CONTINUE
+ ANMWIN = ANMWIN - 1
+ IPIW = 6+(ANMWIN-1)*5
+ END IF
+*
+* If we have no more windows, return.
+*
+ IF( ANMWIN.LT.1 ) RETURN
+*
+ ELSE
+*
+* Set up windows such that as many bulges as possible can be
+* moved over the border to the next block. Make sure that the
+* cross border window is at least (NTINY+1)-by-(NTINY+1), unless
+* we are chasing off the bulges from the last window. This is
+* accomplished by setting the bottom index LKBOT such that the
+* local window has the correct size.
+*
+* If LKBOT then becomes larger than KBOT, the endpoint of the whole
+* global submatrix, or LKTOP from a window located already residing
+* at the other side of the border, this is taken care of by some
+* dirty tricks.
+*
+ DO 130 WIN = 1, ANMWIN
+ LKTOP1 = IWORK( 1+(WIN-1)*5 )
+ LKBOT = IWORK( 2+(WIN-1)*5 )
+ LNWIN = MAX( 6, MIN( LKBOT - LKTOP1 + 1, LCHAIN ) )
+ LKBOT1 = MAX( MIN( KBOT, ICEIL(LKTOP1,NB)*NB+LCHAIN),
+ $ MIN( KBOT, MIN( LKTOP1+2*LNWIN-1,
+ $ (ICEIL(LKTOP1,NB)+1)*NB ) ) )
+ IWORK( 2+(WIN-1)*5 ) = LKBOT1
+ 130 CONTINUE
+ ICHOFF = 0
+*
+* Keep a record over what windows that were moved over the borders
+* such that we can delay some windows due to lack of space on the
+* other side of the border; we do not want to leave any of the
+* bulges behind...
+*
+* IWORK( 5+(WIN-1)*5 ) = 0: window WIN has not been processed
+* IWORK( 5+(WIN-1)*5 ) = 1: window WIN is being processed (need to
+* know for updates)
+* IWORK( 5+(WIN-1)*5 ) = 2: window WIN has been fully processed
+*
+* So, start by marking all windows as not processed.
+*
+ DO 135 WIN = 1, ANMWIN
+ IWORK( 5+(WIN-1)*5 ) = 0
+ 135 CONTINUE
+*
+* Do the cross border bulge-chase as follows: Start from the
+* first window (the one that is closest to be chased off the
+* diagonal of H) and take the odd windows first followed by the
+* even ones. To not get into hang-problems on processor meshes
+* with at least one odd dimension, the windows will in such a case
+* be processed in chunks of {the minimum odd process dimension}-1
+* windows to avoid overlapping processor scopes in forming the
+* cross border computational windows and the cross border update
+* regions.
+*
+ WCHUNK = MAX( 1, MIN( ANMWIN, NPROW-1, NPCOL-1 ) )
+ NUMCHUNK = ICEIL( ANMWIN, WCHUNK )
+*
+* Based on the computed chunk of windows, start working with
+* crossborder bulge-chasing. Repeat this as long as there is
+* still work left to do (137 is a kind of do-while statement).
+*
+ 137 CONTINUE
+*
+* Zero out LENRBUF and LENCBUF each time we restart this loop.
+*
+ LENRBUF = 0
+ LENCBUF = 0
+*
+ DO 140 ODDEVEN = 1, MIN( 2, ANMWIN )
+ DO 150 CHUNKNUM = 1, NUMCHUNK
+ IPNEXT = 1
+ DO 160 WIN = ODDEVEN+(CHUNKNUM-1)*WCHUNK,
+ $ MIN(ANMWIN,MAX(1,ODDEVEN+(CHUNKNUM)*WCHUNK-1)), 2
+*
+* Get position and size of the WIN:th active window and
+* make sure that we skip the cross border bulge for this
+* window if the window is not shared between several data
+* layout blocks (and processors).
+*
+* Also, delay windows that do not have sufficient size of
+* the other side of the border. Moreover, make sure to skip
+* windows that was already processed in the last round of
+* the do-while loop (137).
+*
+ IF( IWORK( 5+(WIN-1)*5 ).EQ.2 ) GO TO 165
+ LKTOP = IWORK( 1+(WIN-1)*5 )
+ LKBOT = IWORK( 2+(WIN-1)*5 )
+ IF( WIN.GT.1 ) THEN
+ LKTOP2 = IWORK( 1+(WIN-2)*5 )
+ ELSE
+ LKTOP2 = KBOT+1
+ END IF
+ IF( ICEIL(LKTOP,NB).EQ.ICEIL(LKBOT,NB) .OR.
+ $ LKBOT.GE.LKTOP2 ) GO TO 165
+ LNWIN = LKBOT - LKTOP + 1
+ IF( LNWIN.LE.NTINY .AND. LKBOT.NE.KBOT .AND.
+ $ .NOT. MOD(LKBOT,NB).EQ.0 ) GO TO 165
+*
+* If window is going to be processed, mark it as processed.
+*
+ IWORK( 5+(WIN-1)*5 ) = 1
+*
+* Extract processors for current cross border window,
+* as below:
+*
+* 1 | 2
+* --+--
+* 3 | 4
+*
+ RSRC1 = IWORK( 3+(WIN-1)*5 )
+ CSRC1 = IWORK( 4+(WIN-1)*5 )
+ RSRC2 = RSRC1
+ CSRC2 = MOD( CSRC1+1, NPCOL )
+ RSRC3 = MOD( RSRC1+1, NPROW )
+ CSRC3 = CSRC1
+ RSRC4 = MOD( RSRC1+1, NPROW )
+ CSRC4 = MOD( CSRC1+1, NPCOL )
+*
+* Form group of four processors for cross border window.
+*
+ IF( ( MYROW.EQ.RSRC1 .AND. MYCOL.EQ.CSRC1 ) .OR.
+ $ ( MYROW.EQ.RSRC2 .AND. MYCOL.EQ.CSRC2 ) .OR.
+ $ ( MYROW.EQ.RSRC3 .AND. MYCOL.EQ.CSRC3 ) .OR.
+ $ ( MYROW.EQ.RSRC4 .AND. MYCOL.EQ.CSRC4 ) ) THEN
+*
+* Compute the upper and lower parts of the active
+* window.
+*
+ DIM1 = NB - MOD(LKTOP-1,NB)
+ DIM4 = LNWIN - DIM1
+*
+* Temporarily compute a new value of the size of the
+* computational window that is larger than or equal to
+* NTINY+1; call the *real* value DIM.
+*
+ DIM = LNWIN
+ LNWIN = MAX(NTINY+1,LNWIN)
+*
+* Divide workspace.
+*
+ IPU = IPNEXT
+ IPH = IPU + DIM**2
+ IPUU = IPH + LNWIN**2
+ IPV = IPUU + LNWIN**2
+ IPNEXT = IPH
+ IF( DIM.LT.LNWIN ) THEN
+ CALL DLASET( 'All', LNWIN, LNWIN, ZERO,
+ $ ONE, WORK( IPH ), LNWIN )
+ ELSE
+ CALL DLASET( 'All', DIM, DIM, ZERO,
+ $ ZERO, WORK( IPH ), LNWIN )
+ END IF
+*
+* Form the active window.
+*
+ IF( MYROW.EQ.RSRC1 .AND. MYCOL.EQ.CSRC1 ) THEN
+ ILOC = INDXG2L( LKTOP, NB, MYROW,
+ $ DESCH( RSRC_ ), NPROW )
+ JLOC = INDXG2L( LKTOP, NB, MYCOL,
+ $ DESCH( CSRC_ ), NPCOL )
+ CALL DLAMOV( 'All', DIM1, DIM1,
+ $ H((JLOC-1)*LLDH+ILOC), LLDH, WORK(IPH),
+ $ LNWIN )
+ IF( RSRC1.NE.RSRC4 .OR. CSRC1.NE.CSRC4 ) THEN
+* Proc#1 <==> Proc#4
+ CALL DGESD2D( ICTXT, DIM1, DIM1,
+ $ WORK(IPH), LNWIN, RSRC4, CSRC4 )
+ CALL DGERV2D( ICTXT, DIM4, DIM4,
+ $ WORK(IPH+DIM1*LNWIN+DIM1),
+ $ LNWIN, RSRC4, CSRC4 )
+ END IF
+ END IF
+ IF( MYROW.EQ.RSRC4 .AND. MYCOL.EQ.CSRC4 ) THEN
+ ILOC = INDXG2L( LKTOP+DIM1, NB, MYROW,
+ $ DESCH( RSRC_ ), NPROW )
+ JLOC = INDXG2L( LKTOP+DIM1, NB, MYCOL,
+ $ DESCH( CSRC_ ), NPCOL )
+ CALL DLAMOV( 'All', DIM4, DIM4,
+ $ H((JLOC-1)*LLDH+ILOC), LLDH,
+ $ WORK(IPH+DIM1*LNWIN+DIM1),
+ $ LNWIN )
+ IF( RSRC4.NE.RSRC1 .OR. CSRC4.NE.CSRC1 ) THEN
+* Proc#4 <==> Proc#1
+ CALL DGESD2D( ICTXT, DIM4, DIM4,
+ $ WORK(IPH+DIM1*LNWIN+DIM1),
+ $ LNWIN, RSRC1, CSRC1 )
+ CALL DGERV2D( ICTXT, DIM1, DIM1,
+ $ WORK(IPH), LNWIN, RSRC1, CSRC1 )
+ END IF
+ END IF
+ IF( MYROW.EQ.RSRC2 .AND. MYCOL.EQ.CSRC2 ) THEN
+ ILOC = INDXG2L( LKTOP, NB, MYROW,
+ $ DESCH( RSRC_ ), NPROW )
+ JLOC = INDXG2L( LKTOP+DIM1, NB, MYCOL,
+ $ DESCH( CSRC_ ), NPCOL )
+ CALL DLAMOV( 'All', DIM1, DIM4,
+ $ H((JLOC-1)*LLDH+ILOC), LLDH,
+ $ WORK(IPH+DIM1*LNWIN), LNWIN )
+ IF( RSRC2.NE.RSRC1 .OR. CSRC2.NE.CSRC1 ) THEN
+* Proc#2 ==> Proc#1
+ CALL DGESD2D( ICTXT, DIM1, DIM4,
+ $ WORK(IPH+DIM1*LNWIN),
+ $ LNWIN, RSRC1, CSRC1 )
+ END IF
+ END IF
+ IF( MYROW.EQ.RSRC2 .AND. MYCOL.EQ.CSRC2 ) THEN
+ IF( RSRC2.NE.RSRC4 .OR. CSRC2.NE.CSRC4 ) THEN
+* Proc#2 ==> Proc#4
+ CALL DGESD2D( ICTXT, DIM1, DIM4,
+ $ WORK(IPH+DIM1*LNWIN),
+ $ LNWIN, RSRC4, CSRC4 )
+ END IF
+ END IF
+ IF( MYROW.EQ.RSRC3 .AND. MYCOL.EQ.CSRC3 ) THEN
+ ILOC = INDXG2L( LKTOP+DIM1, NB, MYROW,
+ $ DESCH( RSRC_ ), NPROW )
+ JLOC = INDXG2L( LKTOP+DIM1-1, NB, MYCOL,
+ $ DESCH( CSRC_ ), NPCOL )
+ CALL DLAMOV( 'All', 1, 1,
+ $ H((JLOC-1)*LLDH+ILOC), LLDH,
+ $ WORK(IPH+(DIM1-1)*LNWIN+DIM1),
+ $ LNWIN )
+ IF( RSRC3.NE.RSRC1 .OR. CSRC3.NE.CSRC1 ) THEN
+* Proc#3 ==> Proc#1
+ CALL DGESD2D( ICTXT, 1, 1,
+ $ WORK(IPH+(DIM1-1)*LNWIN+DIM1),
+ $ LNWIN, RSRC1, CSRC1 )
+ END IF
+ END IF
+ IF( MYROW.EQ.RSRC3 .AND. MYCOL.EQ.CSRC3 ) THEN
+ IF( RSRC3.NE.RSRC4 .OR. CSRC3.NE.CSRC4 ) THEN
+* Proc#3 ==> Proc#4
+ CALL DGESD2D( ICTXT, 1, 1,
+ $ WORK(IPH+(DIM1-1)*LNWIN+DIM1),
+ $ LNWIN, RSRC4, CSRC4 )
+ END IF
+ END IF
+ IF( MYROW.EQ.RSRC1 .AND. MYCOL.EQ.CSRC1 ) THEN
+ IF( RSRC1.NE.RSRC2 .OR. CSRC1.NE.CSRC2 ) THEN
+* Proc#1 <== Proc#2
+ CALL DGERV2D( ICTXT, DIM1, DIM4,
+ $ WORK(IPH+DIM1*LNWIN),
+ $ LNWIN, RSRC2, CSRC2 )
+ END IF
+ IF( RSRC1.NE.RSRC3 .OR. CSRC1.NE.CSRC3 ) THEN
+* Proc#1 <== Proc#3
+ CALL DGERV2D( ICTXT, 1, 1,
+ $ WORK(IPH+(DIM1-1)*LNWIN+DIM1),
+ $ LNWIN, RSRC3, CSRC3 )
+ END IF
+ END IF
+ IF( MYROW.EQ.RSRC4 .AND. MYCOL.EQ.CSRC4 ) THEN
+ IF( RSRC4.NE.RSRC2 .OR. CSRC4.NE.CSRC2 ) THEN
+* Proc#4 <== Proc#2
+ CALL DGERV2D( ICTXT, DIM1, DIM4,
+ $ WORK(IPH+DIM1*LNWIN),
+ $ LNWIN, RSRC2, CSRC2 )
+ END IF
+ IF( RSRC4.NE.RSRC3 .OR. CSRC4.NE.CSRC3 ) THEN
+* Proc#4 <== Proc#3
+ CALL DGERV2D( ICTXT, 1, 1,
+ $ WORK(IPH+(DIM1-1)*LNWIN+DIM1),
+ $ LNWIN, RSRC3, CSRC3 )
+ END IF
+ END IF
+*
+* Prepare for call to DLAQR6 - it could happen that no
+* bulges where introduced in the pre-cross border step
+* since the chain was too long to fit in the top-left
+* part of the cross border window. In such a case, the
+* bulges are introduced here instead. It could also
+* happen that the bottom-right part is too small to hold
+* the whole chain -- in such a case, the bulges are
+* chasen off immediately, as well.
+*
+ IF( (MYROW.EQ.RSRC1 .AND. MYCOL.EQ.CSRC1) .OR.
+ $ (MYROW.EQ.RSRC4 .AND. MYCOL.EQ.CSRC4) ) THEN
+ IF( LKTOP.EQ.KTOP .AND. LKBOT.EQ.KBOT .AND.
+ $ (DIM1.LE.LCHAIN .OR. DIM1.LE.NTINY ) ) THEN
+ JOB = 'All steps'
+ ICHOFF = 1
+ ELSEIF( LKTOP.EQ.KTOP .AND.
+ $ ( DIM1.LE.LCHAIN .OR. DIM1.LE.NTINY ) ) THEN
+ JOB = 'Introduce and chase'
+ ELSEIF( LKBOT.EQ.KBOT ) THEN
+ JOB = 'Off-chase bulges'
+ ICHOFF = 1
+ ELSE
+ JOB = 'Chase bulges'
+ END IF
+ KU = LNWIN - KDU + 1
+ KWH = KDU + 1
+ NHO = ( LNWIN-KDU+1-4 ) - ( KDU+1 ) + 1
+ KWV = KDU + 4
+ NVE = LNWIN - KDU - KWV + 1
+ CALL DLASET( 'All', LNWIN, LNWIN,
+ $ ZERO, ONE, WORK(IPUU), LNWIN )
+*
+* Small-bulge multi-shift QR sweep.
+*
+ LKS = MAX(1, NS - WIN*LNS + 1)
+ CALL DLAQR6( JOB, WANTT, .TRUE., LKACC22, LNWIN,
+ $ 1, DIM, LNS, SR( LKS ), SI( LKS ),
+ $ WORK(IPH), LNWIN, 1, DIM,
+ $ WORK(IPUU), LNWIN, WORK(IPU), 3,
+ $ WORK( IPH+KU-1 ), LNWIN, NVE,
+ $ WORK( IPH+KWV-1 ), LNWIN, NHO,
+ $ WORK( IPH-1+KU+(KWH-1)*LNWIN ), LNWIN )
+*
+* Copy local submatrices of H back to global matrix.
+*
+ IF( MYROW.EQ.RSRC1 .AND. MYCOL.EQ.CSRC1 ) THEN
+ ILOC = INDXG2L( LKTOP, NB, MYROW,
+ $ DESCH( RSRC_ ), NPROW )
+ JLOC = INDXG2L( LKTOP, NB, MYCOL,
+ $ DESCH( CSRC_ ), NPCOL )
+ CALL DLAMOV( 'All', DIM1, DIM1, WORK(IPH),
+ $ LNWIN, H((JLOC-1)*LLDH+ILOC),
+ $ LLDH )
+ END IF
+ IF( MYROW.EQ.RSRC4 .AND. MYCOL.EQ.CSRC4 ) THEN
+ ILOC = INDXG2L( LKTOP+DIM1, NB, MYROW,
+ $ DESCH( RSRC_ ), NPROW )
+ JLOC = INDXG2L( LKTOP+DIM1, NB, MYCOL,
+ $ DESCH( CSRC_ ), NPCOL )
+ CALL DLAMOV( 'All', DIM4, DIM4,
+ $ WORK(IPH+DIM1*LNWIN+DIM1),
+ $ LNWIN, H((JLOC-1)*LLDH+ILOC), LLDH )
+ END IF
+*
+* Copy actual submatrix of U to the correct place of
+* the buffer.
+*
+ CALL DLAMOV( 'All', DIM, DIM,
+ $ WORK(IPUU), LNWIN, WORK(IPU), DIM )
+ END IF
+*
+* Return data to process 2 and 3.
+*
+ RWS3 = MIN(3,DIM4)
+ CLS3 = MIN(3,DIM1)
+ IF( MYROW.EQ.RSRC1 .AND. MYCOL.EQ.CSRC1 ) THEN
+ IF( RSRC1.NE.RSRC3 .OR. CSRC1.NE.CSRC3 ) THEN
+* Proc#1 ==> Proc#3
+ CALL DGESD2D( ICTXT, RWS3, CLS3,
+ $ WORK( IPH+(DIM1-CLS3)*LNWIN+DIM1 ),
+ $ LNWIN, RSRC3, CSRC3 )
+ END IF
+ END IF
+ IF( MYROW.EQ.RSRC4 .AND. MYCOL.EQ.CSRC4 ) THEN
+ IF( RSRC4.NE.RSRC2 .OR. CSRC4.NE.CSRC2 ) THEN
+* Proc#4 ==> Proc#2
+ CALL DGESD2D( ICTXT, DIM1, DIM4,
+ $ WORK( IPH+DIM1*LNWIN),
+ $ LNWIN, RSRC2, CSRC2 )
+ END IF
+ END IF
+ IF( MYROW.EQ.RSRC2 .AND. MYCOL.EQ.CSRC2 ) THEN
+ ILOC = INDXG2L( LKTOP, NB, MYROW,
+ $ DESCH( RSRC_ ), NPROW )
+ JLOC = INDXG2L( LKTOP+DIM1, NB, MYCOL,
+ $ DESCH( CSRC_ ), NPCOL )
+ IF( RSRC2.NE.RSRC4 .OR. CSRC2.NE.CSRC4 ) THEN
+* Proc#2 <== Proc#4
+ CALL DGERV2D( ICTXT, DIM1, DIM4,
+ $ WORK(IPH+DIM1*LNWIN),
+ $ LNWIN, RSRC4, CSRC4 )
+ END IF
+ CALL DLAMOV( 'All', DIM1, DIM4,
+ $ WORK( IPH+DIM1*LNWIN ), LNWIN,
+ $ H((JLOC-1)*LLDH+ILOC), LLDH )
+ END IF
+ IF( MYROW.EQ.RSRC3 .AND. MYCOL.EQ.CSRC3 ) THEN
+ ILOC = INDXG2L( LKTOP+DIM1, NB, MYROW,
+ $ DESCH( RSRC_ ), NPROW )
+ JLOC = INDXG2L( LKTOP+DIM1-CLS3, NB, MYCOL,
+ $ DESCH( CSRC_ ), NPCOL )
+ IF( RSRC3.NE.RSRC1 .OR. CSRC3.NE.CSRC1 ) THEN
+* Proc#3 <== Proc#1
+ CALL DGERV2D( ICTXT, RWS3, CLS3,
+ $ WORK( IPH+(DIM1-CLS3)*LNWIN+DIM1 ),
+ $ LNWIN, RSRC1, CSRC1 )
+ END IF
+ CALL DLAMOV( 'Upper', RWS3, CLS3,
+ $ WORK( IPH+(DIM1-CLS3)*LNWIN+DIM1 ),
+ $ LNWIN, H((JLOC-1)*LLDH+ILOC),
+ $ LLDH )
+ IF( RWS3.GT.1 .AND. CLS3.GT.1 ) THEN
+ ELEM = WORK( IPH+(DIM1-CLS3)*LNWIN+DIM1+1 )
+ IF( ELEM.NE.ZERO ) THEN
+ CALL DLAMOV( 'Lower', RWS3-1, CLS3-1,
+ $ WORK( IPH+(DIM1-CLS3)*LNWIN+DIM1+1 ),
+ $ LNWIN, H((JLOC-1)*LLDH+ILOC+1), LLDH )
+ END IF
+ END IF
+ END IF
+*
+* Restore correct value of LNWIN.
+*
+ LNWIN = DIM
+*
+ END IF
+*
+* Increment counter for buffers of orthogonal
+* transformations.
+*
+ IF( MYROW.EQ.RSRC1 .OR. MYCOL.EQ.CSRC1 .OR.
+ $ MYROW.EQ.RSRC4 .OR. MYCOL.EQ.CSRC4 ) THEN
+ IF( MYROW.EQ.RSRC1 .OR. MYROW.EQ.RSRC4 )
+ $ LENRBUF = LENRBUF + LNWIN*LNWIN
+ IF( MYCOL.EQ.CSRC1 .OR. MYCOL.EQ.CSRC4 )
+ $ LENCBUF = LENCBUF + LNWIN*LNWIN
+ END IF
+*
+* If no cross border bulge chasing was performed for the
+* current WIN:th window, the processor jump to this point
+* and consider the next one.
+*
+ 165 CONTINUE
+*
+ 160 CONTINUE
+*
+* Broadcast orthogonal transformations -- this will only happen
+* if the buffer associated with the orthogonal transformations
+* is not empty (controlled by LENRBUF, for row-wise
+* broadcasts, and LENCBUF, for column-wise broadcasts).
+*
+ DO 170 DIR = 1, 2
+ BCDONE = .FALSE.
+ DO 180 WIN = ODDEVEN+(CHUNKNUM-1)*WCHUNK,
+ $ MIN(ANMWIN,MAX(1,ODDEVEN+(CHUNKNUM)*WCHUNK-1)), 2
+ IF( ( LENRBUF.EQ.0 .AND. LENCBUF.EQ.0 ) .OR.
+ $ BCDONE ) GO TO 185
+ RSRC1 = IWORK( 3+(WIN-1)*5 )
+ CSRC1 = IWORK( 4+(WIN-1)*5 )
+ RSRC4 = MOD( RSRC1+1, NPROW )
+ CSRC4 = MOD( CSRC1+1, NPCOL )
+ IF( ( MYROW.EQ.RSRC1 .AND. MYCOL.EQ.CSRC1 ) .OR.
+ $ ( MYROW.EQ.RSRC4 .AND. MYCOL.EQ.CSRC4 ) ) THEN
+ IF( DIR.EQ.1 .AND. LENRBUF.GT.0 .AND.
+ $ NPCOL.GT.1 .AND. NPROCS.GT.2 ) THEN
+ IF( MYROW.EQ.RSRC1 .OR. ( MYROW.EQ.RSRC4
+ $ .AND. RSRC4.NE.RSRC1 ) ) THEN
+ CALL DGEBS2D( ICTXT, 'Row', '1-Tree',
+ $ LENRBUF, 1, WORK, LENRBUF )
+ ELSE
+ CALL DGEBR2D( ICTXT, 'Row', '1-Tree',
+ $ LENRBUF, 1, WORK, LENRBUF, RSRC1,
+ $ CSRC1 )
+ END IF
+ ELSEIF( DIR.EQ.2 .AND. LENCBUF.GT.0 .AND.
+ $ NPROW.GT.1 .AND. NPROCS.GT.2 ) THEN
+ IF( MYCOL.EQ.CSRC1 .OR. ( MYCOL.EQ.CSRC4
+ $ .AND. CSRC4.NE.CSRC1 ) ) THEN
+ CALL DGEBS2D( ICTXT, 'Col', '1-Tree',
+ $ LENCBUF, 1, WORK, LENCBUF )
+ ELSE
+ CALL DGEBR2D( ICTXT, 'Col', '1-Tree',
+ $ LENCBUF, 1, WORK(1+LENRBUF), LENCBUF,
+ $ RSRC1, CSRC1 )
+ END IF
+ END IF
+ IF( LENRBUF.GT.0 .AND. ( MYCOL.EQ.CSRC1 .OR.
+ $ ( MYCOL.EQ.CSRC4 .AND. CSRC4.NE.CSRC1 ) ) )
+ $ CALL DLAMOV( 'All', LENRBUF, 1, WORK, LENRBUF,
+ $ WORK(1+LENRBUF), LENCBUF )
+ BCDONE = .TRUE.
+ ELSEIF( MYROW.EQ.RSRC1 .AND. DIR.EQ.1 ) THEN
+ IF( LENRBUF.GT.0 .AND. NPCOL.GT.1 )
+ $ CALL DGEBR2D( ICTXT, 'Row', '1-Tree', LENRBUF,
+ $ 1, WORK, LENRBUF, RSRC1, CSRC1 )
+ BCDONE = .TRUE.
+ ELSEIF( MYCOL.EQ.CSRC1 .AND. DIR.EQ.2 ) THEN
+ IF( LENCBUF.GT.0 .AND. NPROW.GT.1 )
+ $ CALL DGEBR2D( ICTXT, 'Col', '1-Tree', LENCBUF,
+ $ 1, WORK(1+LENRBUF), LENCBUF, RSRC1, CSRC1 )
+ BCDONE = .TRUE.
+ ELSEIF( MYROW.EQ.RSRC4 .AND. DIR.EQ.1 ) THEN
+ IF( LENRBUF.GT.0 .AND. NPCOL.GT.1 )
+ $ CALL DGEBR2D( ICTXT, 'Row', '1-Tree', LENRBUF,
+ $ 1, WORK, LENRBUF, RSRC4, CSRC4 )
+ BCDONE = .TRUE.
+ ELSEIF( MYCOL.EQ.CSRC4 .AND. DIR.EQ.2 ) THEN
+ IF( LENCBUF.GT.0 .AND. NPROW.GT.1 )
+ $ CALL DGEBR2D( ICTXT, 'Col', '1-Tree', LENCBUF,
+ $ 1, WORK(1+LENRBUF), LENCBUF, RSRC4, CSRC4 )
+ BCDONE = .TRUE.
+ END IF
+ 185 CONTINUE
+ 180 CONTINUE
+ 170 CONTINUE
+*
+* Prepare for computing cross border updates by exchanging
+* data in cross border update regions in H and Z.
+*
+ DO 190 DIR = 1, 2
+ WINID = 0
+ IPW3 = 1
+ DO 200 WIN = ODDEVEN+(CHUNKNUM-1)*WCHUNK,
+ $ MIN(ANMWIN,MAX(1,ODDEVEN+(CHUNKNUM)*WCHUNK-1)), 2
+ IF( IWORK( 5+(WIN-1)*5 ).NE.1 ) GO TO 205
+*
+* Make sure this part of the code is only executed when
+* there has been some work performed on the WIN:th
+* window.
+*
+ LKTOP = IWORK( 1+(WIN-1)*5 )
+ LKBOT = IWORK( 2+(WIN-1)*5 )
+*
+* Extract processor indices associated with
+* the current window.
+*
+ RSRC1 = IWORK( 3+(WIN-1)*5 )
+ CSRC1 = IWORK( 4+(WIN-1)*5 )
+ RSRC4 = MOD( RSRC1+1, NPROW )
+ CSRC4 = MOD( CSRC1+1, NPCOL )
+*
+* Compute local number of rows and columns
+* of H and Z to exchange.
+*
+ IF(((MYCOL.EQ.CSRC1.OR.MYCOL.EQ.CSRC4).AND.DIR.EQ.2)
+ $ .OR.((MYROW.EQ.RSRC1.OR.MYROW.EQ.RSRC4).AND.
+ $ DIR.EQ.1)) THEN
+ WINID = WINID + 1
+ LNWIN = LKBOT - LKTOP + 1
+ IPU = IPNEXT
+ DIM1 = NB - MOD(LKTOP-1,NB)
+ DIM4 = LNWIN - DIM1
+ IPNEXT = IPU + LNWIN*LNWIN
+ IF( DIR.EQ.2 ) THEN
+ IF( WANTZ ) THEN
+ ZROWS = NUMROC( N, NB, MYROW, DESCZ( RSRC_ ),
+ $ NPROW )
+ ELSE
+ ZROWS = 0
+ END IF
+ IF( WANTT ) THEN
+ HROWS = NUMROC( LKTOP-1, NB, MYROW,
+ $ DESCH( RSRC_ ), NPROW )
+ ELSE
+ HROWS = 0
+ END IF
+ ELSE
+ ZROWS = 0
+ HROWS = 0
+ END IF
+ IF( DIR.EQ.1 ) THEN
+ IF( WANTT ) THEN
+ HCOLS = NUMROC( N - (LKTOP+DIM1-1), NB,
+ $ MYCOL, CSRC4, NPCOL )
+ IF( MYCOL.EQ.CSRC4 ) HCOLS = HCOLS - DIM4
+ ELSE
+ HCOLS = 0
+ END IF
+ ELSE
+ HCOLS = 0
+ END IF
+ IPW = MAX( 1 + LENRBUF + LENCBUF, IPW3 )
+ IPW1 = IPW + HROWS * LNWIN
+ IF( WANTZ ) THEN
+ IPW2 = IPW1 + LNWIN * HCOLS
+ IPW3 = IPW2 + ZROWS * LNWIN
+ ELSE
+ IPW3 = IPW1 + LNWIN * HCOLS
+ END IF
+ END IF
+*
+* Let each process row and column involved in the updates
+* exchange data in H and Z with their neighbours.
+*
+ IF( DIR.EQ.2 .AND. WANTT .AND. LENCBUF.GT.0 ) THEN
+ IF( MYCOL.EQ.CSRC1 .OR. MYCOL.EQ.CSRC4 ) THEN
+ DO 210 INDX = 1, NPROW
+ IF( MYCOL.EQ.CSRC1 ) THEN
+ CALL INFOG2L( 1+(INDX-1)*NB, LKTOP, DESCH,
+ $ NPROW, NPCOL, MYROW, MYCOL, ILOC,
+ $ JLOC1, RSRC, CSRC1 )
+ IF( MYROW.EQ.RSRC ) THEN
+ CALL DLAMOV( 'All', HROWS, DIM1,
+ $ H((JLOC1-1)*LLDH+ILOC), LLDH,
+ $ WORK(IPW), HROWS )
+ IF( NPCOL.GT.1 ) THEN
+ EAST = MOD( MYCOL + 1, NPCOL )
+ CALL DGESD2D( ICTXT, HROWS, DIM1,
+ $ WORK(IPW), HROWS, RSRC, EAST )
+ CALL DGERV2D( ICTXT, HROWS, DIM4,
+ $ WORK(IPW+HROWS*DIM1), HROWS,
+ $ RSRC, EAST )
+ END IF
+ END IF
+ END IF
+ IF( MYCOL.EQ.CSRC4 ) THEN
+ CALL INFOG2L( 1+(INDX-1)*NB, LKTOP+DIM1,
+ $ DESCH, NPROW, NPCOL, MYROW, MYCOL,
+ $ ILOC, JLOC4, RSRC, CSRC4 )
+ IF( MYROW.EQ.RSRC ) THEN
+ CALL DLAMOV( 'All', HROWS, DIM4,
+ $ H((JLOC4-1)*LLDH+ILOC), LLDH,
+ $ WORK(IPW+HROWS*DIM1), HROWS )
+ IF( NPCOL.GT.1 ) THEN
+ WEST = MOD( MYCOL - 1 + NPCOL,
+ $ NPCOL )
+ CALL DGESD2D( ICTXT, HROWS, DIM4,
+ $ WORK(IPW+HROWS*DIM1), HROWS,
+ $ RSRC, WEST )
+ CALL DGERV2D( ICTXT, HROWS, DIM1,
+ $ WORK(IPW), HROWS, RSRC, WEST )
+ END IF
+ END IF
+ END IF
+ 210 CONTINUE
+ END IF
+ END IF
+*
+ IF( DIR.EQ.1 .AND. WANTT .AND. LENRBUF.GT.0 ) THEN
+ IF( MYROW.EQ.RSRC1 .OR. MYROW.EQ.RSRC4 ) THEN
+ DO 220 INDX = 1, NPCOL
+ IF( MYROW.EQ.RSRC1 ) THEN
+ IF( INDX.EQ.1 ) THEN
+ IF( LKBOT.LT.N ) THEN
+ CALL INFOG2L( LKTOP, LKBOT+1, DESCH,
+ $ NPROW, NPCOL, MYROW, MYCOL,
+ $ ILOC1, JLOC, RSRC1, CSRC )
+ ELSE
+ CSRC = -1
+ END IF
+ ELSEIF( MOD(LKBOT,NB).NE.0 ) THEN
+ CALL INFOG2L( LKTOP,
+ $ (ICEIL(LKBOT,NB)+(INDX-2))*NB+1,
+ $ DESCH, NPROW, NPCOL, MYROW, MYCOL,
+ $ ILOC1, JLOC, RSRC1, CSRC )
+ ELSE
+ CALL INFOG2L( LKTOP,
+ $ (ICEIL(LKBOT,NB)+(INDX-1))*NB+1,
+ $ DESCH, NPROW, NPCOL, MYROW, MYCOL,
+ $ ILOC1, JLOC, RSRC1, CSRC )
+ END IF
+ IF( MYCOL.EQ.CSRC ) THEN
+ CALL DLAMOV( 'All', DIM1, HCOLS,
+ $ H((JLOC-1)*LLDH+ILOC1), LLDH,
+ $ WORK(IPW1), LNWIN )
+ IF( NPROW.GT.1 ) THEN
+ SOUTH = MOD( MYROW + 1, NPROW )
+ CALL DGESD2D( ICTXT, DIM1, HCOLS,
+ $ WORK(IPW1), LNWIN, SOUTH,
+ $ CSRC )
+ CALL DGERV2D( ICTXT, DIM4, HCOLS,
+ $ WORK(IPW1+DIM1), LNWIN, SOUTH,
+ $ CSRC )
+ END IF
+ END IF
+ END IF
+ IF( MYROW.EQ.RSRC4 ) THEN
+ IF( INDX.EQ.1 ) THEN
+ IF( LKBOT.LT.N ) THEN
+ CALL INFOG2L( LKTOP+DIM1, LKBOT+1,
+ $ DESCH, NPROW, NPCOL, MYROW,
+ $ MYCOL, ILOC4, JLOC, RSRC4,
+ $ CSRC )
+ ELSE
+ CSRC = -1
+ END IF
+ ELSEIF( MOD(LKBOT,NB).NE.0 ) THEN
+ CALL INFOG2L( LKTOP+DIM1,
+ $ (ICEIL(LKBOT,NB)+(INDX-2))*NB+1,
+ $ DESCH, NPROW, NPCOL, MYROW, MYCOL,
+ $ ILOC4, JLOC, RSRC4, CSRC )
+ ELSE
+ CALL INFOG2L( LKTOP+DIM1,
+ $ (ICEIL(LKBOT,NB)+(INDX-1))*NB+1,
+ $ DESCH, NPROW, NPCOL, MYROW, MYCOL,
+ $ ILOC4, JLOC, RSRC4, CSRC )
+ END IF
+ IF( MYCOL.EQ.CSRC ) THEN
+ CALL DLAMOV( 'All', DIM4, HCOLS,
+ $ H((JLOC-1)*LLDH+ILOC4), LLDH,
+ $ WORK(IPW1+DIM1), LNWIN )
+ IF( NPROW.GT.1 ) THEN
+ NORTH = MOD( MYROW - 1 + NPROW,
+ $ NPROW )
+ CALL DGESD2D( ICTXT, DIM4, HCOLS,
+ $ WORK(IPW1+DIM1), LNWIN, NORTH,
+ $ CSRC )
+ CALL DGERV2D( ICTXT, DIM1, HCOLS,
+ $ WORK(IPW1), LNWIN, NORTH,
+ $ CSRC )
+ END IF
+ END IF
+ END IF
+ 220 CONTINUE
+ END IF
+ END IF
+*
+ IF( DIR.EQ.2 .AND. WANTZ .AND. LENCBUF.GT.0) THEN
+ IF( MYCOL.EQ.CSRC1 .OR. MYCOL.EQ.CSRC4 ) THEN
+ DO 230 INDX = 1, NPROW
+ IF( MYCOL.EQ.CSRC1 ) THEN
+ CALL INFOG2L( 1+(INDX-1)*NB, LKTOP,
+ $ DESCZ, NPROW, NPCOL, MYROW, MYCOL,
+ $ ILOC, JLOC1, RSRC, CSRC1 )
+ IF( MYROW.EQ.RSRC ) THEN
+ CALL DLAMOV( 'All', ZROWS, DIM1,
+ $ Z((JLOC1-1)*LLDZ+ILOC), LLDZ,
+ $ WORK(IPW2), ZROWS )
+ IF( NPCOL.GT.1 ) THEN
+ EAST = MOD( MYCOL + 1, NPCOL )
+ CALL DGESD2D( ICTXT, ZROWS, DIM1,
+ $ WORK(IPW2), ZROWS, RSRC,
+ $ EAST )
+ CALL DGERV2D( ICTXT, ZROWS, DIM4,
+ $ WORK(IPW2+ZROWS*DIM1),
+ $ ZROWS, RSRC, EAST )
+ END IF
+ END IF
+ END IF
+ IF( MYCOL.EQ.CSRC4 ) THEN
+ CALL INFOG2L( 1+(INDX-1)*NB,
+ $ LKTOP+DIM1, DESCZ, NPROW, NPCOL,
+ $ MYROW, MYCOL, ILOC, JLOC4, RSRC,
+ $ CSRC4 )
+ IF( MYROW.EQ.RSRC ) THEN
+ CALL DLAMOV( 'All', ZROWS, DIM4,
+ $ Z((JLOC4-1)*LLDZ+ILOC), LLDZ,
+ $ WORK(IPW2+ZROWS*DIM1), ZROWS )
+ IF( NPCOL.GT.1 ) THEN
+ WEST = MOD( MYCOL - 1 + NPCOL,
+ $ NPCOL )
+ CALL DGESD2D( ICTXT, ZROWS, DIM4,
+ $ WORK(IPW2+ZROWS*DIM1),
+ $ ZROWS, RSRC, WEST )
+ CALL DGERV2D( ICTXT, ZROWS, DIM1,
+ $ WORK(IPW2), ZROWS, RSRC,
+ $ WEST )
+ END IF
+ END IF
+ END IF
+ 230 CONTINUE
+ END IF
+ END IF
+*
+* If no exchanges was performed for the current window,
+* all processors jump to this point and try the next
+* one.
+*
+ 205 CONTINUE
+*
+ 200 CONTINUE
+*
+* Compute crossborder bulge-chase updates.
+*
+ WINID = 0
+ IF( DIR.EQ.1 ) THEN
+ IPNEXT = 1
+ ELSE
+ IPNEXT = 1 + LENRBUF
+ END IF
+ IPW3 = 1
+ DO 240 WIN = ODDEVEN+(CHUNKNUM-1)*WCHUNK,
+ $ MIN(ANMWIN,MAX(1,ODDEVEN+(CHUNKNUM)*WCHUNK-1)), 2
+ IF( IWORK( 5+(WIN-1)*5 ).NE.1 ) GO TO 245
+*
+* Only perform this part of the code if there was really
+* some work performed on the WIN:th window.
+*
+ LKTOP = IWORK( 1+(WIN-1)*5 )
+ LKBOT = IWORK( 2+(WIN-1)*5 )
+ LNWIN = LKBOT - LKTOP + 1
+*
+* Extract the processor indices associated with
+* the current window.
+*
+ RSRC1 = IWORK( 3+(WIN-1)*5 )
+ CSRC1 = IWORK( 4+(WIN-1)*5 )
+ RSRC4 = MOD( RSRC1+1, NPROW )
+ CSRC4 = MOD( CSRC1+1, NPCOL )
+*
+ IF(((MYCOL.EQ.CSRC1.OR.MYCOL.EQ.CSRC4).AND.DIR.EQ.2)
+ $ .OR.((MYROW.EQ.RSRC1.OR.MYROW.EQ.RSRC4).AND.
+ $ DIR.EQ.1)) THEN
+*
+* Set up workspaces.
+*
+ WINID = WINID + 1
+ LKTOP = IWORK( 1+(WIN-1)*5 )
+ LKBOT = IWORK( 2+(WIN-1)*5 )
+ LNWIN = LKBOT - LKTOP + 1
+ DIM1 = NB - MOD(LKTOP-1,NB)
+ DIM4 = LNWIN - DIM1
+ IPU = IPNEXT + (WINID-1)*LNWIN*LNWIN
+ IF( DIR.EQ.2 ) THEN
+ IF( WANTZ ) THEN
+ ZROWS = NUMROC( N, NB, MYROW, DESCZ( RSRC_ ),
+ $ NPROW )
+ ELSE
+ ZROWS = 0
+ END IF
+ IF( WANTT ) THEN
+ HROWS = NUMROC( LKTOP-1, NB, MYROW,
+ $ DESCH( RSRC_ ), NPROW )
+ ELSE
+ HROWS = 0
+ END IF
+ ELSE
+ ZROWS = 0
+ HROWS = 0
+ END IF
+ IF( DIR.EQ.1 ) THEN
+ IF( WANTT ) THEN
+ HCOLS = NUMROC( N - (LKTOP+DIM1-1), NB,
+ $ MYCOL, CSRC4, NPCOL )
+ IF( MYCOL.EQ.CSRC4 ) HCOLS = HCOLS - DIM4
+ ELSE
+ HCOLS = 0
+ END IF
+ ELSE
+ HCOLS = 0
+ END IF
+*
+* IPW = local copy of overlapping column block of H
+* IPW1 = local copy of overlapping row block of H
+* IPW2 = local copy of overlapping column block of Z
+* IPW3 = workspace for right hand side of matrix
+* multiplication
+*
+ IPW = MAX( 1 + LENRBUF + LENCBUF, IPW3 )
+ IPW1 = IPW + HROWS * LNWIN
+ IF( WANTZ ) THEN
+ IPW2 = IPW1 + LNWIN * HCOLS
+ IPW3 = IPW2 + ZROWS * LNWIN
+ ELSE
+ IPW3 = IPW1 + LNWIN * HCOLS
+ END IF
+*
+* Recompute job to see if special structure of U
+* could possibly be exploited.
+*
+ IF( LKTOP.EQ.KTOP .AND. LKBOT.EQ.KBOT ) THEN
+ JOB = 'All steps'
+ ELSEIF( LKTOP.EQ.KTOP .AND.
+ $ ( DIM1.LT.LCHAIN+1 .OR. DIM1.LE.NTINY ) )
+ $ THEN
+ JOB = 'Introduce and chase'
+ ELSEIF( LKBOT.EQ.KBOT ) THEN
+ JOB = 'Off-chase bulges'
+ ELSE
+ JOB = 'Chase bulges'
+ END IF
+ END IF
+*
+* Test if to exploit sparsity structure of
+* orthogonal matrix U.
+*
+ KS = DIM1+DIM4-LNS/2*3
+ IF( .NOT. BLK22 .OR. DIM1.NE.KS .OR.
+ $ DIM4.NE.KS .OR. LSAME(JOB,'I') .OR.
+ $ LSAME(JOB,'O') .OR. LNS.LE.2 ) THEN
+*
+* Update the columns of H and Z.
+*
+ IF( DIR.EQ.2 .AND. WANTT .AND. LENCBUF.GT.0 ) THEN
+ DO 250 INDX = 1, MIN(LKTOP-1,1+(NPROW-1)*NB), NB
+ IF( MYCOL.EQ.CSRC1 ) THEN
+ CALL INFOG2L( INDX, LKTOP, DESCH, NPROW,
+ $ NPCOL, MYROW, MYCOL, ILOC, JLOC,
+ $ RSRC, CSRC1 )
+ IF( MYROW.EQ.RSRC ) THEN
+ CALL DGEMM( 'No transpose',
+ $ 'No transpose', HROWS, DIM1,
+ $ LNWIN, ONE, WORK( IPW ), HROWS,
+ $ WORK( IPU ), LNWIN, ZERO,
+ $ WORK(IPW3), HROWS )
+ CALL DLAMOV( 'All', HROWS, DIM1,
+ $ WORK(IPW3), HROWS,
+ $ H((JLOC-1)*LLDH+ILOC), LLDH )
+ END IF
+ END IF
+ IF( MYCOL.EQ.CSRC4 ) THEN
+ CALL INFOG2L( INDX, LKTOP+DIM1, DESCH,
+ $ NPROW, NPCOL, MYROW, MYCOL, ILOC,
+ $ JLOC, RSRC, CSRC4 )
+ IF( MYROW.EQ.RSRC ) THEN
+ CALL DGEMM( 'No transpose',
+ $ 'No transpose', HROWS, DIM4,
+ $ LNWIN, ONE, WORK( IPW ), HROWS,
+ $ WORK( IPU+LNWIN*DIM1 ), LNWIN,
+ $ ZERO, WORK(IPW3), HROWS )
+ CALL DLAMOV( 'All', HROWS, DIM4,
+ $ WORK(IPW3), HROWS,
+ $ H((JLOC-1)*LLDH+ILOC), LLDH )
+ END IF
+ END IF
+ 250 CONTINUE
+ END IF
+*
+ IF( DIR.EQ.2 .AND. WANTZ .AND. LENCBUF.GT.0 ) THEN
+ DO 260 INDX = 1, MIN(N,1+(NPROW-1)*NB), NB
+ IF( MYCOL.EQ.CSRC1 ) THEN
+ CALL INFOG2L( INDX, LKTOP, DESCZ, NPROW,
+ $ NPCOL, MYROW, MYCOL, ILOC, JLOC,
+ $ RSRC, CSRC1 )
+ IF( MYROW.EQ.RSRC ) THEN
+ CALL DGEMM( 'No transpose',
+ $ 'No transpose', ZROWS, DIM1,
+ $ LNWIN, ONE, WORK( IPW2 ),
+ $ ZROWS, WORK( IPU ), LNWIN,
+ $ ZERO, WORK(IPW3), ZROWS )
+ CALL DLAMOV( 'All', ZROWS, DIM1,
+ $ WORK(IPW3), ZROWS,
+ $ Z((JLOC-1)*LLDZ+ILOC), LLDZ )
+ END IF
+ END IF
+ IF( MYCOL.EQ.CSRC4 ) THEN
+ CALL INFOG2L( INDX, LKTOP+DIM1, DESCZ,
+ $ NPROW, NPCOL, MYROW, MYCOL, ILOC,
+ $ JLOC, RSRC, CSRC4 )
+ IF( MYROW.EQ.RSRC ) THEN
+ CALL DGEMM( 'No transpose',
+ $ 'No transpose', ZROWS, DIM4,
+ $ LNWIN, ONE, WORK( IPW2 ),
+ $ ZROWS,
+ $ WORK( IPU+LNWIN*DIM1 ), LNWIN,
+ $ ZERO, WORK(IPW3), ZROWS )
+ CALL DLAMOV( 'All', ZROWS, DIM4,
+ $ WORK(IPW3), ZROWS,
+ $ Z((JLOC-1)*LLDZ+ILOC), LLDZ )
+ END IF
+ END IF
+ 260 CONTINUE
+ END IF
+*
+* Update the rows of H.
+*
+ IF( DIR.EQ.1 .AND. WANTT .AND. LENRBUF.GT.0 ) THEN
+ IF( LKBOT.LT.N ) THEN
+ IF( MYROW.EQ.RSRC1.AND.MYCOL.EQ.CSRC4 .AND.
+ $ MOD(LKBOT,NB).NE.0 ) THEN
+ INDX = LKBOT + 1
+ CALL INFOG2L( LKTOP, INDX, DESCH, NPROW,
+ $ NPCOL, MYROW, MYCOL, ILOC, JLOC,
+ $ RSRC1, CSRC4 )
+ CALL DGEMM( 'Transpose', 'No Transpose',
+ $ DIM1, HCOLS, LNWIN, ONE, WORK(IPU),
+ $ LNWIN, WORK( IPW1 ), LNWIN, ZERO,
+ $ WORK(IPW3), DIM1 )
+ CALL DLAMOV( 'All', DIM1, HCOLS,
+ $ WORK(IPW3), DIM1,
+ $ H((JLOC-1)*LLDH+ILOC), LLDH )
+ END IF
+ IF( MYROW.EQ.RSRC4.AND.MYCOL.EQ.CSRC4 .AND.
+ $ MOD(LKBOT,NB).NE.0 ) THEN
+ INDX = LKBOT + 1
+ CALL INFOG2L( LKTOP+DIM1, INDX, DESCH,
+ $ NPROW, NPCOL, MYROW, MYCOL, ILOC,
+ $ JLOC, RSRC4, CSRC4 )
+ CALL DGEMM( 'Transpose', 'No Transpose',
+ $ DIM4, HCOLS, LNWIN, ONE,
+ $ WORK( IPU+DIM1*LNWIN ), LNWIN,
+ $ WORK( IPW1), LNWIN, ZERO,
+ $ WORK(IPW3), DIM4 )
+ CALL DLAMOV( 'All', DIM4, HCOLS,
+ $ WORK(IPW3), DIM4,
+ $ H((JLOC-1)*LLDH+ILOC), LLDH )
+ END IF
+ INDXS = ICEIL(LKBOT,NB)*NB + 1
+ IF( MOD(LKBOT,NB).NE.0 ) THEN
+ INDXE = MIN(N,INDXS+(NPCOL-2)*NB)
+ ELSE
+ INDXE = MIN(N,INDXS+(NPCOL-1)*NB)
+ END IF
+ DO 270 INDX = INDXS, INDXE, NB
+ IF( MYROW.EQ.RSRC1 ) THEN
+ CALL INFOG2L( LKTOP, INDX, DESCH,
+ $ NPROW, NPCOL, MYROW, MYCOL, ILOC,
+ $ JLOC, RSRC1, CSRC )
+ IF( MYCOL.EQ.CSRC ) THEN
+ CALL DGEMM( 'Transpose',
+ $ 'No Transpose', DIM1, HCOLS,
+ $ LNWIN, ONE, WORK( IPU ), LNWIN,
+ $ WORK( IPW1 ), LNWIN, ZERO,
+ $ WORK(IPW3), DIM1 )
+ CALL DLAMOV( 'All', DIM1, HCOLS,
+ $ WORK(IPW3), DIM1,
+ $ H((JLOC-1)*LLDH+ILOC), LLDH )
+ END IF
+ END IF
+ IF( MYROW.EQ.RSRC4 ) THEN
+ CALL INFOG2L( LKTOP+DIM1, INDX, DESCH,
+ $ NPROW, NPCOL, MYROW, MYCOL, ILOC,
+ $ JLOC, RSRC4, CSRC )
+ IF( MYCOL.EQ.CSRC ) THEN
+ CALL DGEMM( 'Transpose',
+ $ 'No Transpose', DIM4, HCOLS,
+ $ LNWIN, ONE,
+ $ WORK( IPU+LNWIN*DIM1 ), LNWIN,
+ $ WORK( IPW1 ), LNWIN,
+ $ ZERO, WORK(IPW3), DIM4 )
+ CALL DLAMOV( 'All', DIM4, HCOLS,
+ $ WORK(IPW3), DIM4,
+ $ H((JLOC-1)*LLDH+ILOC), LLDH )
+ END IF
+ END IF
+ 270 CONTINUE
+ END IF
+ END IF
+ ELSE
+*
+* Update the columns of H and Z.
+*
+* Compute H2*U21 + H1*U11 on the left side of the border.
+*
+ IF( DIR.EQ.2 .AND. WANTT .AND. LENCBUF.GT.0 ) THEN
+ INDXE = MIN(LKTOP-1,1+(NPROW-1)*NB)
+ DO 280 INDX = 1, INDXE, NB
+ IF( MYCOL.EQ.CSRC1 ) THEN
+ CALL INFOG2L( INDX, LKTOP, DESCH, NPROW,
+ $ NPCOL, MYROW, MYCOL, ILOC, JLOC,
+ $ RSRC, CSRC1 )
+ IF( MYROW.EQ.RSRC ) THEN
+ CALL DLAMOV( 'All', HROWS, KS,
+ $ WORK( IPW+HROWS*DIM4), HROWS,
+ $ WORK(IPW3), HROWS )
+ CALL DTRMM( 'Right', 'Upper',
+ $ 'No transpose',
+ $ 'Non-unit', HROWS, KS, ONE,
+ $ WORK( IPU+DIM4 ), LNWIN,
+ $ WORK(IPW3), HROWS )
+ CALL DGEMM( 'No transpose',
+ $ 'No transpose', HROWS, KS, DIM4,
+ $ ONE, WORK( IPW ), HROWS,
+ $ WORK( IPU ), LNWIN, ONE,
+ $ WORK(IPW3), HROWS )
+ CALL DLAMOV( 'All', HROWS, KS,
+ $ WORK(IPW3), HROWS,
+ $ H((JLOC-1)*LLDH+ILOC), LLDH )
+ END IF
+ END IF
+*
+* Compute H1*U12 + H2*U22 on the right side of
+* the border.
+*
+ IF( MYCOL.EQ.CSRC4 ) THEN
+ CALL INFOG2L( INDX, LKTOP+DIM1, DESCH,
+ $ NPROW, NPCOL, MYROW, MYCOL, ILOC,
+ $ JLOC, RSRC, CSRC4 )
+ IF( MYROW.EQ.RSRC ) THEN
+ CALL DLAMOV( 'All', HROWS, DIM4,
+ $ WORK(IPW), HROWS, WORK( IPW3 ),
+ $ HROWS )
+ CALL DTRMM( 'Right', 'Lower',
+ $ 'No transpose',
+ $ 'Non-unit', HROWS, DIM4, ONE,
+ $ WORK( IPU+LNWIN*KS ), LNWIN,
+ $ WORK( IPW3 ), HROWS )
+ CALL DGEMM( 'No transpose',
+ $ 'No transpose', HROWS, DIM4, KS,
+ $ ONE, WORK( IPW+HROWS*DIM4),
+ $ HROWS,
+ $ WORK( IPU+LNWIN*KS+DIM4 ), LNWIN,
+ $ ONE, WORK( IPW3 ), HROWS )
+ CALL DLAMOV( 'All', HROWS, DIM4,
+ $ WORK(IPW3), HROWS,
+ $ H((JLOC-1)*LLDH+ILOC), LLDH )
+ END IF
+ END IF
+ 280 CONTINUE
+ END IF
+*
+ IF( DIR.EQ.2 .AND. WANTZ .AND. LENCBUF.GT.0 ) THEN
+*
+* Compute Z2*U21 + Z1*U11 on the left side
+* of border.
+*
+ INDXE = MIN(N,1+(NPROW-1)*NB)
+ DO 290 INDX = 1, INDXE, NB
+ IF( MYCOL.EQ.CSRC1 ) THEN
+ CALL INFOG2L( INDX, I, DESCZ, NPROW,
+ $ NPCOL, MYROW, MYCOL, ILOC, JLOC,
+ $ RSRC, CSRC1 )
+ IF( MYROW.EQ.RSRC ) THEN
+ CALL DLAMOV( 'All', ZROWS, KS,
+ $ WORK( IPW2+ZROWS*DIM4),
+ $ ZROWS, WORK(IPW3), ZROWS )
+ CALL DTRMM( 'Right', 'Upper',
+ $ 'No transpose',
+ $ 'Non-unit', ZROWS, KS, ONE,
+ $ WORK( IPU+DIM4 ), LNWIN,
+ $ WORK(IPW3), ZROWS )
+ CALL DGEMM( 'No transpose',
+ $ 'No transpose', ZROWS, KS,
+ $ DIM4, ONE, WORK( IPW2 ),
+ $ ZROWS, WORK( IPU ), LNWIN,
+ $ ONE, WORK(IPW3), ZROWS )
+ CALL DLAMOV( 'All', ZROWS, KS,
+ $ WORK(IPW3), ZROWS,
+ $ Z((JLOC-1)*LLDZ+ILOC), LLDZ )
+ END IF
+ END IF
+*
+* Compute Z1*U12 + Z2*U22 on the right side
+* of border.
+*
+ IF( MYCOL.EQ.CSRC4 ) THEN
+ CALL INFOG2L( INDX, I+DIM1, DESCZ,
+ $ NPROW, NPCOL, MYROW, MYCOL, ILOC,
+ $ JLOC, RSRC, CSRC4 )
+ IF( MYROW.EQ.RSRC ) THEN
+ CALL DLAMOV( 'All', ZROWS, DIM4,
+ $ WORK(IPW2), ZROWS,
+ $ WORK( IPW3 ), ZROWS )
+ CALL DTRMM( 'Right', 'Lower',
+ $ 'No transpose',
+ $ 'Non-unit', ZROWS, DIM4,
+ $ ONE, WORK( IPU+LNWIN*KS ),
+ $ LNWIN, WORK( IPW3 ), ZROWS )
+ CALL DGEMM( 'No transpose',
+ $ 'No transpose', ZROWS, DIM4,
+ $ KS, ONE,
+ $ WORK( IPW2+ZROWS*(DIM4)),
+ $ ZROWS,
+ $ WORK( IPU+LNWIN*KS+DIM4 ),
+ $ LNWIN, ONE, WORK( IPW3 ),
+ $ ZROWS )
+ CALL DLAMOV( 'All', ZROWS, DIM4,
+ $ WORK(IPW3), ZROWS,
+ $ Z((JLOC-1)*LLDZ+ILOC), LLDZ )
+ END IF
+ END IF
+ 290 CONTINUE
+ END IF
+*
+ IF( DIR.EQ.1 .AND. WANTT .AND. LENRBUF.GT.0) THEN
+ IF ( LKBOT.LT.N ) THEN
+*
+* Compute U21**T*H2 + U11**T*H1 on the upper
+* side of the border.
+*
+ IF( MYROW.EQ.RSRC1.AND.MYCOL.EQ.CSRC4.AND.
+ $ MOD(LKBOT,NB).NE.0 ) THEN
+ INDX = LKBOT + 1
+ CALL INFOG2L( LKTOP, INDX, DESCH, NPROW,
+ $ NPCOL, MYROW, MYCOL, ILOC, JLOC,
+ $ RSRC1, CSRC4 )
+ CALL DLAMOV( 'All', KS, HCOLS,
+ $ WORK( IPW1+DIM4 ), LNWIN,
+ $ WORK(IPW3), KS )
+ CALL DTRMM( 'Left', 'Upper', 'Transpose',
+ $ 'Non-unit', KS, HCOLS, ONE,
+ $ WORK( IPU+DIM4 ), LNWIN,
+ $ WORK(IPW3), KS )
+ CALL DGEMM( 'Transpose', 'No transpose',
+ $ KS, HCOLS, DIM4, ONE, WORK(IPU),
+ $ LNWIN, WORK(IPW1), LNWIN,
+ $ ONE, WORK(IPW3), KS )
+ CALL DLAMOV( 'All', KS, HCOLS,
+ $ WORK(IPW3), KS,
+ $ H((JLOC-1)*LLDH+ILOC), LLDH )
+ END IF
+*
+* Compute U12**T*H1 + U22**T*H2 one the lower
+* side of the border.
+*
+ IF( MYROW.EQ.RSRC4.AND.MYCOL.EQ.CSRC4.AND.
+ $ MOD(LKBOT,NB).NE.0 ) THEN
+ INDX = LKBOT + 1
+ CALL INFOG2L( LKTOP+DIM1, INDX, DESCH,
+ $ NPROW, NPCOL, MYROW, MYCOL, ILOC,
+ $ JLOC, RSRC4, CSRC4 )
+ CALL DLAMOV( 'All', DIM4, HCOLS,
+ $ WORK( IPW1 ), LNWIN,
+ $ WORK( IPW3 ), DIM4 )
+ CALL DTRMM( 'Left', 'Lower', 'Transpose',
+ $ 'Non-unit', DIM4, HCOLS, ONE,
+ $ WORK( IPU+LNWIN*KS ), LNWIN,
+ $ WORK( IPW3 ), DIM4 )
+ CALL DGEMM( 'Transpose', 'No Transpose',
+ $ DIM4, HCOLS, KS, ONE,
+ $ WORK( IPU+LNWIN*KS+DIM4 ), LNWIN,
+ $ WORK( IPW1+DIM1 ), LNWIN,
+ $ ONE, WORK( IPW3), DIM4 )
+ CALL DLAMOV( 'All', DIM4, HCOLS,
+ $ WORK(IPW3), DIM4,
+ $ H((JLOC-1)*LLDH+ILOC), LLDH )
+ END IF
+*
+* Compute U21**T*H2 + U11**T*H1 on upper side
+* on border.
+*
+ INDXS = ICEIL(LKBOT,NB)*NB+1
+ IF( MOD(LKBOT,NB).NE.0 ) THEN
+ INDXE = MIN(N,INDXS+(NPCOL-2)*NB)
+ ELSE
+ INDXE = MIN(N,INDXS+(NPCOL-1)*NB)
+ END IF
+ DO 300 INDX = INDXS, INDXE, NB
+ IF( MYROW.EQ.RSRC1 ) THEN
+ CALL INFOG2L( LKTOP, INDX, DESCH,
+ $ NPROW, NPCOL, MYROW, MYCOL, ILOC,
+ $ JLOC, RSRC1, CSRC )
+ IF( MYCOL.EQ.CSRC ) THEN
+ CALL DLAMOV( 'All', KS, HCOLS,
+ $ WORK( IPW1+DIM4 ), LNWIN,
+ $ WORK(IPW3), KS )
+ CALL DTRMM( 'Left', 'Upper',
+ $ 'Transpose', 'Non-unit',
+ $ KS, HCOLS, ONE,
+ $ WORK( IPU+DIM4 ), LNWIN,
+ $ WORK(IPW3), KS )
+ CALL DGEMM( 'Transpose',
+ $ 'No transpose', KS, HCOLS,
+ $ DIM4, ONE, WORK(IPU), LNWIN,
+ $ WORK(IPW1), LNWIN, ONE,
+ $ WORK(IPW3), KS )
+ CALL DLAMOV( 'All', KS, HCOLS,
+ $ WORK(IPW3), KS,
+ $ H((JLOC-1)*LLDH+ILOC), LLDH )
+ END IF
+ END IF
+*
+* Compute U12**T*H1 + U22**T*H2 on lower
+* side of border.
+*
+ IF( MYROW.EQ.RSRC4 ) THEN
+ CALL INFOG2L( LKTOP+DIM1, INDX, DESCH,
+ $ NPROW, NPCOL, MYROW, MYCOL, ILOC,
+ $ JLOC, RSRC4, CSRC )
+ IF( MYCOL.EQ.CSRC ) THEN
+ CALL DLAMOV( 'All', DIM4, HCOLS,
+ $ WORK( IPW1 ), LNWIN,
+ $ WORK( IPW3 ), DIM4 )
+ CALL DTRMM( 'Left', 'Lower',
+ $ 'Transpose','Non-unit',
+ $ DIM4, HCOLS, ONE,
+ $ WORK( IPU+LNWIN*KS ), LNWIN,
+ $ WORK( IPW3 ), DIM4 )
+ CALL DGEMM( 'Transpose',
+ $ 'No Transpose', DIM4, HCOLS,
+ $ KS, ONE,
+ $ WORK( IPU+LNWIN*KS+DIM4 ),
+ $ LNWIN, WORK( IPW1+DIM1 ),
+ $ LNWIN, ONE, WORK( IPW3),
+ $ DIM4 )
+ CALL DLAMOV( 'All', DIM4, HCOLS,
+ $ WORK(IPW3), DIM4,
+ $ H((JLOC-1)*LLDH+ILOC), LLDH )
+ END IF
+ END IF
+ 300 CONTINUE
+ END IF
+ END IF
+ END IF
+*
+* Update window information - mark processed windows are
+* completed.
+*
+ IF( DIR.EQ.2 ) THEN
+ IF( LKBOT.EQ.KBOT ) THEN
+ LKTOP = KBOT+1
+ LKBOT = KBOT+1
+ IWORK( 1+(WIN-1)*5 ) = LKTOP
+ IWORK( 2+(WIN-1)*5 ) = LKBOT
+ ELSE
+ LKTOP = MIN( LKTOP + LNWIN - LCHAIN,
+ $ MIN( KBOT, ICEIL( LKBOT, NB )*NB ) -
+ $ LCHAIN + 1 )
+ IWORK( 1+(WIN-1)*5 ) = LKTOP
+ LKBOT = MIN( MAX( LKBOT + LNWIN - LCHAIN,
+ $ LKTOP + NWIN - 1), MIN( KBOT,
+ $ ICEIL( LKBOT, NB )*NB ) )
+ IWORK( 2+(WIN-1)*5 ) = LKBOT
+ END IF
+ IF( IWORK( 5+(WIN-1)*5 ).EQ.1 )
+ $ IWORK( 5+(WIN-1)*5 ) = 2
+ IWORK( 3+(WIN-1)*5 ) = RSRC4
+ IWORK( 4+(WIN-1)*5 ) = CSRC4
+ END IF
+*
+* If nothing was done for the WIN:th window, all
+* processors come here and consider the next one
+* instead.
+*
+ 245 CONTINUE
+ 240 CONTINUE
+ 190 CONTINUE
+ 150 CONTINUE
+ 140 CONTINUE
+*
+* Chased off bulges from first window?
+*
+ IF( NPROCS.GT.1 )
+ $ CALL IGAMX2D( ICTXT, 'All', '1-Tree', 1, 1, ICHOFF, 1,
+ $ -1, -1, -1, -1, -1 )
+*
+* If the bulge was chasen off from first window it is removed.
+*
+ IF( ICHOFF.GT.0 ) THEN
+ DO 198 WIN = 2, ANMWIN
+ IWORK( 1+(WIN-2)*5 ) = IWORK( 1+(WIN-1)*5 )
+ IWORK( 2+(WIN-2)*5 ) = IWORK( 2+(WIN-1)*5 )
+ IWORK( 3+(WIN-2)*5 ) = IWORK( 3+(WIN-1)*5 )
+ IWORK( 4+(WIN-2)*5 ) = IWORK( 4+(WIN-1)*5 )
+ 198 CONTINUE
+ ANMWIN = ANMWIN - 1
+ IPIW = 6+(ANMWIN-1)*5
+ END IF
+*
+* If we have no more windows, return.
+*
+ IF( ANMWIN.LT.1 ) RETURN
+*
+* Check for any more windows to bring over the border.
+*
+ WINFIN = 0
+ DO 199 WIN = 1, ANMWIN
+ WINFIN = WINFIN+IWORK( 5+(WIN-1)*5 )
+ 199 CONTINUE
+ IF( WINFIN.LT.2*ANMWIN ) GO TO 137
+*
+* Zero out process mark for each window - this is legal now when
+* the process starts over with local bulge-chasing etc.
+*
+ DO 201 WIN = 1, ANMWIN
+ IWORK( 5+(WIN-1)*5 ) = 0
+ 201 CONTINUE
+*
+ END IF
+*
+* Go back to local bulge-chase and see if there is more work to do.
+*
+ GO TO 20
+*
+* End of PDLAQR5
+*
+ END
diff --git a/SRC/pdlarfb.f b/SRC/pdlarfb.f
index e2828ff..2c3b426 100644
--- a/SRC/pdlarfb.f
+++ b/SRC/pdlarfb.f
@@ -1,10 +1,9 @@
SUBROUTINE PDLARFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, V, IV,
$ JV, DESCV, T, C, IC, JC, DESCC, WORK )
*
-* -- ScaLAPACK auxiliary routine (version 1.7) --
-* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
-* and University of California, Berkeley.
-* May 1, 1997
+* -- ScaLAPACK auxiliary routine (version 2.0.2) --
+* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver
+* May 1 2012
*
* .. Scalar Arguments ..
CHARACTER SIDE, TRANS, DIRECT, STOREV
@@ -236,7 +235,7 @@
* ..
* .. External Subroutines ..
EXTERNAL BLACS_GRIDINFO, DGEBR2D, DGEBS2D,DGEMM,
- $ DGSUM2D, DLACPY, DLASET, DTRBR2D,
+ $ DGSUM2D, DLAMOV, DLASET, DTRBR2D,
$ DTRBS2D, DTRMM, INFOG1L, INFOG2L, PB_TOPGET,
$ PBDTRAN
* ..
@@ -324,7 +323,7 @@
IF( MYROW.EQ.IVROW )
$ CALL DTRBS2D( ICTXT, 'Rowwise', ROWBTOP, UPLO,
$ 'Non unit', K, K, T, NBV )
- CALL DLACPY( 'All', MPC, K, V( IOFFV ), LDV, WORK( IPV ),
+ CALL DLAMOV( 'All', MPC, K, V( IOFFV ), LDV, WORK( IPV ),
$ LV )
ELSE
CALL DGEBR2D( ICTXT, 'Rowwise', ROWBTOP, MPC, K,
@@ -461,11 +460,11 @@
CALL DLASET( 'All', IROFFV, K, ZERO, ZERO,
$ WORK( IPW ), LW )
IPW1 = IPW + IROFFV
- CALL DLACPY( 'All', NPV, K, V( IOFFV ), LDV,
+ CALL DLAMOV( 'All', NPV, K, V( IOFFV ), LDV,
$ WORK( IPW1 ), LW )
ELSE
IPW1 = IPW
- CALL DLACPY( 'All', NPV, K, V( IOFFV ), LDV,
+ CALL DLAMOV( 'All', NPV, K, V( IOFFV ), LDV,
$ WORK( IPW1 ), LW )
END IF
*
@@ -624,11 +623,11 @@
CALL DLASET( 'All', K, ICOFFV, ZERO, ZERO,
$ WORK( IPW ), LW )
IPW1 = IPW + ICOFFV * LW
- CALL DLACPY( 'All', K, MQV, V( IOFFV ), LDV,
+ CALL DLAMOV( 'All', K, MQV, V( IOFFV ), LDV,
$ WORK( IPW1 ), LW )
ELSE
IPW1 = IPW
- CALL DLACPY( 'All', K, MQV, V( IOFFV ), LDV,
+ CALL DLAMOV( 'All', K, MQV, V( IOFFV ), LDV,
$ WORK( IPW1 ), LW )
END IF
*
@@ -772,7 +771,7 @@
IF( MYCOL.EQ.IVCOL )
$ CALL DTRBS2D( ICTXT, 'Columnwise', COLBTOP, UPLO,
$ 'Non unit', K, K, T, MBV )
- CALL DLACPY( 'All', K, NQC, V( IOFFV ), LDV, WORK( IPV ),
+ CALL DLAMOV( 'All', K, NQC, V( IOFFV ), LDV, WORK( IPV ),
$ LV )
ELSE
CALL DGEBR2D( ICTXT, 'Columnwise', COLBTOP, K, NQC,
diff --git a/SRC/pdlarzb.f b/SRC/pdlarzb.f
index ef55f97..096fba5 100644
--- a/SRC/pdlarzb.f
+++ b/SRC/pdlarzb.f
@@ -1,10 +1,9 @@
SUBROUTINE PDLARZB( SIDE, TRANS, DIRECT, STOREV, M, N, K, L, V,
$ IV, JV, DESCV, T, C, IC, JC, DESCC, WORK )
*
-* -- ScaLAPACK auxiliary routine (version 1.7) --
-* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
-* and University of California, Berkeley.
-* March 14, 2000
+* -- ScaLAPACK auxiliary routine (version 2.0.2) --
+* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver
+* May 1 2012
*
* .. Scalar Arguments ..
CHARACTER DIRECT, SIDE, STOREV, TRANS
@@ -241,7 +240,7 @@
* ..
* .. External Subroutines ..
EXTERNAL BLACS_ABORT, BLACS_GRIDINFO, DGEBR2D,
- $ DGEBS2D,DGEMM, DGSUM2D, DLACPY,
+ $ DGEBS2D,DGEMM, DGSUM2D, DLAMOV,
$ DLASET, DTRBR2D, DTRBS2D, DTRMM,
$ INFOG2L, PBDMATADD, PBDTRAN, PB_TOPGET, PXERBLA
* ..
@@ -379,10 +378,10 @@
*
IF( MYROW.EQ.IVROW ) THEN
IF( MYCOL.EQ.IVCOL ) THEN
- CALL DLACPY( 'All', K, MQV, V( IOFFV ), LDV,
+ CALL DLAMOV( 'All', K, MQV, V( IOFFV ), LDV,
$ WORK( IPW+ICOFFV*LW ), LW )
ELSE
- CALL DLACPY( 'All', K, MQV, V( IOFFV ), LDV,
+ CALL DLAMOV( 'All', K, MQV, V( IOFFV ), LDV,
$ WORK( IPW ), LW )
END IF
END IF
@@ -512,7 +511,7 @@
IF( MYCOL.EQ.IVCOL )
$ CALL DTRBS2D( ICTXT, 'Columnwise', COLBTOP, 'Lower',
$ 'Non unit', K, K, T, MBV )
- CALL DLACPY( 'All', K, NQC2, V( IOFFV ), LDV, WORK( IPV ),
+ CALL DLAMOV( 'All', K, NQC2, V( IOFFV ), LDV, WORK( IPV ),
$ LV )
ELSE
CALL DGEBR2D( ICTXT, 'Columnwise', COLBTOP, K, NQC2,
diff --git a/SRC/pdlascl.f b/SRC/pdlascl.f
index fe4aa00..3925ed4 100644
--- a/SRC/pdlascl.f
+++ b/SRC/pdlascl.f
@@ -153,10 +153,10 @@
EXTERNAL BLACS_GRIDINFO, CHK1MAT, INFOG2L, PXERBLA
* ..
* .. External Functions ..
- LOGICAL LSAME
+ LOGICAL LSAME, DISNAN
INTEGER ICEIL, NUMROC
DOUBLE PRECISION PDLAMCH
- EXTERNAL ICEIL, LSAME, NUMROC, PDLAMCH
+ EXTERNAL DISNAN, ICEIL, LSAME, NUMROC, PDLAMCH
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MIN, MOD
@@ -189,8 +189,10 @@
END IF
IF( ITYPE.EQ.-1 ) THEN
INFO = -1
- ELSE IF( CFROM.EQ.ZERO ) THEN
+ ELSE IF( CFROM.EQ.ZERO .OR. DISNAN(CFROM) ) THEN
INFO = -4
+ ELSE IF( DISNAN(CTO) ) THEN
+ INFO = -5
END IF
END IF
END IF
@@ -230,18 +232,32 @@
*
10 CONTINUE
CFROM1 = CFROMC*SMLNUM
- CTO1 = CTOC / BIGNUM
- IF( ABS( CFROM1 ).GT.ABS( CTOC ) .AND. CTOC.NE.ZERO ) THEN
- MUL = SMLNUM
- DONE = .FALSE.
- CFROMC = CFROM1
- ELSE IF( ABS( CTO1 ).GT.ABS( CFROMC ) ) THEN
- MUL = BIGNUM
- DONE = .FALSE.
- CTOC = CTO1
- ELSE
+ 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
*
IOFFA = ( JJA - 1 ) * LDA
diff --git a/SRC/pdlasmsub.f b/SRC/pdlasmsub.f
index 0805af6..1feda04 100644
--- a/SRC/pdlasmsub.f
+++ b/SRC/pdlasmsub.f
@@ -146,11 +146,11 @@
PARAMETER ( ZERO = 0.0D+0 )
* ..
* .. Local Scalars ..
- INTEGER CONTXT, DOWN, HBL, IBUF1, IBUF2, ICOL1, ICOL2,
- $ II, III, IRCV1, IRCV2, IROW1, IROW2, ISRC,
- $ ISTR1, ISTR2, ITMP1, ITMP2, JJ, JJJ, JSRC, LDA,
- $ LEFT, MODKM1, MYCOL, MYROW, NPCOL, NPROW, NUM,
- $ RIGHT, UP
+ INTEGER CONTXT, DOWN, HBL, IAFIRST, IBUF1, IBUF2,
+ $ ICOL1, ICOL2, II, III, IRCV1, IRCV2, IROW1,
+ $ IROW2, ISRC, ISTR1, ISTR2, ITMP1, ITMP2,
+ $ JAFIRST, JJ, JJJ, JSRC, LDA, LEFT, MODKM1,
+ $ MYCOL, MYROW, NPCOL, NPROW, NUM, RIGHT, UP
DOUBLE PRECISION H10, H11, H22, TST1, ULP
* ..
* .. External Functions ..
@@ -170,6 +170,8 @@
HBL = DESCA( MB_ )
CONTXT = DESCA( CTXT_ )
LDA = DESCA( LLD_ )
+ IAFIRST = DESCA( RSRC_ )
+ JAFIRST = DESCA( CSRC_ )
ULP = PDLAMCH( CONTXT, 'PRECISION' )
CALL BLACS_GRIDINFO( CONTXT, NPROW, NPCOL, MYROW, MYCOL )
LEFT = MOD( MYCOL+NPCOL-1, NPCOL )
@@ -333,10 +335,10 @@
*
* FIND SOME NORM OF THE LOCAL H(L:I,L:I)
*
- CALL INFOG1L( L, HBL, NPROW, MYROW, 0, ITMP1, III )
- IROW2 = NUMROC( I, HBL, MYROW, 0, NPROW )
- CALL INFOG1L( L, HBL, NPCOL, MYCOL, 0, ITMP2, III )
- ICOL2 = NUMROC( I, HBL, MYCOL, 0, NPCOL )
+ CALL INFOG1L( L, HBL, NPROW, MYROW, IAFIRST, ITMP1, III )
+ IROW2 = NUMROC( I, HBL, MYROW, IAFIRST, NPROW )
+ CALL INFOG1L( L, HBL, NPCOL, MYCOL, JAFIRST, ITMP2, III )
+ ICOL2 = NUMROC( I, HBL, MYCOL, JAFIRST, NPCOL )
DO 30 III = ITMP1, IROW2
DO 20 JJJ = ITMP2, ICOL2
TST1 = TST1 + ABS( A( ( JJJ-1 )*LDA+III ) )
diff --git a/SRC/pdlasrt.f b/SRC/pdlasrt.f
index f678850..ebe618a 100644
--- a/SRC/pdlasrt.f
+++ b/SRC/pdlasrt.f
@@ -1,10 +1,9 @@
SUBROUTINE PDLASRT( ID, N, D, Q, IQ, JQ, DESCQ, WORK, LWORK,
$ IWORK, LIWORK, INFO )
*
-* -- ScaLAPACK auxiliary routine (version 1.7) --
-* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
-* and University of California, Berkeley.
-* February 22, 2000
+* -- ScaLAPACK auxiliary routine (version 2.0.2) --
+* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver
+* May 1 2012
*
* .. Scalar Arguments ..
CHARACTER ID
@@ -97,7 +96,7 @@
* ..
* .. External Subroutines ..
EXTERNAL BLACS_GRIDINFO, CHK1MAT, PXERBLA, DCOPY,
- $ DGERV2D, DGESD2D, DLACPY, DLAPST
+ $ DGERV2D, DGESD2D, DLAMOV, DLAPST
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN, MOD
@@ -247,7 +246,7 @@
ND = ND + NB
GO TO 20
END IF
- CALL DLACPY( 'Full', NP, NQ, WORK, NP, Q( IIQ ), LDQ )
+ CALL DLAMOV( 'Full', NP, NQ, WORK, NP, Q( IIQ ), LDQ )
*
* End of PDLASRT
*
diff --git a/SRC/pdormrq.f b/SRC/pdormrq.f
index adcd4c1..1ea3695 100644
--- a/SRC/pdormrq.f
+++ b/SRC/pdormrq.f
@@ -223,7 +223,7 @@
$ RSRC_ = 7, CSRC_ = 8, LLD_ = 9 )
* ..
* .. Local Scalars ..
- LOGICAL LEFT, LQUERY, NOTRAN
+ LOGICAL LEFT, LQUERY, NOTRAN, RIGHT, TRAN
CHARACTER COLBTOP, ROWBTOP, TRANST
INTEGER I, I1, I2, I3, IACOL, IB, ICCOL, ICOFFA,
$ ICOFFC, ICROW, ICTXT, IINFO, IPW, IROFFC, LCM,
@@ -258,8 +258,20 @@
IF( NPROW.EQ.-1 ) THEN
INFO = -(900+CTXT_)
ELSE
- LEFT = LSAME( SIDE, 'L' )
- NOTRAN = LSAME( TRANS, 'N' )
+ IF( LSAME( SIDE, 'L' ) ) THEN
+ LEFT = .TRUE.
+ RIGHT = .FALSE.
+ ELSE
+ LEFT = .FALSE.
+ RIGHT = .TRUE.
+ END IF
+ IF( LSAME( TRANS, 'N' ) ) THEN
+ NOTRAN = .TRUE.
+ TRAN = .FALSE.
+ ELSE
+ NOTRAN = .FALSE.
+ TRAN = .TRUE.
+ END IF
*
* NQ is the order of Q
*
@@ -439,8 +451,8 @@
$ WORK( IPW ) )
10 CONTINUE
*
- IF( ( LEFT .AND. .NOT.NOTRAN ) .OR.
- $ ( .NOT.LEFT .AND. NOTRAN ) ) THEN
+ IF( ( RIGHT .AND. TRAN ) .OR.
+ $ ( LEFT .AND. NOTRAN ) ) THEN
IB = I2 - IA
IF( LEFT ) THEN
MI = M - K + IB
diff --git a/SRC/pdpbtrf.f b/SRC/pdpbtrf.f
index 3d23372..6367cac 100644
--- a/SRC/pdpbtrf.f
+++ b/SRC/pdpbtrf.f
@@ -1,10 +1,9 @@
SUBROUTINE PDPBTRF( UPLO, N, BW, A, JA, DESCA, AF, LAF, WORK,
$ LWORK, INFO )
*
-* -- ScaLAPACK routine (version 1.7) --
-* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
-* and University of California, Berkeley.
-* April 3, 2000
+* -- ScaLAPACK routine (version 2.0.2) --
+* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver
+* May 1 2012
*
* .. Scalar Arguments ..
CHARACTER UPLO
@@ -376,7 +375,7 @@
* ..
* .. External Subroutines ..
EXTERNAL BLACS_GRIDEXIT, BLACS_GRIDINFO, DAXPY,
- $ DESC_CONVERT, DGEMM, DGERV2D, DGESD2D, DLACPY,
+ $ DESC_CONVERT, DGEMM, DGERV2D, DGESD2D, DLAMOV,
$ DLATCPY, DPBTRF, DPOTRF, DSYRK, DTBTRS, DTRMM,
$ DTRRV2D, DTRSD2D, DTRSM, DTRTRS, GLOBCHK,
$ IGAMX2D, IGEBR2D, IGEBS2D, PXERBLA, RESHAPE
@@ -863,7 +862,7 @@
* Copy last diagonal block into AF storage for subsequent
* operations.
*
- CALL DLACPY( 'N', BW, BW, A( OFST+ODD_SIZE*LLDA+1 ), LLDA-1,
+ CALL DLAMOV( 'N', BW, BW, A( OFST+ODD_SIZE*LLDA+1 ), LLDA-1,
$ AF( ODD_SIZE*BW+MBW2+1 ), BW )
*
* Receive cont. to diagonal block that is stored on this proc.
@@ -945,7 +944,7 @@
* Move block into place that it will be expected to be for
* calcs.
*
- CALL DLACPY( 'N', BW, BW, AF( ODD_SIZE*BW+1 ), BW,
+ CALL DLAMOV( 'N', BW, BW, AF( ODD_SIZE*BW+1 ), BW,
$ AF( ODD_SIZE*BW+2*MBW2+1 ), BW )
*
ELSE
@@ -1100,7 +1099,7 @@
*
* Move the connection block in preparation.
*
- CALL DLACPY( 'L', BW, BW, A( ( OFST+1+ODD_SIZE*LLDA ) ),
+ CALL DLAMOV( 'L', BW, BW, A( ( OFST+1+ODD_SIZE*LLDA ) ),
$ LLDA-1, AF( ODD_SIZE*BW+2*MBW2+1+BW-BW ), BW )
*
*
@@ -1112,7 +1111,7 @@
*
* Move the resulting block back to its location in main storage.
*
- CALL DLACPY( 'L', BW, BW, AF( ODD_SIZE*BW+2*MBW2+1+BW-BW ),
+ CALL DLAMOV( 'L', BW, BW, AF( ODD_SIZE*BW+2*MBW2+1+BW-BW ),
$ BW, A( ( OFST+1+ODD_SIZE*LLDA ) ), LLDA-1 )
*
*
@@ -1321,7 +1320,7 @@
* Move block into place that it will be expected to be for
* calcs.
*
- CALL DLACPY( 'N', BW, BW, AF( ODD_SIZE*BW+1 ), BW,
+ CALL DLAMOV( 'N', BW, BW, AF( ODD_SIZE*BW+1 ), BW,
$ AF( ODD_SIZE*BW+2*MBW2+1 ), BW )
*
ELSE
diff --git a/SRC/pdpbtrsv.f b/SRC/pdpbtrsv.f
index 6d52795..a4cdffc 100644
--- a/SRC/pdpbtrsv.f
+++ b/SRC/pdpbtrsv.f
@@ -1,10 +1,9 @@
SUBROUTINE PDPBTRSV( UPLO, TRANS, N, BW, NRHS, A, JA, DESCA, B,
$ IB, DESCB, AF, LAF, WORK, LWORK, INFO )
*
-* -- ScaLAPACK routine (version 1.7) --
-* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
-* and University of California, Berkeley.
-* April 3, 2000
+* -- ScaLAPACK routine (version 2.0.2) --
+* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver
+* May 1 2012
*
* .. Scalar Arguments ..
CHARACTER TRANS, UPLO
@@ -394,7 +393,7 @@
* ..
* .. External Subroutines ..
EXTERNAL BLACS_GRIDEXIT, BLACS_GRIDINFO, DESC_CONVERT,
- $ DGEMM, DGERV2D, DGESD2D, DLACPY, DMATADD,
+ $ DGEMM, DGERV2D, DGESD2D, DLAMOV, DMATADD,
$ DTBTRS, DTRMM, DTRTRS, GLOBCHK, PXERBLA,
$ RESHAPE
* ..
@@ -762,7 +761,7 @@
* First copy and multiply it into temporary storage,
* then use it on RHS
*
- CALL DLACPY( 'N', BW, NRHS,
+ CALL DLAMOV( 'N', BW, NRHS,
$ B( PART_OFFSET+ODD_SIZE-BW+1 ), LLDB,
$ WORK( 1 ), BW )
*
@@ -1086,7 +1085,7 @@
* First copy and multiply it into temporary storage,
* then use it on RHS
*
- CALL DLACPY( 'N', BW, NRHS, B( PART_OFFSET+ODD_SIZE+1 ),
+ CALL DLAMOV( 'N', BW, NRHS, B( PART_OFFSET+ODD_SIZE+1 ),
$ LLDB, WORK( 1+BW-BW ), BW )
*
CALL DTRMM( 'L', 'U', 'T', 'N', BW, NRHS, -ONE,
@@ -1136,7 +1135,7 @@
* First copy and multiply it into temporary storage,
* then use it on RHS
*
- CALL DLACPY( 'N', BW, NRHS,
+ CALL DLAMOV( 'N', BW, NRHS,
$ B( PART_OFFSET+ODD_SIZE-BW+1 ), LLDB,
$ WORK( 1 ), BW )
*
@@ -1460,7 +1459,7 @@
* First copy and multiply it into temporary storage,
* then use it on RHS
*
- CALL DLACPY( 'N', BW, NRHS, B( PART_OFFSET+ODD_SIZE+1 ),
+ CALL DLAMOV( 'N', BW, NRHS, B( PART_OFFSET+ODD_SIZE+1 ),
$ LLDB, WORK( 1+BW-BW ), BW )
*
CALL DTRMM( 'L', 'L', 'N', 'N', BW, NRHS, -ONE,
diff --git a/SRC/pdrot.f b/SRC/pdrot.f
new file mode 100644
index 0000000..cbbfb3e
--- /dev/null
+++ b/SRC/pdrot.f
@@ -0,0 +1,442 @@
+ SUBROUTINE PDROT( N, X, IX, JX, DESCX, INCX, Y, IY, JY, DESCY,
+ $ INCY, CS, SN, WORK, LWORK, INFO )
+*
+* Contribution from the Department of Computing Science and HPC2N,
+* Umea University, Sweden
+*
+* -- ScaLAPACK auxiliary routine (version 2.0.1) --
+* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
+* Univ. of Colorado Denver and University of California, Berkeley.
+* January, 2012
+*
+ IMPLICIT NONE
+*
+* .. Scalar Arguments ..
+ INTEGER N, IX, JX, INCX, IY, JY, INCY, LWORK, INFO
+ DOUBLE PRECISION CS, SN
+* ..
+* .. Array Arguments ..
+ INTEGER DESCX( * ), DESCY( * )
+ DOUBLE PRECISION X( * ), Y( * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+* PDROT applies a planar rotation defined by CS and SN to the
+* two distributed vectors sub(X) and sub(Y).
+*
+* Notes
+* =====
+*
+* Each global data object is described by an associated description
+* vector. This vector stores the information required to establish
+* the mapping between an object element and its corresponding process
+* and memory location.
+*
+* Let A be a generic term for any 2D block cyclicly distributed array.
+* Such a global array has an associated description vector DESCA.
+* In the following comments, the character _ should be read as
+* "of the global array".
+*
+* NOTATION STORED IN EXPLANATION
+* --------------- -------------- --------------------------------------
+* DTYPE_A(global) DESCA( DTYPE_ )The descriptor type. In this case,
+* DTYPE_A = 1.
+* CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating
+* the BLACS process grid A is distribu-
+* ted over. The context itself is glo-
+* bal, but the handle (the integer
+* value) may vary.
+* M_A (global) DESCA( M_ ) The number of rows in the global
+* array A.
+* N_A (global) DESCA( N_ ) The number of columns in the global
+* array A.
+* MB_A (global) DESCA( MB_ ) The blocking factor used to distribute
+* the rows of the array.
+* NB_A (global) DESCA( NB_ ) The blocking factor used to distribute
+* the columns of the array.
+* RSRC_A (global) DESCA( RSRC_ ) The process row over which the first
+* row of the array A is distributed.
+* CSRC_A (global) DESCA( CSRC_ ) The process column over which the
+* first column of the array A is
+* distributed.
+* LLD_A (local) DESCA( LLD_ ) The leading dimension of the local
+* array. LLD_A >= MAX(1,LOCr(M_A)).
+*
+* Let K be the number of rows or columns of a distributed matrix,
+* and assume that its process grid has dimension p x q.
+* LOCr( K ) denotes the number of elements of K that a process
+* would receive if K were distributed over the p processes of its
+* process column.
+* Similarly, LOCc( K ) denotes the number of elements of K that a
+* process would receive if K were distributed over the q processes of
+* its process row.
+* The values of LOCr() and LOCc() may be determined via a call to the
+* ScaLAPACK tool function, NUMROC:
+* LOCr( M ) = NUMROC( M, MB_A, MYROW, RSRC_A, NPROW ),
+* LOCc( N ) = NUMROC( N, NB_A, MYCOL, CSRC_A, NPCOL ).
+* An upper bound for these quantities may be computed by:
+* LOCr( M ) <= ceil( ceil(M/MB_A)/NPROW )*MB_A
+* LOCc( N ) <= ceil( ceil(N/NB_A)/NPCOL )*NB_A
+*
+* Arguments
+* =========
+*
+* N (global input) INTEGER
+* The number of elements to operate on when applying the planar
+* rotation to X and Y. N>=0.
+*
+* X (local input/local output) DOUBLE PRECSION array of dimension
+* ( (JX-1)*M_X + IX + ( N - 1 )*abs( INCX ) )
+* This array contains the entries of the distributed vector
+* sub( X ).
+*
+* IX (global input) INTEGER
+* The global row index of the submatrix of the distributed
+* matrix X to operate on. If INCX = 1, then it is required
+* that IX = IY. 1 <= IX <= M_X.
+*
+* JX (global input) INTEGER
+* The global column index of the submatrix of the distributed
+* matrix X to operate on. If INCX = M_X, then it is required
+* that JX = JY. 1 <= IX <= N_X.
+*
+* DESCX (global and local input) INTEGER array of dimension 9
+* The array descriptor of the distributed matrix X.
+*
+* INCX (global input) INTEGER
+* The global increment for the elements of X. Only two values
+* of INCX are supported in this version, namely 1 and M_X.
+* Moreover, it must hold that INCX = M_X if INCY = M_Y and
+* that INCX = 1 if INCY = 1.
+*
+* Y (local input/local output) DOUBLE PRECSION array of dimension
+* ( (JY-1)*M_Y + IY + ( N - 1 )*abs( INCY ) )
+* This array contains the entries of the distributed vector
+* sub( Y ).
+*
+* IY (global input) INTEGER
+* The global row index of the submatrix of the distributed
+* matrix Y to operate on. If INCY = 1, then it is required
+* that IY = IX. 1 <= IY <= M_Y.
+*
+* JY (global input) INTEGER
+* The global column index of the submatrix of the distributed
+* matrix Y to operate on. If INCY = M_X, then it is required
+* that JY = JX. 1 <= JY <= N_Y.
+*
+* DESCY (global and local input) INTEGER array of dimension 9
+* The array descriptor of the distributed matrix Y.
+*
+* INCY (global input) INTEGER
+* The global increment for the elements of Y. Only two values
+* of INCY are supported in this version, namely 1 and M_Y.
+* Moreover, it must hold that INCY = M_Y if INCX = M_X and
+* that INCY = 1 if INCX = 1.
+*
+* CS (global input) DOUBLE PRECISION
+* SN (global input) DOUBLE PRECISION
+* The parameters defining the properties of the planar
+* rotation. It must hold that 0 <= CS,SN <= 1 and that
+* SN**2 + CS**2 = 1. The latter is hardly checked in
+* finite precision arithmetics.
+*
+* WORK (local input) DOUBLE PRECISION array of dimension LWORK
+* Local workspace area.
+*
+* LWORK (local input) INTEGER
+* The length of the workspace array WORK.
+* If INCX = 1 and INCY = 1, then LWORK = 2*MB_X
+*
+* If LWORK = -1, then a workspace query is assumed; the
+* routine only calculates the optimal size of the WORK array,
+* returns this value as the first entry of the IWORK array, and
+* no error message related to LIWORK is issued by PXERBLA.
+*
+* INFO (global output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value.
+* If the i-th argument is an array and the j-entry had
+* an illegal value, then INFO = -(i*100+j), if the i-th
+* argument is a scalar and had an illegal value, then INFO = -i.
+*
+* Additional requirements
+* =======================
+*
+* The following alignment requirements must hold:
+* (a) DESCX( MB_ ) = DESCY( MB_ ) and DESCX( NB_ ) = DESCY( NB_ )
+* (b) DESCX( RSRC_ ) = DESCY( RSRC_ )
+* (c) DESCX( CSRC_ ) = DESCY( CSRC_ )
+*
+* =====================================================================
+*
+* Written by Robert Granat, May 15, 2007.
+*
+* .. Parameters ..
+ INTEGER BLOCK_CYCLIC_2D, CSRC_, CTXT_, DLEN_, DTYPE_,
+ $ LLD_, MB_, M_, NB_, N_, RSRC_
+ PARAMETER ( BLOCK_CYCLIC_2D = 1, DLEN_ = 9, DTYPE_ = 1,
+ $ CTXT_ = 2, M_ = 3, N_ = 4, MB_ = 5, NB_ = 6,
+ $ RSRC_ = 7, CSRC_ = 8, LLD_ = 9 )
+* ..
+* .. Local Scalars ..
+ LOGICAL LQUERY, LEFT, RIGHT
+ INTEGER ICTXT, NPROW, NPCOL, MYROW, MYCOL, NPROCS,
+ $ MB, NB, XYROWS, XYCOLS, RSRC1, RSRC2, CSRC1,
+ $ CSRC2, ICOFFXY, IROFFXY, MNWRK, LLDX, LLDY,
+ $ INDX, JXX, XLOC1, XLOC2, RSRC, CSRC, YLOC1,
+ $ YLOC2, JYY, IXX, IYY
+* ..
+* .. External Functions ..
+ INTEGER NUMROC, INDXG2P, INDXG2L
+ EXTERNAL NUMROC, INDXG2P, INDXG2L
+* ..
+* .. External Subroutines ..
+ EXTERNAL DROT
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, MIN
+* ..
+* .. Local Functions ..
+ INTEGER ICEIL
+* ..
+* .. Executable Statements ..
+*
+* Get grid parameters
+*
+ ICTXT = DESCX( CTXT_ )
+ CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL )
+ NPROCS = NPROW*NPCOL
+*
+* Test and decode parameters
+*
+ LQUERY = LWORK.EQ.-1
+ INFO = 0
+ IF( N.LT.0 ) THEN
+ INFO = -1
+ ELSEIF( IX.LT.1 .OR. IX.GT.DESCX(M_) ) THEN
+ INFO = -3
+ ELSEIF( JX.LT.1 .OR. JX.GT.DESCX(N_) ) THEN
+ INFO = -4
+ ELSEIF( INCX.NE.1 .AND. INCX.NE.DESCX(M_) ) THEN
+ INFO = -6
+ ELSEIF( IY.LT.1 .OR. IY.GT.DESCY(M_) ) THEN
+ INFO = -8
+ ELSEIF( JY.LT.1 .OR. JY.GT.DESCY(N_) ) THEN
+ INFO = -9
+ ELSEIF( INCY.NE.1 .AND. INCY.NE.DESCY(M_) ) THEN
+ INFO = -11
+ ELSEIF( (INCX.EQ.DESCX(M_) .AND. INCY.NE.DESCY(M_)) .OR.
+ $ (INCX.EQ.1 .AND. INCY.NE.1 ) ) THEN
+ INFO = -11
+ ELSEIF( (INCX.EQ.1 .AND. INCY.EQ.1) .AND.
+ $ IX.NE.IY ) THEN
+ INFO = -8
+ ELSEIF( (INCX.EQ.DESCX(M_) .AND. INCY.EQ.DESCY(M_)) .AND.
+ $ JX.NE.JY ) THEN
+ INFO = -9
+ END IF
+*
+* Compute the direction of the planar rotation
+*
+ LEFT = INCX.EQ.DESCX(M_) .AND. INCY.EQ.DESCY(M_)
+ RIGHT = INCX.EQ.1 .AND. INCY.EQ.1
+*
+* Check blocking factors and root processor
+*
+ IF( INFO.EQ.0 ) THEN
+ IF( LEFT .AND. DESCX(NB_).NE.DESCY(NB_) ) THEN
+ INFO = -(100*5 + NB_)
+ END IF
+ IF( RIGHT .AND. DESCX(MB_).NE.DESCY(NB_) ) THEN
+ INFO = -(100*10 + MB_)
+ END IF
+ END IF
+ IF( INFO.EQ.0 ) THEN
+ IF( LEFT .AND. DESCX(CSRC_).NE.DESCY(CSRC_) ) THEN
+ INFO = -(100*5 + CSRC_)
+ END IF
+ IF( RIGHT .AND. DESCX(RSRC_).NE.DESCY(RSRC_) ) THEN
+ INFO = -(100*10 + RSRC_)
+ END IF
+ END IF
+*
+* Compute workspace
+*
+ MB = DESCX( MB_ )
+ NB = DESCX( NB_ )
+ IF( LEFT ) THEN
+ RSRC1 = INDXG2P( IX, MB, MYROW, DESCX(RSRC_), NPROW )
+ RSRC2 = INDXG2P( IY, MB, MYROW, DESCY(RSRC_), NPROW )
+ CSRC = INDXG2P( JX, NB, MYCOL, DESCX(CSRC_), NPCOL )
+ ICOFFXY = MOD( JX - 1, NB )
+ XYCOLS = NUMROC( N+ICOFFXY, NB, MYCOL, CSRC, NPCOL )
+ IF( ( MYROW.EQ.RSRC1 .OR. MYROW.EQ.RSRC2 ) .AND.
+ $ MYCOL.EQ.CSRC ) XYCOLS = XYCOLS - ICOFFXY
+ IF( RSRC1.NE.RSRC2 ) THEN
+ MNWRK = XYCOLS
+ ELSE
+ MNWRK = 0
+ END IF
+ ELSEIF( RIGHT ) THEN
+ CSRC1 = INDXG2P( JX, NB, MYCOL, DESCX(CSRC_), NPCOL )
+ CSRC2 = INDXG2P( JY, NB, MYCOL, DESCY(CSRC_), NPCOL )
+ RSRC = INDXG2P( IX, MB, MYROW, DESCX(RSRC_), NPROW )
+ IROFFXY = MOD( IX - 1, MB )
+ XYROWS = NUMROC( N+IROFFXY, MB, MYROW, RSRC, NPROW )
+ IF( ( MYCOL.EQ.CSRC1 .OR. MYCOL.EQ.CSRC2 ) .AND.
+ $ MYROW.EQ.RSRC ) XYROWS = XYROWS - IROFFXY
+ IF( CSRC1.NE.CSRC2 ) THEN
+ MNWRK = XYROWS
+ ELSE
+ MNWRK = 0
+ END IF
+ END IF
+ IF( INFO.EQ.0 ) THEN
+ IF( .NOT.LQUERY . AND. LWORK.LT.MNWRK ) INFO = -15
+ END IF
+*
+* Return if some argument is incorrect
+*
+ IF( INFO.NE.0 ) THEN
+ CALL PXERBLA( ICTXT, 'PDROT', -INFO )
+ RETURN
+ ELSEIF( LQUERY ) THEN
+ WORK( 1 ) = DBLE(MNWRK)
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 ) THEN
+ RETURN
+ END IF
+*
+* Extract local leading dimensions
+*
+ LLDX = DESCX( LLD_ )
+ LLDY = DESCY( LLD_ )
+*
+* If we have only one process, use the corresponding LAPACK
+* routine and return
+*
+ IF( NPROCS.EQ.1 ) THEN
+ IF( LEFT ) THEN
+ CALL DROT( N, X((JX-1)*LLDX+IX), LLDX, Y((JY-1)*LLDY+IY),
+ $ LLDY, CS, SN )
+ ELSEIF( RIGHT ) THEN
+ CALL DROT( N, X((JX-1)*LLDX+IX), 1, Y((JY-1)*LLDY+IY),
+ $ 1, CS, SN )
+ END IF
+ RETURN
+ END IF
+*
+* Exchange data between processors if necessary and perform planar
+* rotation
+*
+ IF( LEFT ) THEN
+ DO 10 INDX = 1, NPCOL
+ IF( MYROW.EQ.RSRC1 .AND. XYCOLS.GT.0 ) THEN
+ IF( INDX.EQ.1 ) THEN
+ JXX = JX
+ ELSE
+ JXX = JX-ICOFFXY + (INDX-1)*NB
+ END IF
+ CALL INFOG2L( IX, JXX, DESCX, NPROW, NPCOL, MYROW,
+ $ MYCOL, XLOC1, XLOC2, RSRC, CSRC )
+ IF( MYROW.EQ.RSRC .AND. MYCOL.EQ.CSRC ) THEN
+ IF( RSRC1.NE.RSRC2 ) THEN
+ CALL DGESD2D( ICTXT, 1, XYCOLS,
+ $ X((XLOC2-1)*LLDX+XLOC1), LLDX,
+ $ RSRC2, CSRC )
+ CALL DGERV2D( ICTXT, 1, XYCOLS, WORK, 1,
+ $ RSRC2, CSRC )
+ CALL DROT( XYCOLS, X((XLOC2-1)*LLDX+XLOC1),
+ $ LLDX, WORK, 1, CS, SN )
+ ELSE
+ CALL INFOG2L( IY, JXX, DESCY, NPROW, NPCOL,
+ $ MYROW, MYCOL, YLOC1, YLOC2, RSRC,
+ $ CSRC )
+ CALL DROT( XYCOLS, X((XLOC2-1)*LLDX+XLOC1),
+ $ LLDX, Y((YLOC2-1)*LLDY+YLOC1), LLDY, CS,
+ $ SN )
+ END IF
+ END IF
+ END IF
+ IF( MYROW.EQ.RSRC2 .AND. RSRC1.NE.RSRC2 ) THEN
+ IF( INDX.EQ.1 ) THEN
+ JYY = JY
+ ELSE
+ JYY = JY-ICOFFXY + (INDX-1)*NB
+ END IF
+ CALL INFOG2L( IY, JYY, DESCY, NPROW, NPCOL, MYROW,
+ $ MYCOL, YLOC1, YLOC2, RSRC, CSRC )
+ IF( MYROW.EQ.RSRC .AND. MYCOL.EQ.CSRC ) THEN
+ CALL DGESD2D( ICTXT, 1, XYCOLS,
+ $ Y((YLOC2-1)*LLDY+YLOC1), LLDY,
+ $ RSRC1, CSRC )
+ CALL DGERV2D( ICTXT, 1, XYCOLS, WORK, 1,
+ $ RSRC1, CSRC )
+ CALL DROT( XYCOLS, WORK, 1, Y((YLOC2-1)*LLDY+YLOC1),
+ $ LLDY, CS, SN )
+ END IF
+ END IF
+ 10 CONTINUE
+ ELSEIF( RIGHT ) THEN
+ DO 20 INDX = 1, NPROW
+ IF( MYCOL.EQ.CSRC1 .AND. XYROWS.GT.0 ) THEN
+ IF( INDX.EQ.1 ) THEN
+ IXX = IX
+ ELSE
+ IXX = IX-IROFFXY + (INDX-1)*MB
+ END IF
+ CALL INFOG2L( IXX, JX, DESCX, NPROW, NPCOL, MYROW,
+ $ MYCOL, XLOC1, XLOC2, RSRC, CSRC )
+ IF( MYROW.EQ.RSRC .AND. MYCOL.EQ.CSRC ) THEN
+ IF( CSRC1.NE.CSRC2 ) THEN
+ CALL DGESD2D( ICTXT, XYROWS, 1,
+ $ X((XLOC2-1)*LLDX+XLOC1), LLDX,
+ $ RSRC, CSRC2 )
+ CALL DGERV2D( ICTXT, XYROWS, 1, WORK, XYROWS,
+ $ RSRC, CSRC2 )
+ CALL DROT( XYROWS, X((XLOC2-1)*LLDX+XLOC1),
+ $ 1, WORK, 1, CS, SN )
+ ELSE
+ CALL INFOG2L( IXX, JY, DESCY, NPROW, NPCOL,
+ $ MYROW, MYCOL, YLOC1, YLOC2, RSRC,
+ $ CSRC )
+ CALL DROT( XYROWS, X((XLOC2-1)*LLDX+XLOC1),
+ $ 1, Y((YLOC2-1)*LLDY+YLOC1), 1, CS,
+ $ SN )
+ END IF
+ END IF
+ END IF
+ IF( MYCOL.EQ.CSRC2 .AND. CSRC1.NE.CSRC2 ) THEN
+ IF( INDX.EQ.1 ) THEN
+ IYY = IY
+ ELSE
+ IYY = IY-IROFFXY + (INDX-1)*MB
+ END IF
+ CALL INFOG2L( IYY, JY, DESCY, NPROW, NPCOL, MYROW,
+ $ MYCOL, YLOC1, YLOC2, RSRC, CSRC )
+ IF( MYROW.EQ.RSRC .AND. MYCOL.EQ.CSRC ) THEN
+ CALL DGESD2D( ICTXT, XYROWS, 1,
+ $ Y((YLOC2-1)*LLDY+YLOC1), LLDY,
+ $ RSRC, CSRC1 )
+ CALL DGERV2D( ICTXT, XYROWS, 1, WORK, XYROWS,
+ $ RSRC, CSRC1 )
+ CALL DROT( XYROWS, WORK, 1, Y((YLOC2-1)*LLDY+YLOC1),
+ $ 1, CS, SN )
+ END IF
+ END IF
+ 20 CONTINUE
+ END IF
+*
+* Store minimum workspace requirements in WORK-array and return
+*
+ WORK( 1 ) = DBLE(MNWRK)
+ RETURN
+*
+* End of PDROT
+*
+ END
diff --git a/SRC/pdsyev.f b/SRC/pdsyev.f
index 5748cd7..8ccf3ac 100644
--- a/SRC/pdsyev.f
+++ b/SRC/pdsyev.f
@@ -125,8 +125,7 @@
* correct error reporting.
*
* W (global output) DOUBLE PRECISION array, dimension (N)
-* On normal exit, the first M entries contain the selected
-* eigenvalues in ascending order.
+* If INFO=0, the eigenvalues in ascending order.
*
* Z (local output) DOUBLE PRECISION array,
* global dimension (N, N),
@@ -342,6 +341,8 @@
$ NB_A ) + NB_A*NB_A
ELSE
SIZEMQRLEFT = 0
+ IROFFZ = 0
+ IZROW = 0
END IF
SIZESYTRD = MAX( NB * ( NP +1 ), 3 * NB )
*
diff --git a/SRC/pdsyevr.f b/SRC/pdsyevr.f
new file mode 100644
index 0000000..984b990
--- /dev/null
+++ b/SRC/pdsyevr.f
@@ -0,0 +1,1167 @@
+ SUBROUTINE PDSYEVR( JOBZ, RANGE, UPLO, N, A, IA, JA,
+ $ DESCA, VL, VU, IL, IU, M, NZ, W, Z, IZ,
+ $ JZ, DESCZ, WORK, LWORK, IWORK, LIWORK,
+ $ INFO )
+
+ IMPLICIT NONE
+*
+* -- ScaLAPACK routine (version 2.0.2) --
+* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver
+* May 1 2012
+*
+* .. Scalar Arguments ..
+ CHARACTER JOBZ, RANGE, UPLO
+ INTEGER IA, IL, INFO, IU, IZ, JA, JZ, LIWORK, LWORK, M,
+ $ N, NZ
+ DOUBLE PRECISION VL, VU
+* ..
+* .. Array Arguments ..
+ INTEGER DESCA( * ), DESCZ( * ), IWORK( * )
+ DOUBLE PRECISION A( * ), W( * ), WORK( * ), Z( * )
+* ..
+*
+* Purpose
+* =======
+*
+* PDSYEVR computes selected eigenvalues and, optionally, eigenvectors
+* of a real symmetric matrix A distributed in 2D blockcyclic format
+* by calling the recommended sequence of ScaLAPACK routines.
+*
+* First, the matrix A is reduced to real symmetric tridiagonal form.
+* Then, the eigenproblem is solved using the parallel MRRR algorithm.
+* Last, if eigenvectors have been computed, a backtransformation is done.
+*
+* Upon successful completion, each processor stores a copy of all computed
+* eigenvalues in W. The eigenvector matrix Z is stored in
+* 2D blockcyclic format distributed over all processors.
+*
+* Note that subsets of eigenvalues/vectors can be selected by
+* specifying a range of values or a range of indices for the desired
+* eigenvalues.
+*
+* For constructive feedback and comments, please contact cvoemel at lbl.gov
+* C. Voemel
+*
+* Arguments
+* =========
+*
+* JOBZ (global input) CHARACTER*1
+* Specifies whether or not to compute the eigenvectors:
+* = 'N': Compute eigenvalues only.
+* = 'V': Compute eigenvalues and eigenvectors.
+*
+* RANGE (global input) CHARACTER*1
+* = 'A': all eigenvalues will be found.
+* = 'V': all eigenvalues in the interval [VL,VU] will be found.
+* = 'I': the IL-th through IU-th eigenvalues will be found.
+*
+* UPLO (global input) CHARACTER*1
+* Specifies whether the upper or lower triangular part of the
+* symmetric matrix A is stored:
+* = 'U': Upper triangular
+* = 'L': Lower triangular
+*
+* N (global input) INTEGER
+* The number of rows and columns of the matrix A. N >= 0
+*
+* A (local input/workspace) 2D block cyclic DOUBLE PRECISION array,
+* global dimension (N, N),
+* local dimension ( LLD_A, LOCc(JA+N-1) ),
+* (see Notes below for more detailed explanation of 2d arrays)
+*
+* On entry, the symmetric matrix A. If UPLO = 'U', only the
+* upper triangular part of A is used to define the elements of
+* the symmetric matrix. If UPLO = 'L', only the lower
+* triangular part of A is used to define the elements of the
+* symmetric matrix.
+*
+* On exit, the lower triangle (if UPLO='L') or the upper
+* triangle (if UPLO='U') of A, including the diagonal, is
+* destroyed.
+*
+* IA (global input) INTEGER
+* A's global row index, which points to the beginning of the
+* submatrix which is to be operated on.
+* It should be set to 1 when operating on a full matrix.
+*
+* JA (global input) INTEGER
+* A's global column index, which points to the beginning of
+* the submatrix which is to be operated on.
+* It should be set to 1 when operating on a full matrix.
+*
+* DESCA (global and local input) INTEGER array of dimension DLEN=9.
+* The array descriptor for the distributed matrix A.
+* The descriptor stores details about the 2D block-cyclic
+* storage, see the notes below.
+* If DESCA is incorrect, PDSYEVR cannot guarantee
+* correct error reporting.
+* Also note the array alignment requirements specified below.
+*
+* VL (global input) DOUBLE PRECISION
+* If RANGE='V', the lower bound of the interval to be searched
+* for eigenvalues. Not referenced if RANGE = 'A' or 'I'.
+*
+* VU (global input) DOUBLE PRECISION
+* If RANGE='V', the upper bound of the interval to be searched
+* for eigenvalues. Not referenced if RANGE = 'A' or 'I'.
+*
+* IL (global input) INTEGER
+* If RANGE='I', the index (from smallest to largest) of the
+* smallest eigenvalue to be returned. IL >= 1.
+* Not referenced if RANGE = 'A'.
+*
+* IU (global input) INTEGER
+* If RANGE='I', the index (from smallest to largest) of the
+* largest eigenvalue to be returned. min(IL,N) <= IU <= N.
+* Not referenced if RANGE = 'A'.
+*
+* M (global output) INTEGER
+* Total number of eigenvalues found. 0 <= M <= N.
+*
+* NZ (global output) INTEGER
+* Total number of eigenvectors computed. 0 <= NZ <= M.
+* The number of columns of Z that are filled.
+* If JOBZ .NE. 'V', NZ is not referenced.
+* If JOBZ .EQ. 'V', NZ = M
+*
+* W (global output) DOUBLE PRECISION array, dimension (N)
+* Upon successful exit, the first M entries contain the selected
+* eigenvalues in ascending order.
+*
+* Z (local output) DOUBLE PRECISION array,
+* global dimension (N, N),
+* local dimension ( LLD_Z, LOCc(JZ+N-1) )
+* (see Notes below for more detailed explanation of 2d arrays)
+* If JOBZ = 'V', then on normal exit the first M columns of Z
+* contain the orthonormal eigenvectors of the matrix
+* corresponding to the selected eigenvalues.
+* If JOBZ = 'N', then Z is not referenced.
+*
+* IZ (global input) INTEGER
+* Z's global row index, which points to the beginning of the
+* submatrix which is to be operated on.
+* It should be set to 1 when operating on a full matrix.
+*
+* JZ (global input) INTEGER
+* Z's global column index, which points to the beginning of
+* the submatrix which is to be operated on.
+* It should be set to 1 when operating on a full matrix.
+*
+* DESCZ (global and local input) INTEGER array of dimension DLEN_.
+* The array descriptor for the distributed matrix Z.
+* The context DESCZ( CTXT_ ) must equal DESCA( CTXT_ ).
+* Also note the array alignment requirements specified below.
+*
+* WORK (local workspace/output) DOUBLE PRECISION array,
+* dimension (LWORK)
+* On return, WORK(1) contains the optimal amount of
+* workspace required for efficient execution.
+* if JOBZ='N' WORK(1) = optimal amount of workspace
+* required to compute the eigenvalues.
+* if JOBZ='V' WORK(1) = optimal amount of workspace
+* required to compute eigenvalues and eigenvectors.
+*
+* LWORK (local input) INTEGER
+* Size of WORK, must be at least 3.
+* See below for definitions of variables used to define LWORK.
+* If no eigenvectors are requested (JOBZ = 'N') then
+* LWORK >= 2 + 5*N + MAX( 12 * NN, NB * ( NP0 + 1 ) )
+* If eigenvectors are requested (JOBZ = 'V' ) then
+* the amount of workspace required is:
+* LWORK >= 2 + 5*N + MAX( 18*NN, NP0 * MQ0 + 2 * NB * NB ) +
+* (2 + ICEIL( NEIG, NPROW*NPCOL))*NN
+*
+* Variable definitions:
+* NEIG = number of eigenvectors requested
+* NB = DESCA( MB_ ) = DESCA( NB_ ) =
+* DESCZ( MB_ ) = DESCZ( NB_ )
+* NN = MAX( N, NB, 2 )
+* DESCA( RSRC_ ) = DESCA( NB_ ) = DESCZ( RSRC_ ) =
+* DESCZ( CSRC_ ) = 0
+* NP0 = NUMROC( NN, NB, 0, 0, NPROW )
+* MQ0 = NUMROC( MAX( NEIG, NB, 2 ), NB, 0, 0, NPCOL )
+* ICEIL( X, Y ) is a ScaLAPACK function returning
+* ceiling(X/Y)
+*
+* If LWORK = -1, then LWORK is global input and a workspace
+* query is assumed; the routine only calculates the size
+* required for optimal performance for all work arrays. Each of
+* these values is returned in the first entry of the
+* corresponding work arrays, and no error message is issued by
+* PXERBLA.
+* Note that in a workspace query, for performance the optimal
+* workspace LWOPT is returned rather than the minimum necessary
+* WORKSPACE LWMIN. For very small matrices, LWOPT >> LWMIN.
+*
+* IWORK (local workspace) INTEGER array
+* On return, IWORK(1) contains the amount of integer workspace
+* required.
+*
+* LIWORK (local input) INTEGER
+* size of IWORK
+*
+* Let NNP = MAX( N, NPROW*NPCOL + 1, 4 ). Then:
+* LIWORK >= 12*NNP + 2*N when the eigenvectors are desired
+* LIWORK >= 10*NNP + 2*N when only the eigenvalues have to be computed
+*
+* If LIWORK = -1, then LIWORK is global input and a workspace
+* query is assumed; the routine only calculates the minimum
+* and optimal size for all work arrays. Each of these
+* values is returned in the first entry of the corresponding
+* work array, and no error message is issued by PXERBLA.
+*
+* INFO (global output) INTEGER
+* = 0: successful exit
+* < 0: If the i-th argument is an array and the j-entry had
+* an illegal value, then INFO = -(i*100+j), if the i-th
+* argument is a scalar and had an illegal value, then
+* INFO = -i.
+*
+* Notes
+* =====
+*
+* Each global data object is described by an associated description
+* vector. This vector stores the information required to establish
+* the mapping between an object element and its corresponding process
+* and memory location.
+*
+* Let A be a generic term for any 2D block cyclicly distributed array.
+* Such a global array has an associated description vector DESCA,
+* or DESCZ for the descriptor of Z, etc.
+* The length of a ScaLAPACK descriptor is nine.
+* In the following comments, the character _ should be read as
+* "of the global array".
+*
+* NOTATION STORED IN EXPLANATION
+* --------------- -------------- --------------------------------------
+* DTYPE_A(global) DESCA( DTYPE_ )The descriptor type. In this case,
+* DTYPE_A = 1.
+* CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating
+* the BLACS process grid A is distribu-
+* ted over. The context itself is glo-
+* bal, but the handle (the integer
+* value) may vary.
+* M_A (global) DESCA( M_ ) The number of rows in the global
+* array A.
+* N_A (global) DESCA( N_ ) The number of columns in the global
+* array A.
+* MB_A (global) DESCA( MB_ ) The blocking factor used to distribute
+* the rows of the array.
+* NB_A (global) DESCA( NB_ ) The blocking factor used to distribute
+* the columns of the array.
+* RSRC_A (global) DESCA( RSRC_ ) The process row over which the first
+* row of the array A is distributed.
+* CSRC_A (global) DESCA( CSRC_ ) The process column over which the
+* first column of the array A is
+* distributed.
+* LLD_A (local) DESCA( LLD_ ) The leading dimension of the local
+* array. LLD_A >= MAX(1,LOCr(M_A)).
+*
+* Let K be the number of rows or columns of a distributed matrix,
+* and assume that its process grid has dimension p x q.
+* LOCr( K ) denotes the number of elements of K that a process
+* would receive if K were distributed over the p processes of its
+* process column.
+* Similarly, LOCc( K ) denotes the number of elements of K that a
+* process would receive if K were distributed over the q processes of
+* its process row.
+* The values of LOCr() and LOCc() may be determined via a call to the
+* ScaLAPACK tool function, NUMROC:
+* LOCr( M ) = NUMROC( M, MB_A, MYROW, RSRC_A, NPROW ),
+* LOCc( N ) = NUMROC( N, NB_A, MYCOL, CSRC_A, NPCOL ).
+* An upper bound for these quantities may be computed by:
+* LOCr( M ) <= ceil( ceil(M/MB_A)/NPROW )*MB_A
+* LOCc( N ) <= ceil( ceil(N/NB_A)/NPCOL )*NB_A
+*
+* PDSYEVR assumes IEEE 754 standard compliant arithmetic.
+*
+* Alignment requirements
+* ======================
+*
+* The distributed submatrices A(IA:*, JA:*) and Z(IZ:IZ+M-1,JZ:JZ+N-1)
+* must satisfy the following alignment properties:
+*
+* 1.Identical (quadratic) dimension:
+* DESCA(M_) = DESCZ(M_) = DESCA(N_) = DESCZ(N_)
+* 2.Quadratic conformal blocking:
+* DESCA(MB_) = DESCA(NB_) = DESCZ(MB_) = DESCZ(NB_)
+* DESCA(RSRC_) = DESCZ(RSRC_)
+* 3.MOD( IA-1, MB_A ) = MOD( IZ-1, MB_Z ) = 0
+* 4.IAROW = IZROW
+*
+*
+* .. Parameters ..
+ INTEGER CTXT_, M_, N_,
+ $ MB_, NB_, RSRC_, CSRC_
+ PARAMETER ( CTXT_ = 2, M_ = 3, N_ = 4, MB_ = 5, NB_ = 6,
+ $ RSRC_ = 7, CSRC_ = 8 )
+ DOUBLE PRECISION ZERO
+ PARAMETER ( ZERO = 0.0D0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL ALLEIG, COLBRT, DOBCST, FINISH, FIRST, INDEIG,
+ $ LOWER, LQUERY, VALEIG, VSTART, WANTZ
+ INTEGER ANB, DOL, DOU, DSTCOL, DSTROW, EIGCNT, FRSTCL,
+ $ I, IAROW, ICTXT, IIL, IINDERR, IINDWLC, IINFO,
+ $ IIU, IM, INDD, INDD2, INDE, INDE2, INDERR,
+ $ INDILU, INDRW, INDTAU, INDWLC, INDWORK, IPIL,
+ $ IPIU, IPROC, IZROW, LASTCL, LENGTHI, LENGTHI2,
+ $ LIWMIN, LLWORK, LWMIN, LWOPT, MAXCLS, MQ00,
+ $ MYCOL, MYIL, MYIU, MYPROC, MYROW, MZ, NB,
+ $ NDEPTH, NEEDIL, NEEDIU, NNP, NP00, NPCOL,
+ $ NPROCS, NPROW, NPS, NSPLIT, NSYTRD_LWOPT,
+ $ OFFSET, PARITY, RLENGTHI, RLENGTHI2, RSTARTI,
+ $ SIZE1, SIZE2, SQNPC, SRCCOL, SRCROW, STARTI,
+ $ ZOFFSET
+
+ DOUBLE PRECISION PIVMIN, SAFMIN, SCALE, VLL, VUU, WL,
+ $ WU
+*
+* .. Local Arrays ..
+ INTEGER IDUM1( 4 ), IDUM2( 4 )
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ INTEGER ICEIL, INDXG2P, NUMROC, PJLAENV
+ DOUBLE PRECISION PDLAMCH
+ EXTERNAL ICEIL, INDXG2P, LSAME, NUMROC, PDLAMCH,
+ $ PJLAENV
+* ..
+* .. External Subroutines ..
+ EXTERNAL BLACS_GRIDINFO, CHK1MAT, DCOPY, DGEBR2D,
+ $ DGEBS2D, DGERV2D, DGESD2D, DLARRC, DLASRT2,
+ $ DSTEGR2A, DSTEGR2B, DSTEGR2, IGEBR2D,
+ $ IGEBS2D, IGERV2D, IGESD2D, IGSUM2D, PCHK1MAT,
+ $ PCHK2MAT, PDELGET, PDLAEVSWP, PDLARED1D,
+ $ PDORMTR, PDSYNTRD, PXERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, DBLE, ICHAR, INT, MAX, MIN, MOD, SQRT
+* ..
+* .. Executable Statements ..
+*
+
+
+ INFO = 0
+***********************************************************************
+*
+* Decode character arguments to find out what the code should do
+*
+***********************************************************************
+ WANTZ = LSAME( JOBZ, 'V' )
+ LOWER = LSAME( UPLO, 'L' )
+ ALLEIG = LSAME( RANGE, 'A' )
+ VALEIG = LSAME( RANGE, 'V' )
+ INDEIG = LSAME( RANGE, 'I' )
+ LQUERY = ( LWORK.EQ.-1 .OR. LIWORK.EQ.-1 )
+
+***********************************************************************
+*
+* GET MACHINE PARAMETERS
+*
+***********************************************************************
+ ICTXT = DESCA( CTXT_ )
+ SAFMIN = PDLAMCH( ICTXT, 'Safe minimum' )
+
+***********************************************************************
+*
+* Set up pointers into the WORK array
+*
+***********************************************************************
+ INDTAU = 1
+ INDD = INDTAU + N
+ INDE = INDD + N + 1
+ INDD2 = INDE + N + 1
+ INDE2 = INDD2 + N
+ INDWORK = INDE2 + N
+ LLWORK = LWORK - INDWORK + 1
+
+***********************************************************************
+*
+* BLACS PROCESSOR GRID SETUP
+*
+***********************************************************************
+ CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL )
+
+
+ NPROCS = NPROW * NPCOL
+ MYPROC = MYROW * NPCOL + MYCOL
+ IF( NPROW.EQ.-1 ) THEN
+ INFO = -( 800+CTXT_ )
+ ELSE IF( WANTZ ) THEN
+ IF( ICTXT.NE.DESCZ( CTXT_ ) ) THEN
+ INFO = -( 2100+CTXT_ )
+ END IF
+ END IF
+
+***********************************************************************
+*
+* COMPUTE REAL WORKSPACE
+*
+***********************************************************************
+ IF ( ALLEIG ) THEN
+ MZ = N
+ ELSE IF ( INDEIG ) THEN
+ MZ = IU - IL + 1
+ ELSE
+* Take upper bound for VALEIG case
+ MZ = N
+ END IF
+*
+ NB = DESCA( NB_ )
+ IF ( WANTZ ) THEN
+ NP00 = NUMROC( N, NB, 0, 0, NPROW )
+ MQ00 = NUMROC( MZ, NB, 0, 0, NPCOL )
+ INDRW = INDWORK + MAX(18*N, NP00*MQ00 + 2*NB*NB)
+ LWMIN = INDRW - 1 + (ICEIL(MZ, NPROCS) + 2)*N
+ ELSE
+ INDRW = INDWORK + 12*N
+ LWMIN = INDRW - 1
+ END IF
+* The code that validates the input requires 3 workspace entries
+ LWMIN = MAX(3, LWMIN)
+ LWOPT = LWMIN
+ ANB = PJLAENV( ICTXT, 3, 'PDSYTTRD', 'L', 0, 0, 0, 0 )
+ SQNPC = INT( SQRT( DBLE( NPROCS ) ) )
+ NPS = MAX( NUMROC( N, 1, 0, 0, SQNPC ), 2*ANB )
+ NSYTRD_LWOPT = 2*( ANB+1 )*( 4*NPS+2 ) + ( NPS+4 )*NPS
+ LWOPT = MAX( LWOPT, 5*N+NSYTRD_LWOPT )
+*
+ SIZE1 = INDRW - INDWORK
+
+***********************************************************************
+*
+* COMPUTE INTEGER WORKSPACE
+*
+***********************************************************************
+ NNP = MAX( N, NPROCS+1, 4 )
+ IF ( WANTZ ) THEN
+ LIWMIN = 12*NNP + 2*N
+ ELSE
+ LIWMIN = 10*NNP + 2*N
+ END IF
+
+***********************************************************************
+*
+* Set up pointers into the IWORK array
+*
+***********************************************************************
+* Pointer to eigenpair distribution over processors
+ INDILU = LIWMIN - 2*NPROCS + 1
+ SIZE2 = INDILU - 2*N
+
+
+***********************************************************************
+*
+* Test the input arguments.
+*
+***********************************************************************
+ IF( INFO.EQ.0 ) THEN
+ CALL CHK1MAT( N, 4, N, 4, IA, JA, DESCA, 8, INFO )
+ IF( WANTZ )
+ $ CALL CHK1MAT( N, 4, N, 4, IZ, JZ, DESCZ, 21, INFO )
+*
+ IF( INFO.EQ.0 ) THEN
+ 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( MOD( IA-1, DESCA( MB_ ) ).NE.0 ) THEN
+ INFO = -6
+ ELSE IF( VALEIG .AND. N.GT.0 .AND. VU.LE.VL ) THEN
+ INFO = -10
+ ELSE IF( INDEIG .AND. ( IL.LT.1 .OR. IL.GT.MAX( 1, N ) ) )
+ $ THEN
+ INFO = -11
+ ELSE IF( INDEIG .AND. ( IU.LT.MIN( N, IL ) .OR. IU.GT.N ) )
+ $ THEN
+ INFO = -12
+ ELSE IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN
+ INFO = -21
+ ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN
+ INFO = -23
+ ELSE IF( DESCA( MB_ ).NE.DESCA( NB_ ) ) THEN
+ INFO = -( 800+NB_ )
+ END IF
+ IF( WANTZ ) THEN
+ IAROW = INDXG2P( 1, DESCA( NB_ ), MYROW,
+ $ DESCA( RSRC_ ), NPROW )
+ IZROW = INDXG2P( 1, DESCA( NB_ ), MYROW,
+ $ DESCZ( RSRC_ ), NPROW )
+ IF( IAROW.NE.IZROW ) THEN
+ INFO = -19
+ ELSE IF( MOD( IA-1, DESCA( MB_ ) ).NE.
+ $ MOD( IZ-1, DESCZ( MB_ ) ) ) THEN
+ INFO = -19
+ ELSE IF( DESCA( M_ ).NE.DESCZ( M_ ) ) THEN
+ INFO = -( 2100+M_ )
+ ELSE IF( DESCA( N_ ).NE.DESCZ( N_ ) ) THEN
+ INFO = -( 2100+N_ )
+ ELSE IF( DESCA( MB_ ).NE.DESCZ( MB_ ) ) THEN
+ INFO = -( 2100+MB_ )
+ ELSE IF( DESCA( NB_ ).NE.DESCZ( NB_ ) ) THEN
+ INFO = -( 2100+NB_ )
+ ELSE IF( DESCA( RSRC_ ).NE.DESCZ( RSRC_ ) ) THEN
+ INFO = -( 2100+RSRC_ )
+ ELSE IF( DESCA( CSRC_ ).NE.DESCZ( CSRC_ ) ) THEN
+ INFO = -( 2100+CSRC_ )
+ ELSE IF( ICTXT.NE.DESCZ( CTXT_ ) ) THEN
+ INFO = -( 2100+CTXT_ )
+ END IF
+ END IF
+ END IF
+ IDUM2( 1 ) = 1
+ IF( LOWER ) THEN
+ IDUM1( 2 ) = ICHAR( 'L' )
+ ELSE
+ IDUM1( 2 ) = ICHAR( 'U' )
+ END IF
+ IDUM2( 2 ) = 2
+ IF( ALLEIG ) THEN
+ IDUM1( 3 ) = ICHAR( 'A' )
+ ELSE IF( INDEIG ) THEN
+ IDUM1( 3 ) = ICHAR( 'I' )
+ ELSE
+ IDUM1( 3 ) = ICHAR( 'V' )
+ END IF
+ IDUM2( 3 ) = 3
+ IF( LQUERY ) THEN
+ IDUM1( 4 ) = -1
+ ELSE
+ IDUM1( 4 ) = 1
+ END IF
+ IDUM2( 4 ) = 4
+ IF( WANTZ ) THEN
+ IDUM1( 1 ) = ICHAR( 'V' )
+ CALL PCHK2MAT( N, 4, N, 4, IA, JA, DESCA, 8, N, 4, N, 4, IZ,
+ $ JZ, DESCZ, 21, 4, IDUM1, IDUM2, INFO )
+ ELSE
+ IDUM1( 1 ) = ICHAR( 'N' )
+ CALL PCHK1MAT( N, 4, N, 4, IA, JA, DESCA, 8, 4, IDUM1,
+ $ IDUM2, INFO )
+ END IF
+ WORK( 1 ) = DBLE( LWOPT )
+ IWORK( 1 ) = LIWMIN
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL PXERBLA( ICTXT, 'PDSYEVR', -INFO )
+ RETURN
+ ELSE IF( LQUERY ) THEN
+ RETURN
+ END IF
+
+***********************************************************************
+*
+* Quick return if possible
+*
+***********************************************************************
+ IF( N.EQ.0 ) THEN
+ IF( WANTZ ) THEN
+ NZ = 0
+ END IF
+ M = 0
+ WORK( 1 ) = DBLE( LWOPT )
+ IWORK( 1 ) = LIWMIN
+ RETURN
+ END IF
+
+ IF( VALEIG ) THEN
+ VLL = VL
+ VUU = VU
+ ELSE
+ VLL = ZERO
+ VUU = ZERO
+ END IF
+*
+* No scaling done here, leave this to MRRR kernel.
+* Scale tridiagonal rather than full matrix.
+*
+***********************************************************************
+*
+* REDUCE SYMMETRIC MATRIX TO TRIDIAGONAL FORM.
+*
+***********************************************************************
+
+
+ CALL PDSYNTRD( UPLO, N, A, IA, JA, DESCA, WORK( INDD ),
+ $ WORK( INDE ), WORK( INDTAU ), WORK( INDWORK ),
+ $ LLWORK, IINFO )
+
+
+ IF (IINFO .NE. 0) THEN
+ CALL PXERBLA( ICTXT, 'PDSYNTRD', -IINFO )
+ RETURN
+ END IF
+
+***********************************************************************
+*
+* DISTRIBUTE TRIDIAGONAL TO ALL PROCESSORS
+*
+***********************************************************************
+ OFFSET = 0
+ IF( IA.EQ.1 .AND. JA.EQ.1 .AND.
+ $ DESCA( RSRC_ ).EQ.0 .AND. DESCA( CSRC_ ).EQ.0 )
+ $ THEN
+ CALL PDLARED1D( N, IA, JA, DESCA, WORK( INDD ), WORK( INDD2 ),
+ $ WORK( INDWORK ), LLWORK )
+*
+ CALL PDLARED1D( N, IA, JA, DESCA, WORK( INDE ), WORK( INDE2 ),
+ $ WORK( INDWORK ), LLWORK )
+ IF( .NOT.LOWER )
+ $ OFFSET = 1
+ ELSE
+ DO 10 I = 1, N
+ CALL PDELGET( 'A', ' ', WORK( INDD2+I-1 ), A, I+IA-1,
+ $ I+JA-1, DESCA )
+ 10 CONTINUE
+ IF( LSAME( UPLO, 'U' ) ) THEN
+ DO 20 I = 1, N - 1
+ CALL PDELGET( 'A', ' ', WORK( INDE2+I-1 ), A, I+IA-1,
+ $ I+JA, DESCA )
+ 20 CONTINUE
+ ELSE
+ DO 30 I = 1, N - 1
+ CALL PDELGET( 'A', ' ', WORK( INDE2+I-1 ), A, I+IA,
+ $ I+JA-1, DESCA )
+ 30 CONTINUE
+ END IF
+ END IF
+
+
+
+
+***********************************************************************
+*
+* SET IIL, IIU
+*
+***********************************************************************
+ IF ( ALLEIG ) THEN
+ IIL = 1
+ IIU = N
+ ELSE IF ( INDEIG ) THEN
+ IIL = IL
+ IIU = IU
+ ELSE IF ( VALEIG ) THEN
+ CALL DLARRC('T', N, VLL, VUU, WORK( INDD2 ),
+ $ WORK( INDE2 + OFFSET ), SAFMIN, EIGCNT, IIL, IIU, INFO)
+* Refine upper bound N that was taken
+ MZ = EIGCNT
+ IIL = IIL + 1
+ ENDIF
+
+ IF(MZ.EQ.0) THEN
+ M = 0
+ IF( WANTZ ) THEN
+ NZ = 0
+ END IF
+ WORK( 1 ) = DBLE( LWOPT )
+ IWORK( 1 ) = LIWMIN
+ RETURN
+ END IF
+
+ MYIL = 0
+ MYIU = 0
+ M = 0
+ IM = 0
+
+***********************************************************************
+*
+* COMPUTE WORK ASSIGNMENTS
+*
+***********************************************************************
+*
+* Each processor computes the work assignments for all processors
+*
+ CALL PMPIM2( IIL, IIU, NPROCS,
+ $ IWORK(INDILU), IWORK(INDILU+NPROCS) )
+*
+* Find local work assignment
+*
+ MYIL = IWORK(INDILU+MYPROC)
+ MYIU = IWORK(INDILU+NPROCS+MYPROC)
+
+
+ ZOFFSET = MAX(0, MYIL - IIL - 1)
+ FIRST = ( MYIL .EQ. IIL )
+
+
+***********************************************************************
+*
+* CALLS TO MRRR KERNEL
+*
+***********************************************************************
+ IF(.NOT.WANTZ) THEN
+*
+* Compute eigenvalues only.
+*
+ IINFO = 0
+ IF ( MYIL.GT.0 ) THEN
+ DOL = 1
+ DOU = MYIU - MYIL + 1
+ CALL DSTEGR2( JOBZ, 'I', N, WORK( INDD2 ),
+ $ WORK( INDE2+OFFSET ), VLL, VUU, MYIL, MYIU,
+ $ IM, W( 1 ), WORK( INDRW ), N,
+ $ MYIU - MYIL + 1,
+ $ IWORK( 1 ), WORK( INDWORK ), SIZE1,
+ $ IWORK( 2*N+1 ), SIZE2,
+ $ DOL, DOU, ZOFFSET, IINFO )
+* DSTEGR2 zeroes out the entire W array, so we can't just give
+* it the part of W we need. So here we copy the W entries into
+* their correct location
+ DO 49 I = 1, IM
+ W( MYIL-IIL+I ) = W( I )
+ 49 CONTINUE
+* W( MYIL ) is at W( MYIL - IIL + 1 )
+* W( X ) is at W(X - IIL + 1 )
+ END IF
+ IF (IINFO .NE. 0) THEN
+ CALL PXERBLA( ICTXT, 'DSTEGR2', -IINFO )
+ RETURN
+ END IF
+ ELSEIF ( WANTZ .AND. NPROCS.EQ.1 ) THEN
+*
+* Compute eigenvalues and -vectors, but only on one processor
+*
+ IINFO = 0
+ IF ( MYIL.GT.0 ) THEN
+ DOL = MYIL - IIL + 1
+ DOU = MYIU - IIL + 1
+ CALL DSTEGR2( JOBZ, 'I', N, WORK( INDD2 ),
+ $ WORK( INDE2+OFFSET ), VLL, VUU, IIL, IIU,
+ $ IM, W( 1 ), WORK( INDRW ), N,
+ $ N,
+ $ IWORK( 1 ), WORK( INDWORK ), SIZE1,
+ $ IWORK( 2*N+1 ), SIZE2, DOL, DOU,
+ $ ZOFFSET, IINFO )
+ ENDIF
+ IF (IINFO .NE. 0) THEN
+ CALL PXERBLA( ICTXT, 'DSTEGR2', -IINFO )
+ RETURN
+ END IF
+ ELSEIF ( WANTZ ) THEN
+*
+* Compute representations in parallel.
+* Share eigenvalue computation for root between all processors
+* Then compute the eigenvectors.
+*
+ IINFO = 0
+* Part 1. compute root representations and root eigenvalues
+ IF ( MYIL.GT.0 ) THEN
+ DOL = MYIL - IIL + 1
+ DOU = MYIU - IIL + 1
+ CALL DSTEGR2A( JOBZ, 'I', N, WORK( INDD2 ),
+ $ WORK( INDE2+OFFSET ), VLL, VUU, IIL, IIU,
+ $ IM, W( 1 ), WORK( INDRW ), N,
+ $ N, WORK( INDWORK ), SIZE1,
+ $ IWORK( 2*N+1 ), SIZE2, DOL,
+ $ DOU, NEEDIL, NEEDIU,
+ $ INDERR, NSPLIT, PIVMIN, SCALE, WL, WU,
+ $ IINFO )
+ ENDIF
+ IF (IINFO .NE. 0) THEN
+ CALL PXERBLA( ICTXT, 'DSTEGR2A', -IINFO )
+ RETURN
+ END IF
+*
+* The second part of parallel MRRR, the representation tree
+* construction begins. Upon successful completion, the
+* eigenvectors have been computed. This is indicated by
+* the flag FINISH.
+*
+ VSTART = .TRUE.
+ FINISH = (MYIL.LE.0)
+C Part 2. Share eigenvalues and uncertainties between all processors
+ IINDERR = INDWORK + INDERR - 1
+
+*
+*
+* There are currently two ways to communicate eigenvalue information
+* using the BLACS.
+* 1.) BROADCAST
+* 2.) POINT2POINT between collaborators (those processors working
+* jointly on a cluster.
+* For efficiency, BROADCAST has been disabled.
+* At a later stage, other more efficient communication algorithms
+* might be implemented, e. g. group or tree-based communication.
+*
+ DOBCST = .FALSE.
+ IF(DOBCST) THEN
+* First gather everything on the first processor.
+* Then use BROADCAST-based communication
+ DO 45 I = 2, NPROCS
+ IF (MYPROC .EQ. (I - 1)) THEN
+ DSTROW = 0
+ DSTCOL = 0
+ STARTI = DOL
+ IWORK(1) = STARTI
+ IF(MYIL.GT.0) THEN
+ LENGTHI = MYIU - MYIL + 1
+ ELSE
+ LENGTHI = 0
+ ENDIF
+ IWORK(2) = LENGTHI
+ CALL IGESD2D( ICTXT, 2, 1, IWORK, 2,
+ $ DSTROW, DSTCOL )
+ IF (( STARTI.GE.1 ) .AND. ( LENGTHI.GE.1 )) THEN
+ LENGTHI2 = 2*LENGTHI
+* Copy eigenvalues into communication buffer
+ CALL DCOPY(LENGTHI,W( STARTI ),1,
+ $ WORK( INDD ), 1)
+* Copy uncertainties into communication buffer
+ CALL DCOPY(LENGTHI,WORK( IINDERR+STARTI-1 ),1,
+ $ WORK( INDD+LENGTHI ), 1)
+* send buffer
+ CALL DGESD2D( ICTXT, LENGTHI2,
+ $ 1, WORK( INDD ), LENGTHI2,
+ $ DSTROW, DSTCOL )
+ END IF
+ ELSE IF (MYPROC .EQ. 0) THEN
+ SRCROW = (I-1) / NPCOL
+ SRCCOL = MOD(I-1, NPCOL)
+ CALL IGERV2D( ICTXT, 2, 1, IWORK, 2,
+ $ SRCROW, SRCCOL )
+ STARTI = IWORK(1)
+ LENGTHI = IWORK(2)
+ IF (( STARTI.GE.1 ) .AND. ( LENGTHI.GE.1 )) THEN
+ LENGTHI2 = 2*LENGTHI
+* receive buffer
+ CALL DGERV2D( ICTXT, LENGTHI2, 1,
+ $ WORK(INDD), LENGTHI2, SRCROW, SRCCOL )
+* copy eigenvalues from communication buffer
+ CALL DCOPY( LENGTHI, WORK(INDD), 1,
+ $ W( STARTI ), 1)
+* copy uncertainties (errors) from communication buffer
+ CALL DCOPY(LENGTHI,WORK(INDD+LENGTHI),1,
+ $ WORK( IINDERR+STARTI-1 ), 1)
+ END IF
+ END IF
+ 45 CONTINUE
+ LENGTHI = IIU - IIL + 1
+ LENGTHI2 = LENGTHI * 2
+ IF (MYPROC .EQ. 0) THEN
+* Broadcast eigenvalues and errors to all processors
+ CALL DCOPY(LENGTHI,W ,1, WORK( INDD ), 1)
+ CALL DCOPY(LENGTHI,WORK( IINDERR ),1,
+ $ WORK( INDD+LENGTHI ), 1)
+ CALL DGEBS2D( ICTXT, 'A', ' ', LENGTHI2, 1,
+ $ WORK(INDD), LENGTHI2 )
+ ELSE
+ SRCROW = 0
+ SRCCOL = 0
+ CALL DGEBR2D( ICTXT, 'A', ' ', LENGTHI2, 1,
+ $ WORK(INDD), LENGTHI2, SRCROW, SRCCOL )
+ CALL DCOPY( LENGTHI, WORK(INDD), 1, W, 1)
+ CALL DCOPY(LENGTHI,WORK(INDD+LENGTHI),1,
+ $ WORK( IINDERR ), 1)
+ END IF
+ ELSE
+*
+* Enable point2point communication between collaborators
+*
+* Find collaborators of MYPROC
+ IF( (NPROCS.GT.1).AND.(MYIL.GT.0) ) THEN
+ CALL PMPCOL( MYPROC, NPROCS, IIL, NEEDIL, NEEDIU,
+ $ IWORK(INDILU), IWORK(INDILU+NPROCS),
+ $ COLBRT, FRSTCL, LASTCL )
+ ELSE
+ COLBRT = .FALSE.
+ ENDIF
+
+ IF(COLBRT) THEN
+* If the processor collaborates with others,
+* communicate information.
+ DO 47 IPROC = FRSTCL, LASTCL
+ IF (MYPROC .EQ. IPROC) THEN
+ STARTI = DOL
+ IWORK(1) = STARTI
+ LENGTHI = MYIU - MYIL + 1
+ IWORK(2) = LENGTHI
+
+ IF ((STARTI.GE.1) .AND. (LENGTHI.GE.1)) THEN
+* Copy eigenvalues into communication buffer
+ CALL DCOPY(LENGTHI,W( STARTI ),1,
+ $ WORK(INDD), 1)
+* Copy uncertainties into communication buffer
+ CALL DCOPY(LENGTHI,
+ $ WORK( IINDERR+STARTI-1 ),1,
+ $ WORK(INDD+LENGTHI), 1)
+ ENDIF
+
+ DO 46 I = FRSTCL, LASTCL
+ IF(I.EQ.MYPROC) GOTO 46
+ DSTROW = I/ NPCOL
+ DSTCOL = MOD(I, NPCOL)
+ CALL IGESD2D( ICTXT, 2, 1, IWORK, 2,
+ $ DSTROW, DSTCOL )
+ IF ((STARTI.GE.1) .AND. (LENGTHI.GE.1)) THEN
+ LENGTHI2 = 2*LENGTHI
+* send buffer
+ CALL DGESD2D( ICTXT, LENGTHI2,
+ $ 1, WORK(INDD), LENGTHI2,
+ $ DSTROW, DSTCOL )
+ END IF
+ 46 CONTINUE
+ ELSE
+ SRCROW = IPROC / NPCOL
+ SRCCOL = MOD(IPROC, NPCOL)
+ CALL IGERV2D( ICTXT, 2, 1, IWORK, 2,
+ $ SRCROW, SRCCOL )
+ RSTARTI = IWORK(1)
+ RLENGTHI = IWORK(2)
+ IF ((RSTARTI.GE.1 ) .AND. (RLENGTHI.GE.1 )) THEN
+ RLENGTHI2 = 2*RLENGTHI
+ CALL DGERV2D( ICTXT, RLENGTHI2, 1,
+ $ WORK(INDE), RLENGTHI2,
+ $ SRCROW, SRCCOL )
+* copy eigenvalues from communication buffer
+ CALL DCOPY( RLENGTHI, WORK(INDE), 1,
+ $ W( RSTARTI ), 1)
+* copy uncertainties (errors) from communication buffer
+ CALL DCOPY(RLENGTHI,WORK(INDE+RLENGTHI),1,
+ $ WORK( IINDERR+RSTARTI-1 ), 1)
+ END IF
+ END IF
+ 47 CONTINUE
+ ENDIF
+ ENDIF
+
+*
+* Part 3. Compute representation tree and eigenvectors.
+* What follows is a loop in which the tree
+* is constructed in parallel from top to bottom,
+* on level at a time, until all eigenvectors
+* have been computed.
+*
+ 100 CONTINUE
+ IF ( MYIL.GT.0 ) THEN
+ CALL DSTEGR2B( JOBZ, N, WORK( INDD2 ),
+ $ WORK( INDE2+OFFSET ),
+ $ IM, W( 1 ), WORK( INDRW ), N, N,
+ $ IWORK( 1 ), WORK( INDWORK ), SIZE1,
+ $ IWORK( 2*N+1 ), SIZE2, DOL,
+ $ DOU, NEEDIL, NEEDIU, INDWLC,
+ $ PIVMIN, SCALE, WL, WU,
+ $ VSTART, FINISH,
+ $ MAXCLS, NDEPTH, PARITY, ZOFFSET, IINFO )
+ IINDWLC = INDWORK + INDWLC - 1
+ IF(.NOT.FINISH) THEN
+ IF((NEEDIL.LT.DOL).OR.(NEEDIU.GT.DOU)) THEN
+ CALL PMPCOL( MYPROC, NPROCS, IIL, NEEDIL, NEEDIU,
+ $ IWORK(INDILU), IWORK(INDILU+NPROCS),
+ $ COLBRT, FRSTCL, LASTCL )
+ ELSE
+ COLBRT = .FALSE.
+ FRSTCL = MYPROC
+ LASTCL = MYPROC
+ ENDIF
+*
+* Check if this processor collaborates, i.e.
+* communication is needed.
+*
+ IF(COLBRT) THEN
+ DO 147 IPROC = FRSTCL, LASTCL
+ IF (MYPROC .EQ. IPROC) THEN
+ STARTI = DOL
+ IWORK(1) = STARTI
+ IF(MYIL.GT.0) THEN
+ LENGTHI = MYIU - MYIL + 1
+ ELSE
+ LENGTHI = 0
+ ENDIF
+ IWORK(2) = LENGTHI
+ IF ((STARTI.GE.1).AND.(LENGTHI.GE.1)) THEN
+* Copy eigenvalues into communication buffer
+ CALL DCOPY(LENGTHI,
+ $ WORK( IINDWLC+STARTI-1 ),1,
+ $ WORK(INDD), 1)
+* Copy uncertainties into communication buffer
+ CALL DCOPY(LENGTHI,
+ $ WORK( IINDERR+STARTI-1 ),1,
+ $ WORK(INDD+LENGTHI), 1)
+ ENDIF
+
+ DO 146 I = FRSTCL, LASTCL
+ IF(I.EQ.MYPROC) GOTO 146
+ DSTROW = I/ NPCOL
+ DSTCOL = MOD(I, NPCOL)
+ CALL IGESD2D( ICTXT, 2, 1, IWORK, 2,
+ $ DSTROW, DSTCOL )
+ IF ((STARTI.GE.1).AND.(LENGTHI.GE.1)) THEN
+ LENGTHI2 = 2*LENGTHI
+* send buffer
+ CALL DGESD2D( ICTXT, LENGTHI2,
+ $ 1, WORK(INDD), LENGTHI2,
+ $ DSTROW, DSTCOL )
+ END IF
+ 146 CONTINUE
+ ELSE
+ SRCROW = IPROC / NPCOL
+ SRCCOL = MOD(IPROC, NPCOL)
+ CALL IGERV2D( ICTXT, 2, 1, IWORK, 2,
+ $ SRCROW, SRCCOL )
+ RSTARTI = IWORK(1)
+ RLENGTHI = IWORK(2)
+ IF ((RSTARTI.GE.1).AND.(RLENGTHI.GE.1)) THEN
+ RLENGTHI2 = 2*RLENGTHI
+ CALL DGERV2D( ICTXT,RLENGTHI2, 1,
+ $ WORK(INDE),RLENGTHI2,
+ $ SRCROW, SRCCOL )
+* copy eigenvalues from communication buffer
+ CALL DCOPY(RLENGTHI, WORK(INDE), 1,
+ $ WORK( IINDWLC+RSTARTI-1 ), 1)
+* copy uncertainties (errors) from communication buffer
+ CALL DCOPY(RLENGTHI,WORK(INDE+RLENGTHI),1,
+ $ WORK( IINDERR+RSTARTI-1 ), 1)
+ END IF
+ END IF
+ 147 CONTINUE
+ ENDIF
+ GOTO 100
+ ENDIF
+ ENDIF
+ IF (IINFO .NE. 0) THEN
+ CALL PXERBLA( ICTXT, 'DSTEGR2B', -IINFO )
+ RETURN
+ END IF
+*
+ ENDIF
+
+*
+***********************************************************************
+*
+* MAIN PART ENDS HERE
+*
+***********************************************************************
+*
+***********************************************************************
+*
+* ALLGATHER: EACH PROCESSOR SENDS ITS EIGENVALUES TO THE FIRST ONE,
+* THEN THE FIRST PROCESSOR BROADCASTS ALL EIGENVALUES
+*
+***********************************************************************
+*
+ DO 50 I = 2, NPROCS
+ IF (MYPROC .EQ. (I - 1)) THEN
+ DSTROW = 0
+ DSTCOL = 0
+ STARTI = MYIL - IIL + 1
+ IWORK(1) = STARTI
+ IF(MYIL.GT.0) THEN
+ LENGTHI = MYIU - MYIL + 1
+ ELSE
+ LENGTHI = 0
+ ENDIF
+ IWORK(2) = LENGTHI
+ CALL IGESD2D( ICTXT, 2, 1, IWORK, 2,
+ $ DSTROW, DSTCOL )
+ IF ((STARTI.GE.1).AND.(LENGTHI.GE.1)) THEN
+ CALL DGESD2D( ICTXT, LENGTHI,
+ $ 1, W( STARTI ), LENGTHI,
+ $ DSTROW, DSTCOL )
+ ENDIF
+ ELSE IF (MYPROC .EQ. 0) THEN
+ SRCROW = (I-1) / NPCOL
+ SRCCOL = MOD(I-1, NPCOL)
+ CALL IGERV2D( ICTXT, 2, 1, IWORK, 2,
+ $ SRCROW, SRCCOL )
+ STARTI = IWORK(1)
+ LENGTHI = IWORK(2)
+ IF ((STARTI.GE.1).AND.(LENGTHI.GE.1)) THEN
+ CALL DGERV2D( ICTXT, LENGTHI, 1,
+ $ W( STARTI ), LENGTHI, SRCROW, SRCCOL )
+ ENDIF
+ ENDIF
+ 50 CONTINUE
+
+* Accumulate M from all processors
+ M = IM
+ CALL IGSUM2D( ICTXT, 'A', ' ', 1, 1, M, 1, -1, -1 )
+
+* Broadcast eigenvalues to all processors
+ IF (MYPROC .EQ. 0) THEN
+* Send eigenvalues
+ CALL DGEBS2D( ICTXT, 'A', ' ', M, 1, W, M )
+ ELSE
+ SRCROW = 0
+ SRCCOL = 0
+ CALL DGEBR2D( ICTXT, 'A', ' ', M, 1,
+ $ W, M, SRCROW, SRCCOL )
+ END IF
+*
+* Sort the eigenvalues and keep permutation in IWORK to
+* sort the eigenvectors accordingly
+*
+ DO 160 I = 1, M
+ IWORK( NPROCS+1+I ) = I
+ 160 CONTINUE
+ CALL DLASRT2( 'I', M, W, IWORK( NPROCS+2 ), IINFO )
+ IF (IINFO.NE.0) THEN
+ CALL PXERBLA( ICTXT, 'DLASRT2', -IINFO )
+ RETURN
+ END IF
+
+***********************************************************************
+*
+* TRANSFORM Z FROM 1D WORKSPACE INTO 2D BLOCKCYCLIC STORAGE
+*
+***********************************************************************
+ IF ( WANTZ ) THEN
+ DO 170 I = 1, M
+ IWORK( M+NPROCS+1+IWORK( NPROCS+1+I ) ) = I
+ 170 CONTINUE
+* Store NVS in IWORK(1:NPROCS+1) for PDLAEVSWP
+ IWORK( 1 ) = 0
+ DO 180 I = 1, NPROCS
+* Find IL and IU for processor i-1
+* Has already been computed by PMPIM2 and stored
+ IPIL = IWORK(INDILU+I-1)
+ IPIU = IWORK(INDILU+NPROCS+I-1)
+ IF (IPIL .EQ. 0) THEN
+ IWORK( I + 1 ) = IWORK( I )
+ ELSE
+ IWORK( I + 1 ) = IWORK( I ) + IPIU - IPIL + 1
+ ENDIF
+ 180 CONTINUE
+
+ IF ( FIRST ) THEN
+ CALL PDLAEVSWP(N, WORK( INDRW ), N, Z, IZ, JZ,
+ $ DESCZ, IWORK( 1 ), IWORK( NPROCS+M+2 ), WORK( INDWORK ),
+ $ INDRW - INDWORK )
+ ELSE
+ CALL PDLAEVSWP(N, WORK( INDRW + N ), N, Z, IZ, JZ,
+ $ DESCZ, IWORK( 1 ), IWORK( NPROCS+M+2 ), WORK( INDWORK ),
+ $ INDRW - INDWORK )
+ END IF
+*
+ NZ = M
+*
+
+***********************************************************************
+*
+* Compute eigenvectors of A from eigenvectors of T
+*
+***********************************************************************
+ IF( NZ.GT.0 ) THEN
+ CALL PDORMTR( 'L', UPLO, 'N', N, NZ, A, IA, JA, DESCA,
+ $ WORK( INDTAU ), Z, IZ, JZ, DESCZ,
+ $ WORK( INDWORK ), SIZE1, IINFO )
+ END IF
+ IF (IINFO.NE.0) THEN
+ CALL PXERBLA( ICTXT, 'PDORMTR', -IINFO )
+ RETURN
+ END IF
+*
+
+ END IF
+*
+ WORK( 1 ) = DBLE( LWOPT )
+ IWORK( 1 ) = LIWMIN
+
+ RETURN
+*
+* End of PDSYEVR
+*
+ END
diff --git a/SRC/pdsyevx.f b/SRC/pdsyevx.f
index f0d74b4..708fa07 100644
--- a/SRC/pdsyevx.f
+++ b/SRC/pdsyevx.f
@@ -594,6 +594,9 @@
RSRC_Z = DESCZ( RSRC_ )
IROFFZ = MOD( IZ-1, MB_A )
IZROW = INDXG2P( 1, NB_A, MYROW, RSRC_Z, NPROW )
+ ELSE
+ IROFFZ = 0
+ IZROW = 0
END IF
*
IF( ( .NOT.WANTZ ) .OR. ( VALEIG .AND. ( .NOT.LQUERY ) ) )
diff --git a/SRC/pdsyttrd.f b/SRC/pdsyttrd.f
index dba4a02..ac98ed6 100644
--- a/SRC/pdsyttrd.f
+++ b/SRC/pdsyttrd.f
@@ -1,10 +1,9 @@
SUBROUTINE PDSYTTRD( UPLO, N, A, IA, JA, DESCA, D, E, TAU, WORK,
$ LWORK, INFO )
*
-* -- ScaLAPACK routine (version 1.7) --
-* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
-* and University of California, Berkeley.
-* May 25, 2001
+* -- ScaLAPACK routine (version 2.0.2) --
+* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver
+* May 1 2012
*
* .. Scalar Arguments ..
CHARACTER UPLO
@@ -442,7 +441,7 @@
* .. External Subroutines ..
EXTERNAL BLACS_GRIDINFO, CHK1MAT, DCOMBNRM2, DGEBR2D,
$ DGEBS2D, DGEMM, DGEMV, DGERV2D, DGESD2D,
- $ DGSUM2D, DLACPY, DSCAL, DTRMVT, PCHK1MAT,
+ $ DGSUM2D, DLAMOV, DSCAL, DTRMVT, PCHK1MAT,
$ PDTREECOMB, PXERBLA
* ..
* .. External Functions ..
@@ -1128,10 +1127,10 @@
IF( INTERLEAVE ) THEN
LDZG = LDV / 2
ELSE
- CALL DLACPY( 'A', LTNM1, ANB, WORK( INHT+LIJP1-1 ),
+ CALL DLAMOV( 'A', LTNM1, ANB, WORK( INHT+LIJP1-1 ),
$ LDV, WORK( INVT+LIJP1-1+ANB*LDV ), LDV )
*
- CALL DLACPY( 'A', LTNM1, ANB, WORK( INV+LTLIP1-1 ),
+ CALL DLAMOV( 'A', LTNM1, ANB, WORK( INV+LTLIP1-1 ),
$ LDV, WORK( INH+LTLIP1-1+ANB*LDV ), LDV )
LDZG = LDV
END IF
diff --git a/SRC/pdtrord.f b/SRC/pdtrord.f
new file mode 100644
index 0000000..1f37d8e
--- /dev/null
+++ b/SRC/pdtrord.f
@@ -0,0 +1,3454 @@
+ SUBROUTINE PDTRORD( COMPQ, SELECT, PARA, N, T, IT, JT,
+ $ DESCT, Q, IQ, JQ, DESCQ, WR, WI, M, WORK, LWORK,
+ $ IWORK, LIWORK, INFO )
+*
+* Contribution from the Department of Computing Science and HPC2N,
+* Umea University, Sweden
+*
+* -- ScaLAPACK routine (version 2.0.2) --
+* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver
+* May 1 2012
+*
+ IMPLICIT NONE
+*
+* .. Scalar Arguments ..
+ CHARACTER COMPQ
+ INTEGER INFO, LIWORK, LWORK, M, N,
+ $ IT, JT, IQ, JQ
+* ..
+* .. Array Arguments ..
+ INTEGER SELECT( * )
+ INTEGER PARA( 6 ), DESCT( * ), DESCQ( * ), IWORK( * )
+ DOUBLE PRECISION Q( * ), T( * ), WI( * ), WORK( * ), WR( * )
+* ..
+*
+* Purpose
+* =======
+*
+* PDTRORD 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.
+*
+* T must be in Schur form (as returned by PDLAHQR), that is, block
+* upper triangular with 1-by-1 and 2-by-2 diagonal blocks.
+*
+* This subroutine uses a delay and accumulate procedure for performing
+* the off-diagonal updates (see references for details).
+*
+* Notes
+* =====
+*
+* Each global data object is described by an associated description
+* vector. This vector stores the information required to establish
+* the mapping between an object element and its corresponding process
+* and memory location.
+*
+* Let A be a generic term for any 2D block cyclicly distributed array.
+* Such a global array has an associated description vector DESCA.
+* In the following comments, the character _ should be read as
+* "of the global array".
+*
+* NOTATION STORED IN EXPLANATION
+* --------------- -------------- --------------------------------------
+* DTYPE_A(global) DESCA( DTYPE_ )The descriptor type. In this case,
+* DTYPE_A = 1.
+* CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating
+* the BLACS process grid A is distribu-
+* ted over. The context itself is glo-
+* bal, but the handle (the integer
+* value) may vary.
+* M_A (global) DESCA( M_ ) The number of rows in the global
+* array A.
+* N_A (global) DESCA( N_ ) The number of columns in the global
+* array A.
+* MB_A (global) DESCA( MB_ ) The blocking factor used to distribute
+* the rows of the array.
+* NB_A (global) DESCA( NB_ ) The blocking factor used to distribute
+* the columns of the array.
+* RSRC_A (global) DESCA( RSRC_ ) The process row over which the first
+* row of the array A is distributed.
+* CSRC_A (global) DESCA( CSRC_ ) The process column over which the
+* first column of the array A is
+* distributed.
+* LLD_A (local) DESCA( LLD_ ) The leading dimension of the local
+* array. LLD_A >= MAX(1,LOCr(M_A)).
+*
+* Let K be the number of rows or columns of a distributed matrix,
+* and assume that its process grid has dimension p x q.
+* LOCr( K ) denotes the number of elements of K that a process
+* would receive if K were distributed over the p processes of its
+* process column.
+* Similarly, LOCc( K ) denotes the number of elements of K that a
+* process would receive if K were distributed over the q processes of
+* its process row.
+* The values of LOCr() and LOCc() may be determined via a call to the
+* ScaLAPACK tool function, NUMROC:
+* LOCr( M ) = NUMROC( M, MB_A, MYROW, RSRC_A, NPROW ),
+* LOCc( N ) = NUMROC( N, NB_A, MYCOL, CSRC_A, NPCOL ).
+* An upper bound for these quantities may be computed by:
+* LOCr( M ) <= ceil( ceil(M/MB_A)/NPROW )*MB_A
+* LOCc( N ) <= ceil( ceil(N/NB_A)/NPCOL )*NB_A
+*
+* Arguments
+* =========
+*
+*
+* COMPQ (global input) CHARACTER*1
+* = 'V': update the matrix Q of Schur vectors;
+* = 'N': do not update Q.
+*
+* SELECT (global input/output) INTEGER array, dimension (N)
+* SELECT specifies the eigenvalues in the selected cluster. To
+* select a real eigenvalue w(j), SELECT(j) must be set to 1.
+* 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 1;
+* a complex conjugate pair of eigenvalues must be
+* either both included in the cluster or both excluded.
+* On output, the (partial) reordering is displayed.
+*
+* PARA (global input) INTEGER*6
+* Block parameters (some should be replaced by calls to
+* PILAENV and others by meaningful default values):
+* PARA(1) = maximum number of concurrent computational windows
+* allowed in the algorithm;
+* 0 < PARA(1) <= min(NPROW,NPCOL) must hold;
+* PARA(2) = number of eigenvalues in each window;
+* 0 < PARA(2) < PARA(3) must hold;
+* PARA(3) = window size; PARA(2) < PARA(3) < DESCT(MB_)
+* must hold;
+* PARA(4) = minimal percentage of flops required for
+* performing matrix-matrix multiplications instead
+* of pipelined orthogonal transformations;
+* 0 <= PARA(4) <= 100 must hold;
+* PARA(5) = width of block column slabs for row-wise
+* application of pipelined orthogonal
+* transformations in their factorized form;
+* 0 < PARA(5) <= DESCT(MB_) must hold.
+* PARA(6) = the maximum number of eigenvalues moved together
+* over a process border; in practice, this will be
+* approximately half of the cross border window size
+* 0 < PARA(6) <= PARA(2) must hold;
+*
+* N (global input) INTEGER
+* The order of the globally distributed matrix T. N >= 0.
+*
+* T (local input/output) DOUBLE PRECISION array,
+* dimension (LLD_T,LOCc(N)).
+* On entry, the local pieces of the global distributed
+* upper quasi-triangular matrix T, in Schur form. On exit, T is
+* overwritten by the local pieces of the reordered matrix T,
+* again in Schur form, with the selected eigenvalues in the
+* globally leading diagonal blocks.
+*
+* IT (global input) INTEGER
+* JT (global input) INTEGER
+* The row and column index in the global array T indicating the
+* first column of sub( T ). IT = JT = 1 must hold.
+*
+* DESCT (global and local input) INTEGER array of dimension DLEN_.
+* The array descriptor for the global distributed matrix T.
+*
+* Q (local input/output) DOUBLE PRECISION array,
+* dimension (LLD_Q,LOCc(N)).
+* On entry, if COMPQ = 'V', the local pieces of the global
+* distributed matrix Q of Schur vectors.
+* On exit, if COMPQ = 'V', Q has been postmultiplied by the
+* global 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.
+*
+* IQ (global input) INTEGER
+* JQ (global input) INTEGER
+* The column index in the global array Q indicating the
+* first column of sub( Q ). IQ = JQ = 1 must hold.
+*
+* DESCQ (global and local input) INTEGER array of dimension DLEN_.
+* The array descriptor for the global distributed matrix Q.
+*
+* WR (global output) DOUBLE PRECISION array, dimension (N)
+* WI (global output) DOUBLE PRECISION array, dimension (N)
+* The real and imaginary parts, respectively, of the reordered
+* eigenvalues of T. The eigenvalues are in principle 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 also that if a complex eigenvalue is sufficiently
+* ill-conditioned, then its value may differ significantly
+* from its value before reordering.
+*
+* M (global output) INTEGER
+* The dimension of the specified invariant subspace.
+* 0 <= M <= N.
+*
+* WORK (local workspace/output) DOUBLE PRECISION array,
+* dimension (LWORK)
+* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*
+* LWORK (local input) 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 PXERBLA.
+*
+* IWORK (local workspace/output) INTEGER array, dimension (LIWORK)
+*
+* LIWORK (local input) INTEGER
+* The dimension of the array IWORK.
+*
+* 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 PXERBLA.
+*
+* INFO (global output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value.
+* If the i-th argument is an array and the j-entry had
+* an illegal value, then INFO = -(i*1000+j), if the i-th
+* argument is a scalar and had an illegal value, then INFO = -i.
+* > 0: here we have several possibilites
+* *) 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.
+* On exit, INFO = {the index of T where the swap failed}.
+* *) A 2-by-2 block to be reordered split into two 1-by-1
+* blocks and the second block failed to swap with an
+* adjacent block.
+* On exit, INFO = {the index of T where the swap failed}.
+* *) If INFO = N+1, there is no valid BLACS context (see the
+* BLACS documentation for details).
+* In a future release this subroutine may distinguish between
+* the case 1 and 2 above.
+*
+* Additional requirements
+* =======================
+*
+* The following alignment requirements must hold:
+* (a) DESCT( MB_ ) = DESCT( NB_ ) = DESCQ( MB_ ) = DESCQ( NB_ )
+* (b) DESCT( RSRC_ ) = DESCQ( RSRC_ )
+* (c) DESCT( CSRC_ ) = DESCQ( CSRC_ )
+*
+* All matrices must be blocked by a block factor larger than or
+* equal to two (3). This is to simplify reordering across processor
+* borders in the presence of 2-by-2 blocks.
+*
+* Limitations
+* ===========
+*
+* This algorithm cannot work on submatrices of T and Q, i.e.,
+* IT = JT = IQ = JQ = 1 must hold. This is however no limitation
+* since PDLAHQR does not compute Schur forms of submatrices anyway.
+*
+* References
+* ==========
+*
+* [1] Z. Bai and J. W. Demmel; On swapping diagonal blocks in real
+* Schur form, Linear Algebra Appl., 186:73--95, 1993. Also as
+* LAPACK Working Note 54.
+*
+* [2] D. Kressner; Block algorithms for reordering standard and
+* generalized Schur forms, ACM TOMS, 32(4):521-532, 2006.
+* Also LAPACK Working Note 171.
+*
+* [3] R. Granat, B. Kagstrom, and D. Kressner; Parallel eigenvalue
+* reordering in real Schur form, Concurrency and Computations:
+* Practice and Experience, 21(9):1225-1250, 2009. Also as
+* LAPACK Working Note 192.
+*
+* Parallel execution recommendations
+* ==================================
+*
+* Use a square grid, if possible, for maximum performance. The block
+* parameters in PARA should be kept well below the data distribution
+* block size. In particular, see [3] for recommended settings for
+* these parameters.
+*
+* In general, the parallel algorithm strives to perform as much work
+* as possible without crossing the block borders on the main block
+* diagonal.
+*
+* Contributors
+* ============
+*
+* Implemented by Robert Granat, Dept. of Computing Science and HPC2N,
+* Umea University, Sweden, March 2007,
+* in collaboration with Bo Kagstrom and Daniel Kressner.
+* Modified by Meiyue Shao, October 2011.
+*
+* Revisions
+* =========
+*
+* Please send bug-reports to granat at cs.umu.se
+*
+* Keywords
+* ========
+*
+* Real Schur form, eigenvalue reordering
+*
+* =====================================================================
+* ..
+* .. Parameters ..
+ CHARACTER TOP
+ INTEGER BLOCK_CYCLIC_2D, CSRC_, CTXT_, DLEN_, DTYPE_,
+ $ LLD_, MB_, M_, NB_, N_, RSRC_
+ DOUBLE PRECISION ZERO, ONE
+ PARAMETER ( TOP = '1-Tree',
+ $ BLOCK_CYCLIC_2D = 1, DLEN_ = 9, DTYPE_ = 1,
+ $ CTXT_ = 2, M_ = 3, N_ = 4, MB_ = 5, NB_ = 6,
+ $ RSRC_ = 7, CSRC_ = 8, LLD_ = 9,
+ $ ZERO = 0.0D+0, ONE = 1.0D+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL LQUERY, PAIR, SWAP, WANTQ,
+ $ ISHH, FIRST, SKIP1CR, BORDER, LASTWAIT
+ INTEGER NPROW, NPCOL, MYROW, MYCOL, NB, NPROCS,
+ $ IERR, DIM1, INDX, LLDT, TRSRC, TCSRC, ILOC1,
+ $ JLOC1, MYIERR, ICTXT,
+ $ RSRC1, CSRC1, ILOC3, JLOC3, TRSRC3,
+ $ TCSRC3, ILOC, JLOC, TRSRC4, TCSRC4,
+ $ FLOPS, I, ILO, IHI, J, K, KK, KKS,
+ $ KS, LIWMIN, LWMIN, MMULT, N1, N2,
+ $ NCB, NDTRAF, NITRAF, NWIN, NUMWIN, PDTRAF,
+ $ PITRAF, PDW, WINEIG, WINSIZ, LLDQ,
+ $ RSRC, CSRC, ILILO, ILIHI, ILSEL, IRSRC,
+ $ ICSRC, IPIW, IPW1, IPW2, IPW3, TIHI, TILO,
+ $ LIHI, WINDOW, LILO, LSEL, BUFFER,
+ $ NMWIN2, BUFFLEN, LROWS, LCOLS, ILOC2, JLOC2,
+ $ WNEICR, WINDOW0, RSRC4, CSRC4, LIHI4, RSRC3,
+ $ CSRC3, RSRC2, CSRC2, LIHIC, LIHI1, ILEN4,
+ $ SELI4, ILEN1, DIM4, IPW4, QROWS, TROWS,
+ $ TCOLS, IPW5, IPW6, IPW7, IPW8, JLOC4,
+ $ EAST, WEST, ILOC4, SOUTH, NORTH, INDXS,
+ $ ITT, JTT, ILEN, DLEN, INDXE, TRSRC1, TCSRC1,
+ $ TRSRC2, TCSRC2, ILOS, DIR, TLIHI, TLILO, TLSEL,
+ $ ROUND, LAST, WIN0S, WIN0E, WINE, MMAX, MMIN
+ DOUBLE PRECISION ELEM, ELEM1, ELEM2, ELEM3, ELEM4, SN, CS, TMP,
+ $ ELEM5
+* ..
+* .. Local Arrays ..
+ INTEGER IBUFF( 8 ), IDUM1( 1 ), IDUM2( 1 )
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ INTEGER NUMROC, INDXG2P, INDXG2L
+ EXTERNAL LSAME, NUMROC, INDXG2P, INDXG2L
+* ..
+* .. External Subroutines ..
+ EXTERNAL PDLACPY, PXERBLA, PCHK1MAT, PCHK2MAT,
+ $ DGEMM, DLAMOV, ILACPY, CHK1MAT,
+ $ INFOG2L, DGSUM2D, DGESD2D, DGERV2D, DGEBS2D,
+ $ DGEBR2D, IGSUM2D, BLACS_GRIDINFO, IGEBS2D,
+ $ IGEBR2D, IGAMX2D, IGAMN2D, BDLAAPP, BDTREXC
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX, SQRT, MIN
+* ..
+* .. Local Functions ..
+ INTEGER ICEIL
+* ..
+* .. Executable Statements ..
+*
+* Get grid parameters.
+*
+ ICTXT = DESCT( CTXT_ )
+ CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL )
+ NPROCS = NPROW*NPCOL
+*
+* Test if grid is O.K., i.e., the context is valid.
+*
+ INFO = 0
+ IF( NPROW.EQ.-1 ) THEN
+ INFO = N+1
+ END IF
+*
+* Check if workspace query.
+*
+ LQUERY = LWORK.EQ.-1 .OR. LIWORK.EQ.-1
+*
+* Test dimensions for local sanity.
+*
+ IF( INFO.EQ.0 ) THEN
+ CALL CHK1MAT( N, 5, N, 5, IT, JT, DESCT, 9, INFO )
+ END IF
+ IF( INFO.EQ.0 ) THEN
+ CALL CHK1MAT( N, 5, N, 5, IQ, JQ, DESCQ, 13, INFO )
+ END IF
+*
+* Check the blocking sizes for alignment requirements.
+*
+ IF( INFO.EQ.0 ) THEN
+ IF( DESCT( MB_ ).NE.DESCT( NB_ ) ) INFO = -(1000*9 + MB_)
+ END IF
+ IF( INFO.EQ.0 ) THEN
+ IF( DESCQ( MB_ ).NE.DESCQ( NB_ ) ) INFO = -(1000*13 + MB_)
+ END IF
+ IF( INFO.EQ.0 ) THEN
+ IF( DESCT( MB_ ).NE.DESCQ( MB_ ) ) INFO = -(1000*9 + MB_)
+ END IF
+*
+* Check the blocking sizes for minimum sizes.
+*
+ IF( INFO.EQ.0 ) THEN
+ IF( N.NE.DESCT( MB_ ) .AND. DESCT( MB_ ).LT.3 )
+ $ INFO = -(1000*9 + MB_)
+ IF( N.NE.DESCQ( MB_ ) .AND. DESCQ( MB_ ).LT.3 )
+ $ INFO = -(1000*13 + MB_)
+ END IF
+*
+* Check parameters in PARA.
+*
+ NB = DESCT( MB_ )
+ IF( INFO.EQ.0 ) THEN
+ IF( PARA(1).LT.1 .OR. PARA(1).GT.MIN(NPROW,NPCOL) )
+ $ INFO = -(1000 * 4 + 1)
+ IF( PARA(2).LT.1 .OR. PARA(2).GE.PARA(3) )
+ $ INFO = -(1000 * 4 + 2)
+ IF( PARA(3).LT.1 .OR. PARA(3).GT.NB )
+ $ INFO = -(1000 * 4 + 3)
+ IF( PARA(4).LT.0 .OR. PARA(4).GT.100 )
+ $ INFO = -(1000 * 4 + 4)
+ IF( PARA(5).LT.1 .OR. PARA(5).GT.NB )
+ $ INFO = -(1000 * 4 + 5)
+ IF( PARA(6).LT.1 .OR. PARA(6).GT.PARA(2) )
+ $ INFO = -(1000 * 4 + 6)
+ END IF
+*
+* Check requirements on IT, JT, IQ and JQ.
+*
+ IF( INFO.EQ.0 ) THEN
+ IF( IT.NE.1 ) INFO = -6
+ IF( JT.NE.IT ) INFO = -7
+ IF( IQ.NE.1 ) INFO = -10
+ IF( JQ.NE.IQ ) INFO = -11
+ END IF
+*
+* Test input parameters for global sanity.
+*
+ IF( INFO.EQ.0 ) THEN
+ CALL PCHK1MAT( N, 5, N, 5, IT, JT, DESCT, 9, 0, IDUM1,
+ $ IDUM2, INFO )
+ END IF
+ IF( INFO.EQ.0 ) THEN
+ CALL PCHK1MAT( N, 5, N, 5, IQ, JQ, DESCQ, 13, 0, IDUM1,
+ $ IDUM2, INFO )
+ END IF
+ IF( INFO.EQ.0 ) THEN
+ CALL PCHK2MAT( N, 5, N, 5, IT, JT, DESCT, 9, N, 5, N, 5,
+ $ IQ, JQ, DESCQ, 13, 0, IDUM1, IDUM2, INFO )
+ END IF
+*
+* Decode and test the input parameters.
+*
+ IF( INFO.EQ.0 .OR. LQUERY ) THEN
+*
+ WANTQ = LSAME( COMPQ, 'V' )
+ IF( N.LT.0 ) THEN
+ INFO = -4
+ ELSE
+*
+* Extract local leading dimension.
+*
+ LLDT = DESCT( LLD_ )
+ LLDQ = DESCQ( LLD_ )
+*
+* Check the SELECT vector for consistency and set M to the
+* dimension of the specified invariant subspace.
+*
+ M = 0
+ DO 10 K = 1, N
+ IF( K.LT.N ) THEN
+ CALL INFOG2L( K+1, K, DESCT, NPROW, NPCOL,
+ $ MYROW, MYCOL, ITT, JTT, TRSRC, TCSRC )
+ IF( MYROW.EQ.TRSRC .AND. MYCOL.EQ.TCSRC ) THEN
+ ELEM = T( (JTT-1)*LLDT + ITT )
+ IF( ELEM.NE.ZERO ) THEN
+ IF( SELECT(K).NE.0 .AND.
+ $ SELECT(K+1).EQ.0 ) THEN
+* INFO = -2
+ SELECT(K+1) = 1
+ ELSEIF( SELECT(K).EQ.0 .AND.
+ $ SELECT(K+1).NE.0 ) THEN
+* INFO = -2
+ SELECT(K) = 1
+ END IF
+ END IF
+ END IF
+ END IF
+ IF( SELECT(K).NE.0 ) M = M + 1
+ 10 CONTINUE
+ MMAX = M
+ MMIN = M
+ IF( NPROCS.GT.1 )
+ $ CALL IGAMX2D( ICTXT, 'All', TOP, 1, 1, MMAX, 1, -1,
+ $ -1, -1, -1, -1 )
+ IF( NPROCS.GT.1 )
+ $ CALL IGAMN2D( ICTXT, 'All', TOP, 1, 1, MMIN, 1, -1,
+ $ -1, -1, -1, -1 )
+ IF( MMAX.GT.MMIN ) THEN
+ M = MMAX
+ IF( NPROCS.GT.1 )
+ $ CALL IGAMX2D( ICTXT, 'All', TOP, N, 1, SELECT, N,
+ $ -1, -1, -1, -1, -1 )
+ END IF
+*
+* Compute needed workspace.
+*
+ N1 = M
+ N2 = N - M
+*
+ TROWS = NUMROC( N, NB, MYROW, DESCT(RSRC_), NPROW )
+ TCOLS = NUMROC( N, NB, MYCOL, DESCT(CSRC_), NPCOL )
+ LWMIN = N + 7*NB**2 + 2*TROWS*PARA( 3 ) + TCOLS*PARA( 3 ) +
+ $ MAX( TROWS*PARA( 3 ), TCOLS*PARA( 3 ) )
+ LIWMIN = 5*PARA( 1 ) + PARA( 2 )*PARA( 3 ) -
+ $ PARA( 2 ) * ( PARA( 2 ) + 1 ) / 2
+*
+ 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
+ END IF
+*
+* Global maximum on info.
+*
+ IF( NPROCS.GT.1 )
+ $ CALL IGAMX2D( ICTXT, 'All', TOP, 1, 1, INFO, 1, -1, -1, -1,
+ $ -1, -1 )
+*
+* Return if some argument is incorrect.
+*
+ IF( INFO.NE.0 .AND. .NOT.LQUERY ) THEN
+ M = 0
+ CALL PXERBLA( ICTXT, 'PDTRORD', -INFO )
+ RETURN
+ ELSEIF( LQUERY ) THEN
+ WORK( 1 ) = DBLE(LWMIN)
+ IWORK( 1 ) = LIWMIN
+ RETURN
+ END IF
+*
+* Quick return if possible.
+*
+ IF( M.EQ.N .OR. M.EQ.0 ) GO TO 545
+*
+* Set parameters.
+*
+ NUMWIN = PARA( 1 )
+ WINEIG = MAX( PARA( 2 ), 2 )
+ WINSIZ = MIN( MAX( PARA( 3 ), PARA( 2 )*2 ), NB )
+ MMULT = PARA( 4 )
+ NCB = PARA( 5 )
+ WNEICR = PARA( 6 )
+*
+* Insert some pointers into INTEGER workspace.
+*
+* Information about all the active windows is stored
+* in IWORK( 1:5*NUMWIN ). Each processor has a copy.
+* LILO: start position
+* LIHI: stop position
+* LSEL: number of selected eigenvalues
+* RSRC: processor id (row)
+* CSRC: processor id (col)
+* IWORK( IPIW+ ) contain information of orthogonal transformations.
+*
+ ILILO = 1
+ ILIHI = ILILO + NUMWIN
+ ILSEL = ILIHI + NUMWIN
+ IRSRC = ILSEL + NUMWIN
+ ICSRC = IRSRC + NUMWIN
+ IPIW = ICSRC + NUMWIN
+*
+* Insert some pointers into DOUBLE PRECISION workspace - for now we
+* only need two pointers.
+*
+ IPW1 = 1
+ IPW2 = IPW1 + NB
+*
+* Collect the selected blocks at the top-left corner of T.
+*
+* Globally: ignore eigenvalues that are already in order.
+* ILO is a global variable and is kept updated to be consistent
+* throughout the process mesh.
+*
+ ILO = 0
+ 40 CONTINUE
+ ILO = ILO + 1
+ IF( ILO.LE.N ) THEN
+ IF( SELECT(ILO).NE.0 ) GO TO 40
+ END IF
+*
+* Globally: start the collection at the top of the matrix. Here,
+* IHI is a global variable and is kept updated to be consistent
+* throughout the process mesh.
+*
+ IHI = N
+*
+* Globally: While ( ILO <= M ) do
+ 50 CONTINUE
+*
+ IF( ILO.LE.M ) THEN
+*
+* Depending on the value of ILO, find the diagonal block index J,
+* such that T(1+(J-1)*NB:1+J*NB,1+(J-1)*NB:1+J*NB) contains the
+* first unsorted eigenvalue. Check that J does not point to a
+* block with only one selected eigenvalue in the last position
+* which belongs to a splitted 2-by-2 block.
+*
+ ILOS = ILO - 1
+ 52 CONTINUE
+ ILOS = ILOS + 1
+ IF( SELECT(ILOS).EQ.0 ) GO TO 52
+ IF( ILOS.LT.N ) THEN
+ IF( SELECT(ILOS+1).NE.0 .AND. MOD(ILOS,NB).EQ.0 ) THEN
+ CALL PDELGET( 'All', TOP, ELEM, T, ILOS+1, ILOS, DESCT )
+ IF( ELEM.NE.ZERO ) GO TO 52
+ END IF
+ END IF
+ J = ICEIL(ILOS,NB)
+*
+* Globally: Set start values of LILO and LIHI for all processes.
+* Choose also the number of selected eigenvalues at top of each
+* diagonal block such that the number of eigenvalues which remain
+* to be reordered is an integer multiple of WINEIG.
+*
+* All the information is saved into the INTEGER workspace such
+* that all processors are aware of each others operations.
+*
+* Compute the number of concurrent windows.
+*
+ NMWIN2 = (ICEIL(IHI,NB)*NB - (ILO-MOD(ILO,NB)+1)+1) / NB
+ NMWIN2 = MIN( MIN( NUMWIN, NMWIN2 ), ICEIL(N,NB) - J + 1 )
+*
+* For all windows, set LSEL = 0 and find a proper start value of
+* LILO such that LILO points at the first non-selected entry in
+* the corresponding diagonal block of T.
+*
+ DO 80 K = 1, NMWIN2
+ IWORK( ILSEL+K-1) = 0
+ IWORK( ILILO+K-1) = MAX( ILO, (J-1)*NB+(K-1)*NB+1 )
+ LILO = IWORK( ILILO+K-1 )
+ 82 CONTINUE
+ IF( SELECT(LILO).NE.0 .AND. LILO.LT.(J+K-1)*NB ) THEN
+ LILO = LILO + 1
+ IF( LILO.LE.N ) GO TO 82
+ END IF
+ IWORK( ILILO+K-1 ) = LILO
+*
+* Fix each LILO to ensure that no 2-by-2 block is cut in top
+* of the submatrix (LILO:LIHI,LILO:LIHI).
+*
+ LILO = IWORK(ILILO+K-1)
+ IF( LILO.GT.NB ) THEN
+ CALL PDELGET( 'All', TOP, ELEM, T, LILO, LILO-1, DESCT )
+ IF( ELEM.NE.ZERO ) THEN
+ IF( LILO.LT.(J+K-1)*NB ) THEN
+ IWORK(ILILO+K-1) = IWORK(ILILO+K-1) + 1
+ ELSE
+ IWORK(ILILO+K-1) = IWORK(ILILO+K-1) - 1
+ END IF
+ END IF
+ END IF
+*
+* Set a proper LIHI value for each window. Also find the
+* processors corresponding to the corresponding windows.
+*
+ IWORK( ILIHI+K-1 ) = IWORK( ILILO+K-1 )
+ IWORK( IRSRC+K-1 ) = INDXG2P( IWORK(ILILO+K-1), NB, MYROW,
+ $ DESCT( RSRC_ ), NPROW )
+ IWORK( ICSRC+K-1 ) = INDXG2P( IWORK(ILILO+K-1), NB, MYCOL,
+ $ DESCT( CSRC_ ), NPCOL )
+ TILO = IWORK(ILILO+K-1)
+ TIHI = MIN( N, ICEIL( TILO, NB ) * NB )
+ DO 90 KK = TIHI, TILO, -1
+ IF( SELECT(KK).NE.0 ) THEN
+ IWORK(ILIHI+K-1) = MAX(IWORK(ILIHI+K-1) , KK )
+ IWORK(ILSEL+K-1) = IWORK(ILSEL+K-1) + 1
+ IF( IWORK(ILSEL+K-1).GT.WINEIG ) THEN
+ IWORK(ILIHI+K-1) = KK
+ IWORK(ILSEL+K-1) = 1
+ END IF
+ END IF
+ 90 CONTINUE
+*
+* Fix each LIHI to avoid that bottom of window cuts 2-by-2
+* block. We exclude such a block if located on block (process)
+* border and on window border or if an inclusion would cause
+* violation on the maximum number of eigenvalues to reorder
+* inside each window. If only on window border, we include it.
+* The excluded block is included automatically later when a
+* subcluster is reordered into the block from South-East.
+*
+ LIHI = IWORK(ILIHI+K-1)
+ IF( LIHI.LT.N ) THEN
+ CALL PDELGET( 'All', TOP, ELEM, T, LIHI+1, LIHI, DESCT )
+ IF( ELEM.NE.ZERO ) THEN
+ IF( ICEIL( LIHI, NB ) .NE. ICEIL( LIHI+1, NB ) .OR.
+ $ IWORK( ILSEL+K-1 ).EQ.WINEIG ) THEN
+ IWORK( ILIHI+K-1 ) = IWORK( ILIHI+K-1 ) - 1
+ IF( IWORK( ILSEL+K-1 ).GT.2 )
+ $ IWORK( ILSEL+K-1 ) = IWORK( ILSEL+K-1 ) - 1
+ ELSE
+ IWORK( ILIHI+K-1 ) = IWORK( ILIHI+K-1 ) + 1
+ IF( SELECT(LIHI+1).NE.0 )
+ $ IWORK( ILSEL+K-1 ) = IWORK( ILSEL+K-1 ) + 1
+ END IF
+ END IF
+ END IF
+ 80 CONTINUE
+*
+* Fix the special cases of LSEL = 0 and LILO = LIHI for each
+* window by assuring that the stop-condition for local reordering
+* is fulfilled directly. Do this by setting LIHI = startposition
+* for the corresponding block and LILO = LIHI + 1.
+*
+ DO 85 K = 1, NMWIN2
+ LILO = IWORK( ILILO + K - 1 )
+ LIHI = IWORK( ILIHI + K - 1 )
+ LSEL = IWORK( ILSEL + K - 1 )
+ IF( LSEL.EQ.0 .OR. LILO.EQ.LIHI ) THEN
+ LIHI = IWORK( ILIHI + K - 1 )
+ IWORK( ILIHI + K - 1 ) = (ICEIL(LIHI,NB)-1)*NB + 1
+ IWORK( ILILO + K - 1 ) = IWORK( ILIHI + K - 1 ) + 1
+ END IF
+ 85 CONTINUE
+*
+* Associate all processors with the first computational window
+* that should be activated, if possible.
+*
+ LILO = IHI
+ LIHI = ILO
+ LSEL = M
+ FIRST = .TRUE.
+ DO 95 WINDOW = 1, NMWIN2
+ RSRC = IWORK(IRSRC+WINDOW-1)
+ CSRC = IWORK(ICSRC+WINDOW-1)
+ IF( MYROW.EQ.RSRC .OR. MYCOL.EQ.CSRC ) THEN
+ TLILO = IWORK( ILILO + WINDOW - 1 )
+ TLIHI = IWORK( ILIHI + WINDOW - 1 )
+ TLSEL = IWORK( ILSEL + WINDOW - 1 )
+ IF( (.NOT. ( LIHI .GE. LILO + LSEL ) ) .AND.
+ $ ( (TLIHI .GE. TLILO + TLSEL) .OR. FIRST ) ) THEN
+ IF( FIRST ) FIRST = .FALSE.
+ LILO = TLILO
+ LIHI = TLIHI
+ LSEL = TLSEL
+ GO TO 97
+ END IF
+ END IF
+ 95 CONTINUE
+ 97 CONTINUE
+*
+* Exclude all processors that are not involved in any
+* computational window right now.
+*
+ IERR = 0
+ IF( LILO.EQ.IHI .AND. LIHI.EQ.ILO .AND. LSEL.EQ.M )
+ $ GO TO 114
+*
+* Make sure all processors associated with a compuational window
+* enter the local reordering the first time.
+*
+ FIRST = .TRUE.
+*
+* Globally for all computational windows:
+* While ( LIHI >= LILO + LSEL ) do
+ ROUND = 1
+ 130 CONTINUE
+ IF( FIRST .OR. ( LIHI .GE. LILO + LSEL ) ) THEN
+*
+* Perform computations in parallel: loop through all
+* compuational windows, do local reordering and accumulate
+* transformations, broadcast them in the corresponding block
+* row and columns and compute the corresponding updates.
+*
+ DO 110 WINDOW = 1, NMWIN2
+ RSRC = IWORK(IRSRC+WINDOW-1)
+ CSRC = IWORK(ICSRC+WINDOW-1)
+*
+* The process on the block diagonal computes the
+* reordering.
+*
+ IF( MYROW.EQ.RSRC .AND. MYCOL.EQ.CSRC ) THEN
+ LILO = IWORK(ILILO+WINDOW-1)
+ LIHI = IWORK(ILIHI+WINDOW-1)
+ LSEL = IWORK(ILSEL+WINDOW-1)
+*
+* Compute the local value of I -- start position.
+*
+ I = MAX( LILO, LIHI - WINSIZ + 1 )
+*
+* Fix my I to avoid that top of window cuts a 2-by-2
+* block.
+*
+ IF( I.GT.LILO ) THEN
+ CALL INFOG2L( I, I-1, DESCT, NPROW, NPCOL, MYROW,
+ $ MYCOL, ILOC, JLOC, RSRC, CSRC )
+ IF( T( LLDT*(JLOC-1) + ILOC ).NE.ZERO )
+ $ I = I + 1
+ END IF
+*
+* Compute local indicies for submatrix to operate on.
+*
+ CALL INFOG2L( I, I, DESCT, NPROW, NPCOL,
+ $ MYROW, MYCOL, ILOC1, JLOC1, RSRC, CSRC )
+*
+* The active window is ( I:LIHI, I:LIHI ). Reorder
+* eigenvalues within this window and pipeline
+* transformations.
+*
+ NWIN = LIHI - I + 1
+ KS = 0
+ PITRAF = IPIW
+ PDTRAF = IPW2
+*
+ PAIR = .FALSE.
+ DO 140 K = I, LIHI
+ IF( PAIR ) THEN
+ PAIR = .FALSE.
+ ELSE
+ SWAP = SELECT( K ).NE.0
+ IF( K.LT.LIHI ) THEN
+ CALL INFOG2L( K+1, K, DESCT, NPROW, NPCOL,
+ $ MYROW, MYCOL, ILOC, JLOC, RSRC, CSRC )
+ IF( T( LLDT*(JLOC-1) + ILOC ).NE.ZERO )
+ $ PAIR = .TRUE.
+ END IF
+ IF( SWAP ) THEN
+ KS = KS + 1
+*
+* Swap the K-th block to position I+KS-1.
+*
+ IERR = 0
+ KK = K - I + 1
+ KKS = KS
+ IF( KK.NE.KS ) THEN
+ NITRAF = LIWORK - PITRAF + 1
+ NDTRAF = LWORK - PDTRAF + 1
+ CALL BDTREXC( NWIN,
+ $ T(LLDT*(JLOC1-1) + ILOC1), LLDT, KK,
+ $ KKS, NITRAF, IWORK( PITRAF ), NDTRAF,
+ $ WORK( PDTRAF ), WORK(IPW1), IERR )
+ PITRAF = PITRAF + NITRAF
+ PDTRAF = PDTRAF + NDTRAF
+*
+* Update array SELECT.
+*
+ IF ( PAIR ) THEN
+ DO 150 J = I+KK-1, I+KKS, -1
+ SELECT(J+1) = SELECT(J-1)
+ 150 CONTINUE
+ SELECT(I+KKS-1) = 1
+ SELECT(I+KKS) = 1
+ ELSE
+ DO 160 J = I+KK-1, I+KKS, -1
+ SELECT(J) = SELECT(J-1)
+ 160 CONTINUE
+ SELECT(I+KKS-1) = 1
+ END IF
+*
+ IF ( IERR.EQ.1 .OR. IERR.EQ.2 ) THEN
+*
+* Some blocks are too close to swap:
+* prepare to leave in a clean fashion. If
+* IERR.EQ.2, we must update SELECT to
+* account for the fact that the 2 by 2
+* block to be reordered did split and the
+* first part of this block is already
+* reordered.
+*
+ IF ( IERR.EQ.2 ) THEN
+ SELECT( I+KKS-3 ) = 1
+ SELECT( I+KKS-1 ) = 0
+ KKS = KKS + 1
+ END IF
+*
+* Update off-diagonal blocks immediately.
+*
+ GO TO 170
+ END IF
+ KS = KKS
+ END IF
+ IF( PAIR )
+ $ KS = KS + 1
+ END IF
+ END IF
+ 140 CONTINUE
+ END IF
+ 110 CONTINUE
+ 170 CONTINUE
+*
+* The on-diagonal processes save their information from the
+* local reordering in the integer buffer. This buffer is
+* broadcasted to updating processors, see below.
+*
+ DO 175 WINDOW = 1, NMWIN2
+ RSRC = IWORK(IRSRC+WINDOW-1)
+ CSRC = IWORK(ICSRC+WINDOW-1)
+ IF( MYROW.EQ.RSRC .AND. MYCOL.EQ.CSRC ) THEN
+ IBUFF( 1 ) = I
+ IBUFF( 2 ) = NWIN
+ IBUFF( 3 ) = PITRAF
+ IBUFF( 4 ) = KS
+ IBUFF( 5 ) = PDTRAF
+ IBUFF( 6 ) = NDTRAF
+ ILEN = PITRAF - IPIW
+ DLEN = PDTRAF - IPW2
+ IBUFF( 7 ) = ILEN
+ IBUFF( 8 ) = DLEN
+ END IF
+ 175 CONTINUE
+*
+* For the updates with respect to the local reordering, we
+* organize the updates in two phases where the update
+* "direction" (controlled by the DIR variable below) is first
+* chosen to be the corresponding rows, then the corresponding
+* columns.
+*
+ DO 1111 DIR = 1, 2
+*
+* Broadcast information about the reordering and the
+* accumulated transformations: I, NWIN, PITRAF, NITRAF,
+* PDTRAF, NDTRAF. If no broadcast is performed, use an
+* artificial value of KS to prevent updating indicies for
+* windows already finished (use KS = -1).
+*
+ DO 111 WINDOW = 1, NMWIN2
+ RSRC = IWORK(IRSRC+WINDOW-1)
+ CSRC = IWORK(ICSRC+WINDOW-1)
+ IF( MYROW.EQ.RSRC .OR. MYCOL.EQ.CSRC ) THEN
+ LILO = IWORK(ILILO+WINDOW-1)
+ LIHI = IWORK(ILIHI+WINDOW-1)
+ LSEL = IWORK(ILSEL+WINDOW-1)
+ END IF
+ IF( MYROW.EQ.RSRC .AND. MYCOL.EQ.CSRC ) THEN
+ IF( NPCOL.GT.1 .AND. DIR.EQ.1 )
+ $ CALL IGEBS2D( ICTXT, 'Row', TOP, 8, 1, IBUFF, 8 )
+ IF( NPROW.GT.1 .AND. DIR.EQ.2 )
+ $ CALL IGEBS2D( ICTXT, 'Col', TOP, 8, 1, IBUFF, 8 )
+ ELSEIF( MYROW.EQ.RSRC .OR. MYCOL.EQ.CSRC ) THEN
+ IF( NPCOL.GT.1 .AND. DIR.EQ.1 .AND. MYROW.EQ.RSRC )
+ $ THEN
+ IF( FIRST .OR. (LIHI .GE. LILO + LSEL) ) THEN
+ CALL IGEBR2D( ICTXT, 'Row', TOP, 8, 1, IBUFF, 8,
+ $ RSRC, CSRC )
+ I = IBUFF( 1 )
+ NWIN = IBUFF( 2 )
+ PITRAF = IBUFF( 3 )
+ KS = IBUFF( 4 )
+ PDTRAF = IBUFF( 5 )
+ NDTRAF = IBUFF( 6 )
+ ILEN = IBUFF( 7 )
+ DLEN = IBUFF( 8 )
+ ELSE
+ ILEN = 0
+ DLEN = 0
+ KS = -1
+ END IF
+ END IF
+ IF( NPROW.GT.1 .AND. DIR.EQ.2 .AND. MYCOL.EQ.CSRC )
+ $ THEN
+ IF( FIRST .OR. (LIHI .GE. LILO + LSEL) ) THEN
+ CALL IGEBR2D( ICTXT, 'Col', TOP, 8, 1, IBUFF, 8,
+ $ RSRC, CSRC )
+ I = IBUFF( 1 )
+ NWIN = IBUFF( 2 )
+ PITRAF = IBUFF( 3 )
+ KS = IBUFF( 4 )
+ PDTRAF = IBUFF( 5 )
+ NDTRAF = IBUFF( 6 )
+ ILEN = IBUFF( 7 )
+ DLEN = IBUFF( 8 )
+ ELSE
+ ILEN = 0
+ DLEN = 0
+ KS = -1
+ END IF
+ END IF
+ END IF
+*
+* Broadcast the accumulated transformations - copy all
+* information from IWORK(IPIW:PITRAF-1) and
+* WORK(IPW2:PDTRAF-1) to a buffer and broadcast this
+* buffer in the corresponding block row and column. On
+* arrival, copy the information back to the correct part of
+* the workspace. This step is avoided if no computations
+* were performed at the diagonal processor, i.e.,
+* BUFFLEN = 0.
+*
+ IF( MYROW.EQ.RSRC .AND. MYCOL.EQ.CSRC ) THEN
+ BUFFER = PDTRAF
+ BUFFLEN = DLEN + ILEN
+ IF( BUFFLEN.NE.0 ) THEN
+ DO 180 INDX = 1, ILEN
+ WORK( BUFFER+INDX-1 ) =
+ $ DBLE( IWORK(IPIW+INDX-1) )
+ 180 CONTINUE
+ CALL DLAMOV( 'All', DLEN, 1, WORK( IPW2 ),
+ $ DLEN, WORK(BUFFER+ILEN), DLEN )
+ IF( NPCOL.GT.1 .AND. DIR.EQ.1 ) THEN
+ CALL DGEBS2D( ICTXT, 'Row', TOP, BUFFLEN, 1,
+ $ WORK(BUFFER), BUFFLEN )
+ END IF
+ IF( NPROW.GT.1 .AND. DIR.EQ.2 ) THEN
+ CALL DGEBS2D( ICTXT, 'Col', TOP, BUFFLEN, 1,
+ $ WORK(BUFFER), BUFFLEN )
+ END IF
+ END IF
+ ELSEIF( MYROW.EQ.RSRC .OR. MYCOL.EQ.CSRC ) THEN
+ IF( NPCOL.GT.1 .AND. DIR.EQ.1 .AND. MYROW.EQ.RSRC )
+ $ THEN
+ BUFFER = PDTRAF
+ BUFFLEN = DLEN + ILEN
+ IF( BUFFLEN.NE.0 ) THEN
+ CALL DGEBR2D( ICTXT, 'Row', TOP, BUFFLEN, 1,
+ $ WORK(BUFFER), BUFFLEN, RSRC, CSRC )
+ END IF
+ END IF
+ IF( NPROW.GT.1 .AND. DIR.EQ.2 .AND. MYCOL.EQ.CSRC )
+ $ THEN
+ BUFFER = PDTRAF
+ BUFFLEN = DLEN + ILEN
+ IF( BUFFLEN.NE.0 ) THEN
+ CALL DGEBR2D( ICTXT, 'Col', TOP, BUFFLEN, 1,
+ $ WORK(BUFFER), BUFFLEN, RSRC, CSRC )
+ END IF
+ END IF
+ IF((NPCOL.GT.1.AND.DIR.EQ.1.AND.MYROW.EQ.RSRC).OR.
+ $ (NPROW.GT.1.AND.DIR.EQ.2.AND.MYCOL.EQ.CSRC ) )
+ $ THEN
+ IF( BUFFLEN.NE.0 ) THEN
+ DO 190 INDX = 1, ILEN
+ IWORK(IPIW+INDX-1) =
+ $ INT(WORK( BUFFER+INDX-1 ))
+ 190 CONTINUE
+ CALL DLAMOV( 'All', DLEN, 1,
+ $ WORK( BUFFER+ILEN ), DLEN,
+ $ WORK( IPW2 ), DLEN )
+ END IF
+ END IF
+ END IF
+ 111 CONTINUE
+*
+* Now really perform the updates by applying the orthogonal
+* transformations to the out-of-window parts of T and Q. This
+* step is avoided if no reordering was performed by the on-
+* diagonal processor from the beginning, i.e., BUFFLEN = 0.
+*
+* Count number of operations to decide whether to use
+* matrix-matrix multiplications for updating off-diagonal
+* parts or not.
+*
+ DO 112 WINDOW = 1, NMWIN2
+ RSRC = IWORK(IRSRC+WINDOW-1)
+ CSRC = IWORK(ICSRC+WINDOW-1)
+*
+ IF( (MYROW.EQ.RSRC .AND. DIR.EQ.1 ).OR.
+ $ (MYCOL.EQ.CSRC .AND. DIR.EQ.2 ) ) THEN
+ LILO = IWORK(ILILO+WINDOW-1)
+ LIHI = IWORK(ILIHI+WINDOW-1)
+ LSEL = IWORK(ILSEL+WINDOW-1)
+*
+* Skip update part for current WINDOW if BUFFLEN = 0.
+*
+ IF( BUFFLEN.EQ.0 ) GO TO 295
+*
+ NITRAF = PITRAF - IPIW
+ ISHH = .FALSE.
+ FLOPS = 0
+ DO 200 K = 1, NITRAF
+ IF( IWORK( IPIW + K - 1 ).LE.NWIN ) THEN
+ FLOPS = FLOPS + 6
+ ELSE
+ FLOPS = FLOPS + 11
+ ISHH = .TRUE.
+ END IF
+ 200 CONTINUE
+*
+* Compute amount of work space necessary for performing
+* matrix-matrix multiplications.
+*
+ PDW = BUFFER
+ IPW3 = PDW + NWIN*NWIN
+ ELSE
+ FLOPS = 0
+ END IF
+*
+ IF( FLOPS.NE.0 .AND.
+ $ ( FLOPS*100 ) / ( 2*NWIN*NWIN ) .GE. MMULT ) THEN
+*
+* Update off-diagonal blocks and Q using matrix-matrix
+* multiplications; if there are no Householder
+* reflectors it is preferable to take the triangular
+* block structure of the transformation matrix into
+* account.
+*
+ CALL DLASET( 'All', NWIN, NWIN, ZERO, ONE,
+ $ WORK( PDW ), NWIN )
+ CALL BDLAAPP( 1, NWIN, NWIN, NCB, WORK( PDW ), NWIN,
+ $ NITRAF, IWORK(IPIW), WORK( IPW2 ), WORK(IPW3) )
+*
+ IF( ISHH ) THEN
+*
+* Loop through the local blocks of the distributed
+* matrices T and Q and update them according to the
+* performed reordering.
+*
+* Update the columns of T and Q affected by the
+* reordering.
+*
+ IF( DIR.EQ.2 ) THEN
+ DO 210 INDX = 1, I-1, NB
+ CALL INFOG2L( INDX, I, DESCT, NPROW, NPCOL,
+ $ MYROW, MYCOL, ILOC, JLOC, RSRC1, CSRC1 )
+ IF( MYROW.EQ.RSRC1 .AND. MYCOL.EQ.CSRC1 )
+ $ THEN
+ LROWS = MIN(NB,I-INDX)
+ CALL DGEMM( 'No transpose',
+ $ 'No transpose', LROWS, NWIN, NWIN,
+ $ ONE, T((JLOC-1)*LLDT+ILOC), LLDT,
+ $ WORK( PDW ), NWIN, ZERO,
+ $ WORK(IPW3), LROWS )
+ CALL DLAMOV( 'All', LROWS, NWIN,
+ $ WORK(IPW3), LROWS,
+ $ T((JLOC-1)*LLDT+ILOC), LLDT )
+ END IF
+ 210 CONTINUE
+ IF( WANTQ ) THEN
+ DO 220 INDX = 1, N, NB
+ CALL INFOG2L( INDX, I, DESCQ, NPROW,
+ $ NPCOL, MYROW, MYCOL, ILOC, JLOC,
+ $ RSRC1, CSRC1 )
+ IF( MYROW.EQ.RSRC1.AND.MYCOL.EQ.CSRC1 )
+ $ THEN
+ LROWS = MIN(NB,N-INDX+1)
+ CALL DGEMM( 'No transpose',
+ $ 'No transpose', LROWS, NWIN, NWIN,
+ $ ONE, Q((JLOC-1)*LLDQ+ILOC), LLDQ,
+ $ WORK( PDW ), NWIN, ZERO,
+ $ WORK(IPW3), LROWS )
+ CALL DLAMOV( 'All', LROWS, NWIN,
+ $ WORK(IPW3), LROWS,
+ $ Q((JLOC-1)*LLDQ+ILOC), LLDQ )
+ END IF
+ 220 CONTINUE
+ END IF
+ END IF
+*
+* Update the rows of T affected by the reordering
+*
+ IF( DIR.EQ.1 ) THEN
+ IF( LIHI.LT.N ) THEN
+ IF( MOD(LIHI,NB).GT.0 ) THEN
+ INDX = LIHI + 1
+ CALL INFOG2L( I, INDX, DESCT, NPROW,
+ $ NPCOL, MYROW, MYCOL, ILOC, JLOC,
+ $ RSRC1, CSRC1 )
+ IF( MYROW.EQ.RSRC1.AND.MYCOL.EQ.CSRC1 )
+ $ THEN
+ LCOLS = MOD( MIN( NB-MOD(LIHI,NB),
+ $ N-LIHI ), NB )
+ CALL DGEMM( 'Transpose',
+ $ 'No Transpose', NWIN, LCOLS, NWIN,
+ $ ONE, WORK( PDW ), NWIN,
+ $ T((JLOC-1)*LLDT+ILOC), LLDT, ZERO,
+ $ WORK(IPW3), NWIN )
+ CALL DLAMOV( 'All', NWIN, LCOLS,
+ $ WORK(IPW3), NWIN,
+ $ T((JLOC-1)*LLDT+ILOC), LLDT )
+ END IF
+ END IF
+ INDXS = ICEIL(LIHI,NB)*NB + 1
+ DO 230 INDX = INDXS, N, NB
+ CALL INFOG2L( I, INDX, DESCT, NPROW,
+ $ NPCOL, MYROW, MYCOL, ILOC, JLOC,
+ $ RSRC1, CSRC1 )
+ IF( MYROW.EQ.RSRC1.AND.MYCOL.EQ.CSRC1 )
+ $ THEN
+ LCOLS = MIN( NB, N-INDX+1 )
+ CALL DGEMM( 'Transpose',
+ $ 'No Transpose', NWIN, LCOLS, NWIN,
+ $ ONE, WORK( PDW ), NWIN,
+ $ T((JLOC-1)*LLDT+ILOC), LLDT, ZERO,
+ $ WORK(IPW3), NWIN )
+ CALL DLAMOV( 'All', NWIN, LCOLS,
+ $ WORK(IPW3), NWIN,
+ $ T((JLOC-1)*LLDT+ILOC), LLDT )
+ END IF
+ 230 CONTINUE
+ END IF
+ END IF
+ ELSE
+*
+* The NWIN-by-NWIN matrix U containing the
+* accumulated orthogonal transformations has the
+* following structure:
+*
+* [ U11 U12 ]
+* U = [ ],
+* [ U21 U22 ]
+*
+* where U21 is KS-by-KS upper triangular and U12 is
+* (NWIN-KS)-by-(NWIN-KS) lower triangular.
+*
+* Update the columns of T and Q affected by the
+* reordering.
+*
+* Compute T2*U21 + T1*U11 in workspace.
+*
+ IF( DIR.EQ.2 ) THEN
+ DO 240 INDX = 1, I-1, NB
+ CALL INFOG2L( INDX, I, DESCT, NPROW, NPCOL,
+ $ MYROW, MYCOL, ILOC, JLOC, RSRC1, CSRC1 )
+ IF( MYROW.EQ.RSRC1 .AND. MYCOL.EQ.CSRC1 )
+ $ THEN
+ JLOC1 = INDXG2L( I+NWIN-KS, NB, MYCOL,
+ $ DESCT( CSRC_ ), NPCOL )
+ LROWS = MIN(NB,I-INDX)
+ CALL DLAMOV( 'All', LROWS, KS,
+ $ T((JLOC1-1)*LLDT+ILOC ), LLDT,
+ $ WORK(IPW3), LROWS )
+ CALL DTRMM( 'Right', 'Upper',
+ $ 'No transpose',
+ $ 'Non-unit', LROWS, KS, ONE,
+ $ WORK( PDW+NWIN-KS ), NWIN,
+ $ WORK(IPW3), LROWS )
+ CALL DGEMM( 'No transpose',
+ $ 'No transpose', LROWS, KS, NWIN-KS,
+ $ ONE, T((JLOC-1)*LLDT+ILOC), LLDT,
+ $ WORK( PDW ), NWIN, ONE, WORK(IPW3),
+ $ LROWS )
+*
+* Compute T1*U12 + T2*U22 in workspace.
+*
+ CALL DLAMOV( 'All', LROWS, NWIN-KS,
+ $ T((JLOC-1)*LLDT+ILOC), LLDT,
+ $ WORK( IPW3+KS*LROWS ), LROWS )
+ CALL DTRMM( 'Right', 'Lower',
+ $ 'No transpose', 'Non-unit',
+ $ LROWS, NWIN-KS, ONE,
+ $ WORK( PDW+NWIN*KS ), NWIN,
+ $ WORK( IPW3+KS*LROWS ), LROWS )
+ CALL DGEMM( 'No transpose',
+ $ 'No transpose', LROWS, NWIN-KS, KS,
+ $ ONE, T((JLOC1-1)*LLDT+ILOC), LLDT,
+ $ WORK( PDW+NWIN*KS+NWIN-KS ), NWIN,
+ $ ONE, WORK( IPW3+KS*LROWS ), LROWS )
+*
+* Copy workspace to T.
+*
+ CALL DLAMOV( 'All', LROWS, NWIN,
+ $ WORK(IPW3), LROWS,
+ $ T((JLOC-1)*LLDT+ILOC), LLDT )
+ END IF
+ 240 CONTINUE
+ IF( WANTQ ) THEN
+*
+* Compute Q2*U21 + Q1*U11 in workspace.
+*
+ DO 250 INDX = 1, N, NB
+ CALL INFOG2L( INDX, I, DESCQ, NPROW,
+ $ NPCOL, MYROW, MYCOL, ILOC, JLOC,
+ $ RSRC1, CSRC1 )
+ IF( MYROW.EQ.RSRC1.AND.MYCOL.EQ.CSRC1 )
+ $ THEN
+ JLOC1 = INDXG2L( I+NWIN-KS, NB,
+ $ MYCOL, DESCQ( CSRC_ ), NPCOL )
+ LROWS = MIN(NB,N-INDX+1)
+ CALL DLAMOV( 'All', LROWS, KS,
+ $ Q((JLOC1-1)*LLDQ+ILOC ), LLDQ,
+ $ WORK(IPW3), LROWS )
+ CALL DTRMM( 'Right', 'Upper',
+ $ 'No transpose', 'Non-unit',
+ $ LROWS, KS, ONE,
+ $ WORK( PDW+NWIN-KS ), NWIN,
+ $ WORK(IPW3), LROWS )
+ CALL DGEMM( 'No transpose',
+ $ 'No transpose', LROWS, KS,
+ $ NWIN-KS, ONE,
+ $ Q((JLOC-1)*LLDQ+ILOC), LLDQ,
+ $ WORK( PDW ), NWIN, ONE,
+ $ WORK(IPW3), LROWS )
+*
+* Compute Q1*U12 + Q2*U22 in workspace.
+*
+ CALL DLAMOV( 'All', LROWS, NWIN-KS,
+ $ Q((JLOC-1)*LLDQ+ILOC), LLDQ,
+ $ WORK( IPW3+KS*LROWS ), LROWS)
+ CALL DTRMM( 'Right', 'Lower',
+ $ 'No transpose', 'Non-unit',
+ $ LROWS, NWIN-KS, ONE,
+ $ WORK( PDW+NWIN*KS ), NWIN,
+ $ WORK( IPW3+KS*LROWS ), LROWS)
+ CALL DGEMM( 'No transpose',
+ $ 'No transpose', LROWS, NWIN-KS,
+ $ KS, ONE, Q((JLOC1-1)*LLDQ+ILOC),
+ $ LLDQ, WORK(PDW+NWIN*KS+NWIN-KS),
+ $ NWIN, ONE, WORK( IPW3+KS*LROWS ),
+ $ LROWS )
+*
+* Copy workspace to Q.
+*
+ CALL DLAMOV( 'All', LROWS, NWIN,
+ $ WORK(IPW3), LROWS,
+ $ Q((JLOC-1)*LLDQ+ILOC), LLDQ )
+ END IF
+ 250 CONTINUE
+ END IF
+ END IF
+*
+ IF( DIR.EQ.1 ) THEN
+ IF ( LIHI.LT.N ) THEN
+*
+* Compute U21**T*T2 + U11**T*T1 in workspace.
+*
+ IF( MOD(LIHI,NB).GT.0 ) THEN
+ INDX = LIHI + 1
+ CALL INFOG2L( I, INDX, DESCT, NPROW,
+ $ NPCOL, MYROW, MYCOL, ILOC, JLOC,
+ $ RSRC1, CSRC1 )
+ IF( MYROW.EQ.RSRC1.AND.MYCOL.EQ.CSRC1 )
+ $ THEN
+ ILOC1 = INDXG2L( I+NWIN-KS, NB, MYROW,
+ $ DESCT( RSRC_ ), NPROW )
+ LCOLS = MOD( MIN( NB-MOD(LIHI,NB),
+ $ N-LIHI ), NB )
+ CALL DLAMOV( 'All', KS, LCOLS,
+ $ T((JLOC-1)*LLDT+ILOC1), LLDT,
+ $ WORK(IPW3), NWIN )
+ CALL DTRMM( 'Left', 'Upper',
+ $ 'Transpose', 'Non-unit', KS,
+ $ LCOLS, ONE, WORK( PDW+NWIN-KS ),
+ $ NWIN, WORK(IPW3), NWIN )
+ CALL DGEMM( 'Transpose',
+ $ 'No transpose', KS, LCOLS,
+ $ NWIN-KS, ONE, WORK(PDW), NWIN,
+ $ T((JLOC-1)*LLDT+ILOC), LLDT, ONE,
+ $ WORK(IPW3), NWIN )
+*
+* Compute U12**T*T1 + U22**T*T2 in
+* workspace.
+*
+ CALL DLAMOV( 'All', NWIN-KS, LCOLS,
+ $ T((JLOC-1)*LLDT+ILOC), LLDT,
+ $ WORK( IPW3+KS ), NWIN )
+ CALL DTRMM( 'Left', 'Lower',
+ $ 'Transpose', 'Non-unit',
+ $ NWIN-KS, LCOLS, ONE,
+ $ WORK( PDW+NWIN*KS ), NWIN,
+ $ WORK( IPW3+KS ), NWIN )
+ CALL DGEMM( 'Transpose',
+ $ 'No Transpose', NWIN-KS, LCOLS,
+ $ KS, ONE,
+ $ WORK( PDW+NWIN*KS+NWIN-KS ),
+ $ NWIN, T((JLOC-1)*LLDT+ILOC1),
+ $ LLDT, ONE, WORK( IPW3+KS ),
+ $ NWIN )
+*
+* Copy workspace to T.
+*
+ CALL DLAMOV( 'All', NWIN, LCOLS,
+ $ WORK(IPW3), NWIN,
+ $ T((JLOC-1)*LLDT+ILOC), LLDT )
+ END IF
+ END IF
+ INDXS = ICEIL(LIHI,NB)*NB + 1
+ DO 260 INDX = INDXS, N, NB
+ CALL INFOG2L( I, INDX, DESCT, NPROW,
+ $ NPCOL, MYROW, MYCOL, ILOC, JLOC,
+ $ RSRC1, CSRC1 )
+ IF( MYROW.EQ.RSRC1.AND.MYCOL.EQ.CSRC1 )
+ $ THEN
+*
+* Compute U21**T*T2 + U11**T*T1 in
+* workspace.
+*
+ ILOC1 = INDXG2L( I+NWIN-KS, NB,
+ $ MYROW, DESCT( RSRC_ ), NPROW )
+ LCOLS = MIN( NB, N-INDX+1 )
+ CALL DLAMOV( 'All', KS, LCOLS,
+ $ T((JLOC-1)*LLDT+ILOC1), LLDT,
+ $ WORK(IPW3), NWIN )
+ CALL DTRMM( 'Left', 'Upper',
+ $ 'Transpose', 'Non-unit', KS,
+ $ LCOLS, ONE,
+ $ WORK( PDW+NWIN-KS ), NWIN,
+ $ WORK(IPW3), NWIN )
+ CALL DGEMM( 'Transpose',
+ $ 'No transpose', KS, LCOLS,
+ $ NWIN-KS, ONE, WORK(PDW), NWIN,
+ $ T((JLOC-1)*LLDT+ILOC), LLDT, ONE,
+ $ WORK(IPW3), NWIN )
+*
+* Compute U12**T*T1 + U22**T*T2 in
+* workspace.
+*
+ CALL DLAMOV( 'All', NWIN-KS, LCOLS,
+ $ T((JLOC-1)*LLDT+ILOC), LLDT,
+ $ WORK( IPW3+KS ), NWIN )
+ CALL DTRMM( 'Left', 'Lower',
+ $ 'Transpose', 'Non-unit',
+ $ NWIN-KS, LCOLS, ONE,
+ $ WORK( PDW+NWIN*KS ), NWIN,
+ $ WORK( IPW3+KS ), NWIN )
+ CALL DGEMM( 'Transpose',
+ $ 'No Transpose', NWIN-KS, LCOLS,
+ $ KS, ONE,
+ $ WORK( PDW+NWIN*KS+NWIN-KS ),
+ $ NWIN, T((JLOC-1)*LLDT+ILOC1),
+ $ LLDT, ONE, WORK(IPW3+KS), NWIN )
+*
+* Copy workspace to T.
+*
+ CALL DLAMOV( 'All', NWIN, LCOLS,
+ $ WORK(IPW3), NWIN,
+ $ T((JLOC-1)*LLDT+ILOC), LLDT )
+ END IF
+ 260 CONTINUE
+ END IF
+ END IF
+ END IF
+ ELSEIF( FLOPS.NE.0 ) THEN
+*
+* Update off-diagonal blocks and Q using the pipelined
+* elementary transformations.
+*
+ IF( DIR.EQ.2 ) THEN
+ DO 270 INDX = 1, I-1, NB
+ CALL INFOG2L( INDX, I, DESCT, NPROW, NPCOL,
+ $ MYROW, MYCOL, ILOC, JLOC, RSRC1, CSRC1 )
+ IF( MYROW.EQ.RSRC1 .AND. MYCOL.EQ.CSRC1 ) THEN
+ LROWS = MIN(NB,I-INDX)
+ CALL BDLAAPP( 1, LROWS, NWIN, NCB,
+ $ T((JLOC-1)*LLDT+ILOC ), LLDT, NITRAF,
+ $ IWORK(IPIW), WORK( IPW2 ),
+ $ WORK(IPW3) )
+ END IF
+ 270 CONTINUE
+ IF( WANTQ ) THEN
+ DO 280 INDX = 1, N, NB
+ CALL INFOG2L( INDX, I, DESCQ, NPROW, NPCOL,
+ $ MYROW, MYCOL, ILOC, JLOC, RSRC1, CSRC1 )
+ IF( MYROW.EQ.RSRC1 .AND. MYCOL.EQ.CSRC1 )
+ $ THEN
+ LROWS = MIN(NB,N-INDX+1)
+ CALL BDLAAPP( 1, LROWS, NWIN, NCB,
+ $ Q((JLOC-1)*LLDQ+ILOC), LLDQ, NITRAF,
+ $ IWORK(IPIW), WORK( IPW2 ),
+ $ WORK(IPW3) )
+ END IF
+ 280 CONTINUE
+ END IF
+ END IF
+ IF( DIR.EQ.1 ) THEN
+ IF( LIHI.LT.N ) THEN
+ IF( MOD(LIHI,NB).GT.0 ) THEN
+ INDX = LIHI + 1
+ CALL INFOG2L( I, INDX, DESCT, NPROW, NPCOL,
+ $ MYROW, MYCOL, ILOC, JLOC, RSRC1, CSRC1 )
+ IF( MYROW.EQ.RSRC1 .AND. MYCOL.EQ.CSRC1 )
+ $ THEN
+ LCOLS = MOD( MIN( NB-MOD(LIHI,NB),
+ $ N-LIHI ), NB )
+ CALL BDLAAPP( 0, NWIN, LCOLS, NCB,
+ $ T((JLOC-1)*LLDT+ILOC), LLDT, NITRAF,
+ $ IWORK(IPIW), WORK( IPW2 ),
+ $ WORK(IPW3) )
+ END IF
+ END IF
+ INDXS = ICEIL(LIHI,NB)*NB + 1
+ DO 290 INDX = INDXS, N, NB
+ CALL INFOG2L( I, INDX, DESCT, NPROW, NPCOL,
+ $ MYROW, MYCOL, ILOC, JLOC, RSRC1, CSRC1 )
+ IF( MYROW.EQ.RSRC1 .AND. MYCOL.EQ.CSRC1 )
+ $ THEN
+ LCOLS = MIN( NB, N-INDX+1 )
+ CALL BDLAAPP( 0, NWIN, LCOLS, NCB,
+ $ T((JLOC-1)*LLDT+ILOC), LLDT, NITRAF,
+ $ IWORK(IPIW), WORK( IPW2 ),
+ $ WORK(IPW3) )
+ END IF
+ 290 CONTINUE
+ END IF
+ END IF
+ END IF
+*
+* If I was not involved in the updates for the current
+* window or the window was fully processed, I go here and
+* try again for the next window.
+*
+ 295 CONTINUE
+*
+* Update LIHI and LIHI depending on the number of
+* eigenvalues really moved - for on-diagonal processes we
+* do this update only once since each on-diagonal process
+* is only involved with one window at one time. The
+* indicies are updated in three cases:
+* 1) When some reordering was really performed
+* -- indicated by BUFFLEN > 0.
+* 2) When no selected eigenvalues was found in the
+* current window -- indicated by KS = 0.
+* 3) When some selected eigenvalues was found in the
+* current window but no one of them was moved
+* (KS > 0 and BUFFLEN = 0)
+* False index updating is avoided by sometimes setting
+* KS = -1. This will affect processors involved in more
+* than one window and where the first one ends up with
+* KS = 0 and for the second one is done already.
+*
+ IF( MYROW.EQ.RSRC.AND.MYCOL.EQ.CSRC ) THEN
+ IF( DIR.EQ.2 ) THEN
+ IF( BUFFLEN.NE.0 .OR. KS.EQ.0 .OR.
+ $ ( BUFFLEN.EQ.0 .AND. KS.GT.0 ) )
+ $ LIHI = I + KS - 1
+ IWORK( ILIHI+WINDOW-1 ) = LIHI
+ IF( .NOT. LIHI.GE.LILO+LSEL ) THEN
+ LILO = LILO + LSEL
+ IWORK( ILILO+WINDOW-1 ) = LILO
+ END IF
+ END IF
+ ELSEIF( MYROW.EQ.RSRC .AND. DIR.EQ.1 ) THEN
+ IF( BUFFLEN.NE.0 .OR. KS.EQ.0 .OR.
+ $ ( BUFFLEN.EQ.0 .AND. KS.GT.0 ) )
+ $ LIHI = I + KS - 1
+ IWORK( ILIHI+WINDOW-1 ) = LIHI
+ IF( .NOT. LIHI.GE.LILO+LSEL ) THEN
+ LILO = LILO + LSEL
+ IWORK( ILILO+WINDOW-1 ) = LILO
+ END IF
+ ELSEIF( MYCOL.EQ.CSRC .AND. DIR.EQ.2 ) THEN
+ IF( BUFFLEN.NE.0 .OR. KS.EQ.0 .OR.
+ $ ( BUFFLEN.EQ.0 .AND. KS.GT.0 ) )
+ $ LIHI = I + KS - 1
+ IWORK( ILIHI+WINDOW-1 ) = LIHI
+ IF( .NOT. LIHI.GE.LILO+LSEL ) THEN
+ LILO = LILO + LSEL
+ IWORK( ILILO+WINDOW-1 ) = LILO
+ END IF
+ END IF
+*
+ 112 CONTINUE
+*
+* End of direction loop for updates with respect to local
+* reordering.
+*
+ 1111 CONTINUE
+*
+* Associate each process with one of the corresponding
+* computational windows such that the test for another round
+* of local reordering is carried out properly. Since the
+* column updates were computed after the row updates, it is
+* sufficient to test for changing the association to the
+* window in the corresponding process row.
+*
+ DO 113 WINDOW = 1, NMWIN2
+ RSRC = IWORK( IRSRC + WINDOW - 1 )
+ IF( MYROW.EQ.RSRC .AND. (.NOT. LIHI.GE.LILO+LSEL ) ) THEN
+ LILO = IWORK( ILILO + WINDOW - 1 )
+ LIHI = IWORK( ILIHI + WINDOW - 1 )
+ LSEL = IWORK( ILSEL + WINDOW - 1 )
+ END IF
+ 113 CONTINUE
+*
+* End While ( LIHI >= LILO + LSEL )
+ ROUND = ROUND + 1
+ IF( FIRST ) FIRST = .FALSE.
+ GO TO 130
+ END IF
+*
+* All processors excluded from the local reordering go here.
+*
+ 114 CONTINUE
+*
+* Barrier to collect the processes before proceeding.
+*
+ CALL BLACS_BARRIER( ICTXT, 'All' )
+*
+* Compute global maximum of IERR so that we know if some process
+* experienced a failure in the reordering.
+*
+ MYIERR = IERR
+ IF( NPROCS.GT.1 )
+ $ CALL IGAMX2D( ICTXT, 'All', TOP, 1, 1, IERR, 1, -1,
+ $ -1, -1, -1, -1 )
+*
+ IF( IERR.NE.0 ) THEN
+*
+* When calling BDTREXC, the block at position I+KKS-1 failed
+* to swap.
+*
+ IF( MYIERR.NE.0 ) INFO = MAX(1,I+KKS-1)
+ IF( NPROCS.GT.1 )
+ $ CALL IGAMX2D( ICTXT, 'All', TOP, 1, 1, INFO, 1, -1,
+ $ -1, -1, -1, -1 )
+ GO TO 300
+ END IF
+*
+* Now, for each compuational window, move the selected
+* eigenvalues across the process border. Do this by forming the
+* processors into groups of four working together to bring the
+* window over the border. The processes are numbered as follows
+*
+* 1 | 2
+* --+--
+* 3 | 4
+*
+* where '|' and '-' denotes the process (and block) borders.
+* This implies that the cluster to be reordered over the border
+* is held by process 4, process 1 will receive the cluster after
+* the reordering, process 3 holds the local (2,1)th element of a
+* 2-by-2 diagonal block located on the block border and process 2
+* holds the closest off-diagonal part of the window that is
+* affected by the cross-border reordering.
+*
+* The active window is now ( I : LIHI[4], I : LIHI[4] ), where
+* I = MAX( ILO, LIHI - 2*MOD(LIHI,NB) ). If this active window is
+* too large compared to the value of PARA( 6 ), it will be
+* truncated in both ends such that a maximum of PARA( 6 )
+* eigenvalues is reordered across the border this time.
+*
+* The active window will be collected and built in workspace at
+* process 1 and 4, which both compute the reordering and return
+* the updated parts to the corresponding processes 2-3. Next, the
+* accumulated transformations are broadcasted for updates in the
+* block rows and column that corresponds to the process rows and
+* columns where process 1 and 4 reside.
+*
+* The off-diagonal blocks are updated by the processes receiving
+* from the broadcasts of the orthogonal transformations. Since
+* the active window is split over the process borders, the
+* updates of T and Q requires that stripes of block rows of
+* columns are exchanged between neighboring processes in the
+* corresponding process rows and columns.
+*
+* First, form each group of processors involved in the
+* crossborder reordering. Do this in two (or three) phases:
+* 1) Reorder each odd window over the border.
+* 2) Reorder each even window over the border.
+* 3) Reorder the last odd window over the border, if it was not
+* processed in the first phase.
+*
+* When reordering the odd windows over the border, we must make
+* sure that no process row or column is involved in both the
+* first and the last window at the same time. This happens when
+* the total number of windows is odd, greater than one and equal
+* to the minumum process mesh dimension. Therefore the last odd
+* window may be reordered over the border at last.
+*
+ LASTWAIT = NMWIN2.GT.1 .AND. MOD(NMWIN2,2).EQ.1 .AND.
+ $ NMWIN2.EQ.MIN(NPROW,NPCOL)
+*
+ LAST = 0
+ 308 CONTINUE
+ IF( LASTWAIT ) THEN
+ IF( LAST.EQ.0 ) THEN
+ WIN0S = 1
+ WIN0E = 2
+ WINE = NMWIN2 - 1
+ ELSE
+ WIN0S = NMWIN2
+ WIN0E = NMWIN2
+ WINE = NMWIN2
+ END IF
+ ELSE
+ WIN0S = 1
+ WIN0E = 2
+ WINE = NMWIN2
+ END IF
+ DO 310 WINDOW0 = WIN0S, WIN0E
+ DO 320 WINDOW = WINDOW0, WINE, 2
+*
+* Define the process holding the down-right part of the
+* window.
+*
+ RSRC4 = IWORK(IRSRC+WINDOW-1)
+ CSRC4 = IWORK(ICSRC+WINDOW-1)
+*
+* Define the other processes in the group of four.
+*
+ RSRC3 = RSRC4
+ CSRC3 = MOD( CSRC4 - 1 + NPCOL, NPCOL )
+ RSRC2 = MOD( RSRC4 - 1 + NPROW, NPROW )
+ CSRC2 = CSRC4
+ RSRC1 = RSRC2
+ CSRC1 = CSRC3
+ IF( ( MYROW.EQ.RSRC1 .AND. MYCOL.EQ.CSRC1 ) .OR.
+ $ ( MYROW.EQ.RSRC2 .AND. MYCOL.EQ.CSRC2 ) .OR.
+ $ ( MYROW.EQ.RSRC3 .AND. MYCOL.EQ.CSRC3 ) .OR.
+ $ ( MYROW.EQ.RSRC4 .AND. MYCOL.EQ.CSRC4 ) ) THEN
+*
+* Compute the correct active window - for reordering
+* into a block that has not been active at all before,
+* we try to reorder as many of our eigenvalues over the
+* border as possible without knowing of the situation on
+* the other side - this may cause very few eigenvalues
+* to be reordered over the border this time (perhaps not
+* any) but this should be an initial problem. Anyway,
+* the bottom-right position of the block will be at
+* position LIHIC.
+*
+ IF( MYROW.EQ.RSRC4 .AND. MYCOL.EQ.CSRC4 ) THEN
+ LIHI4 = ( IWORK( ILILO + WINDOW - 1 ) +
+ $ IWORK( ILIHI + WINDOW - 1 ) ) / 2
+ LIHIC = MIN(LIHI4,(ICEIL(LIHI4,NB)-1)*NB+WNEICR)
+*
+* Fix LIHIC to avoid that bottom of window cuts
+* 2-by-2 block and make sure all processors in the
+* group knows about the correct value.
+*
+ IF( (.NOT. LIHIC.LE.NB) .AND. LIHIC.LT.N ) THEN
+ ILOC = INDXG2L( LIHIC+1, NB, MYROW,
+ $ DESCT( RSRC_ ), NPROW )
+ JLOC = INDXG2L( LIHIC, NB, MYCOL,
+ $ DESCT( CSRC_ ), NPCOL )
+ IF( T( (JLOC-1)*LLDT+ILOC ).NE.ZERO ) THEN
+ IF( MOD( LIHIC, NB ).EQ.1 .OR.
+ $ ( MOD( LIHIC, NB ).EQ.2 .AND.
+ $ SELECT(LIHIC-2).EQ.0 ) )
+ $ THEN
+ LIHIC = LIHIC + 1
+ ELSE
+ LIHIC = LIHIC - 1
+ END IF
+ END IF
+ END IF
+ IF( RSRC4.NE.RSRC1 .OR. CSRC4.NE.CSRC1 )
+ $ CALL IGESD2D( ICTXT, 1, 1, LIHIC, 1, RSRC1,
+ $ CSRC1 )
+ IF( RSRC4.NE.RSRC2 .OR. CSRC4.NE.CSRC2 )
+ $ CALL IGESD2D( ICTXT, 1, 1, LIHIC, 1, RSRC2,
+ $ CSRC2 )
+ IF( RSRC4.NE.RSRC3 .OR. CSRC4.NE.CSRC3 )
+ $ CALL IGESD2D( ICTXT, 1, 1, LIHIC, 1, RSRC3,
+ $ CSRC3 )
+ END IF
+ IF( MYROW.EQ.RSRC1 .AND. MYCOL.EQ.CSRC1 ) THEN
+ IF( RSRC4.NE.RSRC1 .OR. CSRC4.NE.CSRC1 )
+ $ CALL IGERV2D( ICTXT, 1, 1, LIHIC, 1, RSRC4,
+ $ CSRC4 )
+ END IF
+ IF( MYROW.EQ.RSRC2 .AND. MYCOL.EQ.CSRC2 ) THEN
+ IF( RSRC4.NE.RSRC2 .OR. CSRC4.NE.CSRC2 )
+ $ CALL IGERV2D( ICTXT, 1, 1, LIHIC, 1, RSRC4,
+ $ CSRC4 )
+ END IF
+ IF( MYROW.EQ.RSRC3 .AND. MYCOL.EQ.CSRC3 ) THEN
+ IF( RSRC4.NE.RSRC3 .OR. CSRC4.NE.CSRC3 )
+ $ CALL IGERV2D( ICTXT, 1, 1, LIHIC, 1, RSRC4,
+ $ CSRC4 )
+ END IF
+*
+* Avoid going over the border with the first window if
+* it resides in the block where the last global position
+* T(ILO,ILO) is or ILO has been updated to point to a
+* position right of T(LIHIC,LIHIC).
+*
+ SKIP1CR = WINDOW.EQ.1 .AND.
+ $ ICEIL(LIHIC,NB).LE.ICEIL(ILO,NB)
+*
+* Decide I, where to put top of window, such that top of
+* window does not cut 2-by-2 block. Make sure that we do
+* not end up in a situation where a 2-by-2 block
+* splitted on the border is left in its original place
+* -- this can cause infinite loops.
+* Remedy: make sure that the part of the window that
+* resides left to the border is at least of dimension
+* two (2) in case we have 2-by-2 blocks in top of the
+* cross border window.
+*
+* Also make sure all processors in the group knows about
+* the correct value of I. When skipping the crossborder
+* reordering, just set I = LIHIC.
+*
+ IF( .NOT. SKIP1CR ) THEN
+ IF( MYROW.EQ.RSRC1 .AND. MYCOL.EQ.CSRC1 ) THEN
+ IF( WINDOW.EQ.1 ) THEN
+ LIHI1 = ILO
+ ELSE
+ LIHI1 = IWORK( ILIHI + WINDOW - 2 )
+ END IF
+ I = MAX( LIHI1,
+ $ MIN( LIHIC-2*MOD(LIHIC,NB) + 1,
+ $ (ICEIL(LIHIC,NB)-1)*NB - 1 ) )
+ ILOC = INDXG2L( I, NB, MYROW, DESCT( RSRC_ ),
+ $ NPROW )
+ JLOC = INDXG2L( I-1, NB, MYCOL, DESCT( CSRC_ ),
+ $ NPCOL )
+ IF( T( (JLOC-1)*LLDT+ILOC ).NE.ZERO )
+ $ I = I - 1
+ IF( RSRC1.NE.RSRC4 .OR. CSRC1.NE.CSRC4 )
+ $ CALL IGESD2D( ICTXT, 1, 1, I, 1, RSRC4,
+ $ CSRC4 )
+ IF( RSRC1.NE.RSRC2 .OR. CSRC1.NE.CSRC2 )
+ $ CALL IGESD2D( ICTXT, 1, 1, I, 1, RSRC2,
+ $ CSRC2 )
+ IF( RSRC1.NE.RSRC3 .OR. CSRC1.NE.CSRC3 )
+ $ CALL IGESD2D( ICTXT, 1, 1, I, 1, RSRC3,
+ $ CSRC3 )
+ END IF
+ IF( MYROW.EQ.RSRC2 .AND. MYCOL.EQ.CSRC2 ) THEN
+ IF( RSRC1.NE.RSRC2 .OR. CSRC1.NE.CSRC2 )
+ $ CALL IGERV2D( ICTXT, 1, 1, I, 1, RSRC1,
+ $ CSRC1 )
+ END IF
+ IF( MYROW.EQ.RSRC3 .AND. MYCOL.EQ.CSRC3 ) THEN
+ IF( RSRC1.NE.RSRC3 .OR. CSRC1.NE.CSRC3 )
+ $ CALL IGERV2D( ICTXT, 1, 1, I, 1, RSRC1,
+ $ CSRC1 )
+ END IF
+ IF( MYROW.EQ.RSRC4 .AND. MYCOL.EQ.CSRC4 ) THEN
+ IF( RSRC1.NE.RSRC4 .OR. CSRC1.NE.CSRC4 )
+ $ CALL IGERV2D( ICTXT, 1, 1, I, 1, RSRC1,
+ $ CSRC1 )
+ END IF
+ ELSE
+ I = LIHIC
+ END IF
+*
+* Finalize computation of window size: active window is
+* now (I:LIHIC,I:LIHIC).
+*
+ NWIN = LIHIC - I + 1
+ KS = 0
+*
+* Skip rest of this part if appropriate.
+*
+ IF( SKIP1CR ) GO TO 360
+*
+* Divide workspace -- put active window in
+* WORK(IPW2:IPW2+NWIN**2-1) and orthogonal
+* transformations in WORK(IPW3:...).
+*
+ CALL DLASET( 'All', NWIN, NWIN, ZERO, ZERO,
+ $ WORK( IPW2 ), NWIN )
+*
+ PITRAF = IPIW
+ IPW3 = IPW2 + NWIN*NWIN
+ PDTRAF = IPW3
+*
+* Exchange the current view of SELECT for the active
+* window between process 1 and 4 to make sure that
+* exactly the same job is performed for both processes.
+*
+ IF( RSRC1.NE.RSRC4 .OR. CSRC1.NE.CSRC4 ) THEN
+ ILEN4 = MOD(LIHIC,NB)
+ SELI4 = ICEIL(I,NB)*NB+1
+ ILEN1 = NWIN - ILEN4
+ IF( MYROW.EQ.RSRC1 .AND. MYCOL.EQ.CSRC1 ) THEN
+ CALL IGESD2D( ICTXT, ILEN1, 1, SELECT(I),
+ $ ILEN1, RSRC4, CSRC4 )
+ CALL IGERV2D( ICTXT, ILEN4, 1, SELECT(SELI4),
+ $ ILEN4, RSRC4, CSRC4 )
+ END IF
+ IF( MYROW.EQ.RSRC4 .AND. MYCOL.EQ.CSRC4 ) THEN
+ CALL IGESD2D( ICTXT, ILEN4, 1, SELECT(SELI4),
+ $ ILEN4, RSRC1, CSRC1 )
+ CALL IGERV2D( ICTXT, ILEN1, 1, SELECT(I),
+ $ ILEN1, RSRC1, CSRC1 )
+ END IF
+ END IF
+*
+* Form the active window by a series of point-to-point
+* sends and receives.
+*
+ DIM1 = NB - MOD(I-1,NB)
+ DIM4 = NWIN - DIM1
+ IF( MYROW.EQ.RSRC1 .AND. MYCOL.EQ.CSRC1 ) THEN
+ ILOC = INDXG2L( I, NB, MYROW, DESCT( RSRC_ ),
+ $ NPROW )
+ JLOC = INDXG2L( I, NB, MYCOL, DESCT( CSRC_ ),
+ $ NPCOL )
+ CALL DLAMOV( 'All', DIM1, DIM1,
+ $ T((JLOC-1)*LLDT+ILOC), LLDT, WORK(IPW2),
+ $ NWIN )
+ IF( RSRC1.NE.RSRC4 .OR. CSRC1.NE.CSRC4 ) THEN
+ CALL DGESD2D( ICTXT, DIM1, DIM1,
+ $ WORK(IPW2), NWIN, RSRC4, CSRC4 )
+ CALL DGERV2D( ICTXT, DIM4, DIM4,
+ $ WORK(IPW2+DIM1*NWIN+DIM1), NWIN, RSRC4,
+ $ CSRC4 )
+ END IF
+ END IF
+ IF( MYROW.EQ.RSRC4 .AND. MYCOL.EQ.CSRC4 ) THEN
+ ILOC = INDXG2L( I+DIM1, NB, MYROW, DESCT( RSRC_ ),
+ $ NPROW )
+ JLOC = INDXG2L( I+DIM1, NB, MYCOL, DESCT( CSRC_ ),
+ $ NPCOL )
+ CALL DLAMOV( 'All', DIM4, DIM4,
+ $ T((JLOC-1)*LLDT+ILOC), LLDT,
+ $ WORK(IPW2+DIM1*NWIN+DIM1), NWIN )
+ IF( RSRC4.NE.RSRC1 .OR. CSRC4.NE.CSRC1 ) THEN
+ CALL DGESD2D( ICTXT, DIM4, DIM4,
+ $ WORK(IPW2+DIM1*NWIN+DIM1), NWIN, RSRC1,
+ $ CSRC1 )
+ CALL DGERV2D( ICTXT, DIM1, DIM1,
+ $ WORK(IPW2), NWIN, RSRC1, CSRC1 )
+ END IF
+ END IF
+ IF( MYROW.EQ.RSRC2 .AND. MYCOL.EQ.CSRC2 ) THEN
+ ILOC = INDXG2L( I, NB, MYROW, DESCT( RSRC_ ),
+ $ NPROW )
+ JLOC = INDXG2L( I+DIM1, NB, MYCOL, DESCT( CSRC_ ),
+ $ NPCOL )
+ CALL DLAMOV( 'All', DIM1, DIM4,
+ $ T((JLOC-1)*LLDT+ILOC), LLDT,
+ $ WORK(IPW2+DIM1*NWIN), NWIN )
+ IF( RSRC2.NE.RSRC1 .OR. CSRC2.NE.CSRC1 ) THEN
+ CALL DGESD2D( ICTXT, DIM1, DIM4,
+ $ WORK(IPW2+DIM1*NWIN), NWIN, RSRC1, CSRC1 )
+ END IF
+ END IF
+ IF( MYROW.EQ.RSRC2 .AND. MYCOL.EQ.CSRC2 ) THEN
+ IF( RSRC2.NE.RSRC4 .OR. CSRC2.NE.CSRC4 ) THEN
+ CALL DGESD2D( ICTXT, DIM1, DIM4,
+ $ WORK(IPW2+DIM1*NWIN), NWIN, RSRC4, CSRC4 )
+ END IF
+ END IF
+ IF( MYROW.EQ.RSRC3 .AND. MYCOL.EQ.CSRC3 ) THEN
+ ILOC = INDXG2L( I+DIM1, NB, MYROW, DESCT( RSRC_ ),
+ $ NPROW )
+ JLOC = INDXG2L( I+DIM1-1, NB, MYCOL,
+ $ DESCT( CSRC_ ), NPCOL )
+ CALL DLAMOV( 'All', 1, 1,
+ $ T((JLOC-1)*LLDT+ILOC), LLDT,
+ $ WORK(IPW2+(DIM1-1)*NWIN+DIM1), NWIN )
+ IF( RSRC3.NE.RSRC1 .OR. CSRC3.NE.CSRC1 ) THEN
+ CALL DGESD2D( ICTXT, 1, 1,
+ $ WORK(IPW2+(DIM1-1)*NWIN+DIM1), NWIN,
+ $ RSRC1, CSRC1 )
+ END IF
+ END IF
+ IF( MYROW.EQ.RSRC3 .AND. MYCOL.EQ.CSRC3 ) THEN
+ IF( RSRC3.NE.RSRC4 .OR. CSRC3.NE.CSRC4 ) THEN
+ CALL DGESD2D( ICTXT, 1, 1,
+ $ WORK(IPW2+(DIM1-1)*NWIN+DIM1), NWIN,
+ $ RSRC4, CSRC4 )
+ END IF
+ END IF
+ IF( MYROW.EQ.RSRC1 .AND. MYCOL.EQ.CSRC1 ) THEN
+ IF( RSRC1.NE.RSRC2 .OR. CSRC1.NE.CSRC2 ) THEN
+ CALL DGERV2D( ICTXT, DIM1, DIM4,
+ $ WORK(IPW2+DIM1*NWIN), NWIN, RSRC2,
+ $ CSRC2 )
+ END IF
+ IF( RSRC1.NE.RSRC3 .OR. CSRC1.NE.CSRC3 ) THEN
+ CALL DGERV2D( ICTXT, 1, 1,
+ $ WORK(IPW2+(DIM1-1)*NWIN+DIM1), NWIN,
+ $ RSRC3, CSRC3 )
+ END IF
+ END IF
+ IF( MYROW.EQ.RSRC4 .AND. MYCOL.EQ.CSRC4 ) THEN
+ IF( RSRC4.NE.RSRC2 .OR. CSRC4.NE.CSRC2 ) THEN
+ CALL DGERV2D( ICTXT, DIM1, DIM4,
+ $ WORK(IPW2+DIM1*NWIN), NWIN, RSRC2,
+ $ CSRC2 )
+ END IF
+ IF( RSRC4.NE.RSRC3 .OR. CSRC4.NE.CSRC3 ) THEN
+ CALL DGERV2D( ICTXT, 1, 1,
+ $ WORK(IPW2+(DIM1-1)*NWIN+DIM1), NWIN,
+ $ RSRC3, CSRC3 )
+ END IF
+ END IF
+*
+* Compute the reordering (just as in the total local
+* case) and accumulate the transformations (ONLY
+* ON-DIAGONAL PROCESSES).
+*
+ IF( ( MYROW.EQ.RSRC1 .AND. MYCOL.EQ.CSRC1 ) .OR.
+ $ ( MYROW.EQ.RSRC4 .AND. MYCOL.EQ.CSRC4 ) ) THEN
+ PAIR = .FALSE.
+ DO 330 K = I, LIHIC
+ IF( PAIR ) THEN
+ PAIR = .FALSE.
+ ELSE
+ SWAP = SELECT( K ).NE.0
+ IF( K.LT.LIHIC ) THEN
+ ELEM = WORK(IPW2+(K-I)*NWIN+K-I+1)
+ IF( ELEM.NE.ZERO )
+ $ PAIR = .TRUE.
+ END IF
+ IF( SWAP ) THEN
+ KS = KS + 1
+*
+* Swap the K-th block to position I+KS-1.
+*
+ IERR = 0
+ KK = K - I + 1
+ KKS = KS
+ IF( KK.NE.KS ) THEN
+ NITRAF = LIWORK - PITRAF + 1
+ NDTRAF = LWORK - PDTRAF + 1
+ CALL BDTREXC( NWIN, WORK(IPW2), NWIN,
+ $ KK, KKS, NITRAF, IWORK( PITRAF ),
+ $ NDTRAF, WORK( PDTRAF ),
+ $ WORK(IPW1), IERR )
+ PITRAF = PITRAF + NITRAF
+ PDTRAF = PDTRAF + NDTRAF
+*
+* Update array SELECT.
+*
+ IF ( PAIR ) THEN
+ DO 340 J = I+KK-1, I+KKS, -1
+ SELECT(J+1) = SELECT(J-1)
+ 340 CONTINUE
+ SELECT(I+KKS-1) = 1
+ SELECT(I+KKS) = 1
+ ELSE
+ DO 350 J = I+KK-1, I+KKS, -1
+ SELECT(J) = SELECT(J-1)
+ 350 CONTINUE
+ SELECT(I+KKS-1) = 1
+ END IF
+*
+ IF ( IERR.EQ.1 .OR. IERR.EQ.2 ) THEN
+*
+ IF ( IERR.EQ.2 ) THEN
+ SELECT( I+KKS-3 ) = 1
+ SELECT( I+KKS-1 ) = 0
+ KKS = KKS + 1
+ END IF
+*
+ GO TO 360
+ END IF
+ KS = KKS
+ END IF
+ IF( PAIR )
+ $ KS = KS + 1
+ END IF
+ END IF
+ 330 CONTINUE
+ END IF
+ 360 CONTINUE
+*
+* Save information about the reordering.
+*
+ IF( ( MYROW.EQ.RSRC1 .AND. MYCOL.EQ.CSRC1 ) .OR.
+ $ ( MYROW.EQ.RSRC4 .AND. MYCOL.EQ.CSRC4 ) ) THEN
+ IBUFF( 1 ) = I
+ IBUFF( 2 ) = NWIN
+ IBUFF( 3 ) = PITRAF
+ IBUFF( 4 ) = KS
+ IBUFF( 5 ) = PDTRAF
+ IBUFF( 6 ) = NDTRAF
+ ILEN = PITRAF - IPIW + 1
+ DLEN = PDTRAF - IPW3 + 1
+ IBUFF( 7 ) = ILEN
+ IBUFF( 8 ) = DLEN
+*
+* Put reordered data back into global matrix if a
+* reordering took place.
+*
+ IF( .NOT. SKIP1CR ) THEN
+ IF( MYROW.EQ.RSRC1 .AND. MYCOL.EQ.CSRC1 ) THEN
+ ILOC = INDXG2L( I, NB, MYROW, DESCT( RSRC_ ),
+ $ NPROW )
+ JLOC = INDXG2L( I, NB, MYCOL, DESCT( CSRC_ ),
+ $ NPCOL )
+ CALL DLAMOV( 'All', DIM1, DIM1, WORK(IPW2),
+ $ NWIN, T((JLOC-1)*LLDT+ILOC), LLDT )
+ END IF
+ IF( MYROW.EQ.RSRC4 .AND. MYCOL.EQ.CSRC4 ) THEN
+ ILOC = INDXG2L( I+DIM1, NB, MYROW,
+ $ DESCT( RSRC_ ), NPROW )
+ JLOC = INDXG2L( I+DIM1, NB, MYCOL,
+ $ DESCT( CSRC_ ), NPCOL )
+ CALL DLAMOV( 'All', DIM4, DIM4,
+ $ WORK(IPW2+DIM1*NWIN+DIM1), NWIN,
+ $ T((JLOC-1)*LLDT+ILOC), LLDT )
+ END IF
+ END IF
+ END IF
+*
+* Break if appropriate -- IBUFF(3:8) may now contain
+* nonsens, but that's no problem. The processors outside
+* the cross border group only needs to know about I and
+* NWIN to get a correct value of SKIP1CR (see below) and
+* to skip the cross border updates if necessary.
+*
+ IF( WINDOW.EQ.1 .AND. SKIP1CR ) GO TO 325
+*
+* Return reordered data to process 2 and 3.
+*
+ IF( MYROW.EQ.RSRC1 .AND. MYCOL.EQ.CSRC1 ) THEN
+ IF( RSRC1.NE.RSRC3 .OR. CSRC1.NE.CSRC3 ) THEN
+ CALL DGESD2D( ICTXT, 1, 1,
+ $ WORK( IPW2+(DIM1-1)*NWIN+DIM1 ), NWIN,
+ $ RSRC3, CSRC3 )
+ END IF
+ END IF
+ IF( MYROW.EQ.RSRC4 .AND. MYCOL.EQ.CSRC4 ) THEN
+ IF( RSRC4.NE.RSRC2 .OR. CSRC4.NE.CSRC2 ) THEN
+ CALL DGESD2D( ICTXT, DIM1, DIM4,
+ $ WORK( IPW2+DIM1*NWIN), NWIN, RSRC2,
+ $ CSRC2 )
+ END IF
+ END IF
+ IF( MYROW.EQ.RSRC2 .AND. MYCOL.EQ.CSRC2 ) THEN
+ ILOC = INDXG2L( I, NB, MYROW, DESCT( RSRC_ ),
+ $ NPROW )
+ JLOC = INDXG2L( I+DIM1, NB, MYCOL,
+ $ DESCT( CSRC_ ), NPCOL )
+ IF( RSRC2.NE.RSRC4 .OR. CSRC2.NE.CSRC4 ) THEN
+ CALL DGERV2D( ICTXT, DIM1, DIM4,
+ $ WORK(IPW2+DIM1*NWIN), NWIN, RSRC4, CSRC4 )
+ END IF
+ CALL DLAMOV( 'All', DIM1, DIM4,
+ $ WORK( IPW2+DIM1*NWIN ), NWIN,
+ $ T((JLOC-1)*LLDT+ILOC), LLDT )
+ END IF
+ IF( MYROW.EQ.RSRC3 .AND. MYCOL.EQ.CSRC3 ) THEN
+ ILOC = INDXG2L( I+DIM1, NB, MYROW,
+ $ DESCT( RSRC_ ), NPROW )
+ JLOC = INDXG2L( I+DIM1-1, NB, MYCOL,
+ $ DESCT( CSRC_ ), NPCOL )
+ IF( RSRC3.NE.RSRC1 .OR. CSRC3.NE.CSRC1 ) THEN
+ CALL DGERV2D( ICTXT, 1, 1,
+ $ WORK( IPW2+(DIM1-1)*NWIN+DIM1 ), NWIN,
+ $ RSRC1, CSRC1 )
+ END IF
+ T((JLOC-1)*LLDT+ILOC) =
+ $ WORK( IPW2+(DIM1-1)*NWIN+DIM1 )
+ END IF
+ END IF
+*
+ 325 CONTINUE
+*
+ 320 CONTINUE
+*
+* For the crossborder updates, we use the same directions as
+* in the local reordering case above.
+*
+ DO 2222 DIR = 1, 2
+*
+* Broadcast information about the reordering.
+*
+ DO 321 WINDOW = WINDOW0, WINE, 2
+ RSRC4 = IWORK(IRSRC+WINDOW-1)
+ CSRC4 = IWORK(ICSRC+WINDOW-1)
+ RSRC1 = MOD( RSRC4 - 1 + NPROW, NPROW )
+ CSRC1 = MOD( CSRC4 - 1 + NPCOL, NPCOL )
+ IF( MYROW.EQ.RSRC1 .AND. MYCOL.EQ.CSRC1 ) THEN
+ IF( NPCOL.GT.1 .AND. DIR.EQ.1 )
+ $ CALL IGEBS2D( ICTXT, 'Row', TOP, 8, 1,
+ $ IBUFF, 8 )
+ IF( NPROW.GT.1 .AND. DIR.EQ.2 )
+ $ CALL IGEBS2D( ICTXT, 'Col', TOP, 8, 1,
+ $ IBUFF, 8 )
+ SKIP1CR = WINDOW.EQ.1 .AND.
+ $ ICEIL(LIHIC,NB).LE.ICEIL(ILO,NB)
+ ELSEIF( MYROW.EQ.RSRC1 .OR. MYCOL.EQ.CSRC1 ) THEN
+ IF( NPCOL.GT.1 .AND. DIR.EQ.1 .AND.
+ $ MYROW.EQ.RSRC1 ) THEN
+ CALL IGEBR2D( ICTXT, 'Row', TOP, 8, 1,
+ $ IBUFF, 8, RSRC1, CSRC1 )
+ I = IBUFF( 1 )
+ NWIN = IBUFF( 2 )
+ PITRAF = IBUFF( 3 )
+ KS = IBUFF( 4 )
+ PDTRAF = IBUFF( 5 )
+ NDTRAF = IBUFF( 6 )
+ ILEN = IBUFF( 7 )
+ DLEN = IBUFF( 8 )
+ BUFFLEN = ILEN + DLEN
+ IPW3 = IPW2 + NWIN*NWIN
+ DIM1 = NB - MOD(I-1,NB)
+ DIM4 = NWIN - DIM1
+ LIHIC = NWIN + I - 1
+ SKIP1CR = WINDOW.EQ.1 .AND.
+ $ ICEIL(LIHIC,NB).LE.ICEIL(ILO,NB)
+ END IF
+ IF( NPROW.GT.1 .AND. DIR.EQ.2 .AND.
+ $ MYCOL.EQ.CSRC1 ) THEN
+ CALL IGEBR2D( ICTXT, 'Col', TOP, 8, 1,
+ $ IBUFF, 8, RSRC1, CSRC1 )
+ I = IBUFF( 1 )
+ NWIN = IBUFF( 2 )
+ PITRAF = IBUFF( 3 )
+ KS = IBUFF( 4 )
+ PDTRAF = IBUFF( 5 )
+ NDTRAF = IBUFF( 6 )
+ ILEN = IBUFF( 7 )
+ DLEN = IBUFF( 8 )
+ BUFFLEN = ILEN + DLEN
+ IPW3 = IPW2 + NWIN*NWIN
+ DIM1 = NB - MOD(I-1,NB)
+ DIM4 = NWIN - DIM1
+ LIHIC = NWIN + I - 1
+ SKIP1CR = WINDOW.EQ.1 .AND.
+ $ ICEIL(LIHIC,NB).LE.ICEIL(ILO,NB)
+ END IF
+ END IF
+ IF( RSRC1.NE.RSRC4 ) THEN
+ IF( MYROW.EQ.RSRC4 .AND. MYCOL.EQ.CSRC4 ) THEN
+ IF( NPCOL.GT.1 .AND. DIR.EQ.1 )
+ $ CALL IGEBS2D( ICTXT, 'Row', TOP, 8, 1,
+ $ IBUFF, 8 )
+ SKIP1CR = WINDOW.EQ.1 .AND.
+ $ ICEIL(LIHIC,NB).LE.ICEIL(ILO,NB)
+ ELSEIF( MYROW.EQ.RSRC4 ) THEN
+ IF( NPCOL.GT.1 .AND. DIR.EQ.1 ) THEN
+ CALL IGEBR2D( ICTXT, 'Row', TOP, 8, 1,
+ $ IBUFF, 8, RSRC4, CSRC4 )
+ I = IBUFF( 1 )
+ NWIN = IBUFF( 2 )
+ PITRAF = IBUFF( 3 )
+ KS = IBUFF( 4 )
+ PDTRAF = IBUFF( 5 )
+ NDTRAF = IBUFF( 6 )
+ ILEN = IBUFF( 7 )
+ DLEN = IBUFF( 8 )
+ BUFFLEN = ILEN + DLEN
+ IPW3 = IPW2 + NWIN*NWIN
+ DIM1 = NB - MOD(I-1,NB)
+ DIM4 = NWIN - DIM1
+ LIHIC = NWIN + I - 1
+ SKIP1CR = WINDOW.EQ.1 .AND.
+ $ ICEIL(LIHIC,NB).LE.ICEIL(ILO,NB)
+ END IF
+ END IF
+ END IF
+ IF( CSRC1.NE.CSRC4 ) THEN
+ IF( MYROW.EQ.RSRC4 .AND. MYCOL.EQ.CSRC4 ) THEN
+ IF( NPROW.GT.1 .AND. DIR.EQ.2 )
+ $ CALL IGEBS2D( ICTXT, 'Col', TOP, 8, 1,
+ $ IBUFF, 8 )
+ SKIP1CR = WINDOW.EQ.1 .AND.
+ $ ICEIL(LIHIC,NB).LE.ICEIL(ILO,NB)
+ ELSEIF( MYCOL.EQ.CSRC4 ) THEN
+ IF( NPROW.GT.1 .AND. DIR.EQ.2 ) THEN
+ CALL IGEBR2D( ICTXT, 'Col', TOP, 8, 1,
+ $ IBUFF, 8, RSRC4, CSRC4 )
+ I = IBUFF( 1 )
+ NWIN = IBUFF( 2 )
+ PITRAF = IBUFF( 3 )
+ KS = IBUFF( 4 )
+ PDTRAF = IBUFF( 5 )
+ NDTRAF = IBUFF( 6 )
+ ILEN = IBUFF( 7 )
+ DLEN = IBUFF( 8 )
+ BUFFLEN = ILEN + DLEN
+ IPW3 = IPW2 + NWIN*NWIN
+ DIM1 = NB - MOD(I-1,NB)
+ DIM4 = NWIN - DIM1
+ LIHIC = NWIN + I - 1
+ SKIP1CR = WINDOW.EQ.1 .AND.
+ $ ICEIL(LIHIC,NB).LE.ICEIL(ILO,NB)
+ END IF
+ END IF
+ END IF
+*
+* Skip rest of broadcasts and updates if appropriate.
+*
+ IF( SKIP1CR ) GO TO 326
+*
+* Broadcast the orthogonal transformations.
+*
+ IF( MYROW.EQ.RSRC1 .AND. MYCOL.EQ.CSRC1 ) THEN
+ BUFFER = PDTRAF
+ BUFFLEN = DLEN + ILEN
+ IF( (NPROW.GT.1 .AND. DIR.EQ.2) .OR.
+ $ (NPCOL.GT.1 .AND. DIR.EQ.1) ) THEN
+ DO 370 INDX = 1, ILEN
+ WORK( BUFFER+INDX-1 ) =
+ $ DBLE( IWORK(IPIW+INDX-1) )
+ 370 CONTINUE
+ CALL DLAMOV( 'All', DLEN, 1, WORK( IPW3 ),
+ $ DLEN, WORK(BUFFER+ILEN), DLEN )
+ END IF
+ IF( NPCOL.GT.1 .AND. DIR.EQ.1 ) THEN
+ CALL DGEBS2D( ICTXT, 'Row', TOP, BUFFLEN, 1,
+ $ WORK(BUFFER), BUFFLEN )
+ END IF
+ IF( NPROW.GT.1 .AND. DIR.EQ.2 ) THEN
+ CALL DGEBS2D( ICTXT, 'Col', TOP, BUFFLEN, 1,
+ $ WORK(BUFFER), BUFFLEN )
+ END IF
+ ELSEIF( MYROW.EQ.RSRC1 .OR. MYCOL.EQ.CSRC1 ) THEN
+ IF( NPCOL.GT.1 .AND. DIR.EQ.1 .AND.
+ $ MYROW.EQ.RSRC1 ) THEN
+ BUFFER = PDTRAF
+ BUFFLEN = DLEN + ILEN
+ CALL DGEBR2D( ICTXT, 'Row', TOP, BUFFLEN, 1,
+ $ WORK(BUFFER), BUFFLEN, RSRC1, CSRC1 )
+ END IF
+ IF( NPROW.GT.1 .AND. DIR.EQ.2 .AND.
+ $ MYCOL.EQ.CSRC1 ) THEN
+ BUFFER = PDTRAF
+ BUFFLEN = DLEN + ILEN
+ CALL DGEBR2D( ICTXT, 'Col', TOP, BUFFLEN, 1,
+ $ WORK(BUFFER), BUFFLEN, RSRC1, CSRC1 )
+ END IF
+ IF( (NPCOL.GT.1.AND.DIR.EQ.1.AND.MYROW.EQ.RSRC1)
+ $ .OR. (NPROW.GT.1.AND.DIR.EQ.2.AND.
+ $ MYCOL.EQ.CSRC1) ) THEN
+ DO 380 INDX = 1, ILEN
+ IWORK(IPIW+INDX-1) =
+ $ INT( WORK( BUFFER+INDX-1 ) )
+ 380 CONTINUE
+ CALL DLAMOV( 'All', DLEN, 1,
+ $ WORK( BUFFER+ILEN ), DLEN,
+ $ WORK( IPW3 ), DLEN )
+ END IF
+ END IF
+ IF( RSRC1.NE.RSRC4 ) THEN
+ IF( MYROW.EQ.RSRC4 .AND. MYCOL.EQ.CSRC4 ) THEN
+ BUFFER = PDTRAF
+ BUFFLEN = DLEN + ILEN
+ IF( NPCOL.GT.1 .AND. DIR.EQ.1 ) THEN
+ DO 390 INDX = 1, ILEN
+ WORK( BUFFER+INDX-1 ) =
+ $ DBLE( IWORK(IPIW+INDX-1) )
+ 390 CONTINUE
+ CALL DLAMOV( 'All', DLEN, 1, WORK( IPW3 ),
+ $ DLEN, WORK(BUFFER+ILEN), DLEN )
+ CALL DGEBS2D( ICTXT, 'Row', TOP, BUFFLEN,
+ $ 1, WORK(BUFFER), BUFFLEN )
+ END IF
+ ELSEIF( MYROW.EQ.RSRC4 .AND. DIR.EQ.1 .AND.
+ $ NPCOL.GT.1 ) THEN
+ BUFFER = PDTRAF
+ BUFFLEN = DLEN + ILEN
+ CALL DGEBR2D( ICTXT, 'Row', TOP, BUFFLEN,
+ $ 1, WORK(BUFFER), BUFFLEN, RSRC4, CSRC4 )
+ DO 400 INDX = 1, ILEN
+ IWORK(IPIW+INDX-1) =
+ $ INT( WORK( BUFFER+INDX-1 ) )
+ 400 CONTINUE
+ CALL DLAMOV( 'All', DLEN, 1,
+ $ WORK( BUFFER+ILEN ), DLEN,
+ $ WORK( IPW3 ), DLEN )
+ END IF
+ END IF
+ IF( CSRC1.NE.CSRC4 ) THEN
+ IF( MYROW.EQ.RSRC4 .AND. MYCOL.EQ.CSRC4 ) THEN
+ BUFFER = PDTRAF
+ BUFFLEN = DLEN + ILEN
+ IF( NPROW.GT.1 .AND. DIR.EQ.2 ) THEN
+ DO 395 INDX = 1, ILEN
+ WORK( BUFFER+INDX-1 ) =
+ $ DBLE( IWORK(IPIW+INDX-1) )
+ 395 CONTINUE
+ CALL DLAMOV( 'All', DLEN, 1, WORK( IPW3 ),
+ $ DLEN, WORK(BUFFER+ILEN), DLEN )
+ CALL DGEBS2D( ICTXT, 'Col', TOP, BUFFLEN,
+ $ 1, WORK(BUFFER), BUFFLEN )
+ END IF
+ ELSEIF( MYCOL.EQ.CSRC4 .AND. DIR.EQ.2 .AND.
+ $ NPROW.GT.1 ) THEN
+ BUFFER = PDTRAF
+ BUFFLEN = DLEN + ILEN
+ CALL DGEBR2D( ICTXT, 'Col', TOP, BUFFLEN, 1,
+ $ WORK(BUFFER), BUFFLEN, RSRC4, CSRC4 )
+ DO 402 INDX = 1, ILEN
+ IWORK(IPIW+INDX-1) =
+ $ INT( WORK( BUFFER+INDX-1 ) )
+ 402 CONTINUE
+ CALL DLAMOV( 'All', DLEN, 1,
+ $ WORK( BUFFER+ILEN ), DLEN,
+ $ WORK( IPW3 ), DLEN )
+ END IF
+ END IF
+*
+ 326 CONTINUE
+*
+ 321 CONTINUE
+*
+* Compute crossborder updates.
+*
+ DO 322 WINDOW = WINDOW0, WINE, 2
+ IF( WINDOW.EQ.1 .AND. SKIP1CR ) GO TO 327
+ RSRC4 = IWORK(IRSRC+WINDOW-1)
+ CSRC4 = IWORK(ICSRC+WINDOW-1)
+ RSRC1 = MOD( RSRC4 - 1 + NPROW, NPROW )
+ CSRC1 = MOD( CSRC4 - 1 + NPCOL, NPCOL )
+*
+* Prepare workspaces for updates:
+* IPW3 holds now the orthogonal transformations
+* IPW4 holds the explicit orthogonal matrix, if formed
+* IPW5 holds the crossborder block column of T
+* IPW6 holds the crossborder block row of T
+* IPW7 holds the crossborder block column of Q
+* (if WANTQ=.TRUE.)
+* IPW8 points to the leftover workspace used as lhs in
+* matrix multiplications
+*
+ IF( ((MYCOL.EQ.CSRC1.OR.MYCOL.EQ.CSRC4).AND.DIR.EQ.2)
+ $ .OR. ((MYROW.EQ.RSRC1.OR.MYROW.EQ.RSRC4).AND.
+ $ DIR.EQ.1)) THEN
+ IPW4 = BUFFER
+ IF( DIR.EQ.2 ) THEN
+ IF( WANTQ ) THEN
+ QROWS = NUMROC( N, NB, MYROW, DESCQ( RSRC_ ),
+ $ NPROW )
+ ELSE
+ QROWS = 0
+ END IF
+ TROWS = NUMROC( I-1, NB, MYROW, DESCT( RSRC_ ),
+ $ NPROW )
+ ELSE
+ QROWS = 0
+ TROWS = 0
+ END IF
+ IF( DIR.EQ.1 ) THEN
+ TCOLS = NUMROC( N - (I+DIM1-1), NB, MYCOL,
+ $ CSRC4, NPCOL )
+ IF( MYCOL.EQ.CSRC4 ) TCOLS = TCOLS - DIM4
+ ELSE
+ TCOLS = 0
+ END IF
+ IPW5 = IPW4 + NWIN*NWIN
+ IPW6 = IPW5 + TROWS * NWIN
+ IF( WANTQ ) THEN
+ IPW7 = IPW6 + NWIN * TCOLS
+ IPW8 = IPW7 + QROWS * NWIN
+ ELSE
+ IPW8 = IPW6 + NWIN * TCOLS
+ END IF
+ END IF
+*
+* Let each process row and column involved in the updates
+* exchange data in T and Q with their neighbours.
+*
+ IF( DIR.EQ.2 ) THEN
+ IF( MYCOL.EQ.CSRC1 .OR. MYCOL.EQ.CSRC4 ) THEN
+ DO 410 INDX = 1, NPROW
+ IF( MYCOL.EQ.CSRC1 ) THEN
+ CALL INFOG2L( 1+(INDX-1)*NB, I, DESCT,
+ $ NPROW, NPCOL, MYROW, MYCOL, ILOC,
+ $ JLOC1, RSRC, CSRC1 )
+ IF( MYROW.EQ.RSRC ) THEN
+ CALL DLAMOV( 'All', TROWS, DIM1,
+ $ T((JLOC1-1)*LLDT+ILOC), LLDT,
+ $ WORK(IPW5), TROWS )
+ IF( NPCOL.GT.1 ) THEN
+ EAST = MOD( MYCOL + 1, NPCOL )
+ CALL DGESD2D( ICTXT, TROWS, DIM1,
+ $ WORK(IPW5), TROWS, RSRC,
+ $ EAST )
+ CALL DGERV2D( ICTXT, TROWS, DIM4,
+ $ WORK(IPW5+TROWS*DIM1), TROWS,
+ $ RSRC, EAST )
+ END IF
+ END IF
+ END IF
+ IF( MYCOL.EQ.CSRC4 ) THEN
+ CALL INFOG2L( 1+(INDX-1)*NB, I+DIM1,
+ $ DESCT, NPROW, NPCOL, MYROW, MYCOL,
+ $ ILOC, JLOC4, RSRC, CSRC4 )
+ IF( MYROW.EQ.RSRC ) THEN
+ CALL DLAMOV( 'All', TROWS, DIM4,
+ $ T((JLOC4-1)*LLDT+ILOC), LLDT,
+ $ WORK(IPW5+TROWS*DIM1), TROWS )
+ IF( NPCOL.GT.1 ) THEN
+ WEST = MOD( MYCOL-1+NPCOL, NPCOL )
+ CALL DGESD2D( ICTXT, TROWS, DIM4,
+ $ WORK(IPW5+TROWS*DIM1), TROWS,
+ $ RSRC, WEST )
+ CALL DGERV2D( ICTXT, TROWS, DIM1,
+ $ WORK(IPW5), TROWS, RSRC,
+ $ WEST )
+ END IF
+ END IF
+ END IF
+ 410 CONTINUE
+ END IF
+ END IF
+*
+ IF( DIR.EQ.1 ) THEN
+ IF( MYROW.EQ.RSRC1 .OR. MYROW.EQ.RSRC4 ) THEN
+ DO 420 INDX = 1, NPCOL
+ IF( MYROW.EQ.RSRC1 ) THEN
+ IF( INDX.EQ.1 ) THEN
+ CALL INFOG2L( I, LIHIC+1, DESCT, NPROW,
+ $ NPCOL, MYROW, MYCOL, ILOC1, JLOC,
+ $ RSRC1, CSRC )
+ ELSE
+ CALL INFOG2L( I,
+ $ (ICEIL(LIHIC,NB)+(INDX-2))*NB+1,
+ $ DESCT, NPROW, NPCOL, MYROW, MYCOL,
+ $ ILOC1, JLOC, RSRC1, CSRC )
+ END IF
+ IF( MYCOL.EQ.CSRC ) THEN
+ CALL DLAMOV( 'All', DIM1, TCOLS,
+ $ T((JLOC-1)*LLDT+ILOC1), LLDT,
+ $ WORK(IPW6), NWIN )
+ IF( NPROW.GT.1 ) THEN
+ SOUTH = MOD( MYROW + 1, NPROW )
+ CALL DGESD2D( ICTXT, DIM1, TCOLS,
+ $ WORK(IPW6), NWIN, SOUTH,
+ $ CSRC )
+ CALL DGERV2D( ICTXT, DIM4, TCOLS,
+ $ WORK(IPW6+DIM1), NWIN, SOUTH,
+ $ CSRC )
+ END IF
+ END IF
+ END IF
+ IF( MYROW.EQ.RSRC4 ) THEN
+ IF( INDX.EQ.1 ) THEN
+ CALL INFOG2L( I+DIM1, LIHIC+1, DESCT,
+ $ NPROW, NPCOL, MYROW, MYCOL, ILOC4,
+ $ JLOC, RSRC4, CSRC )
+ ELSE
+ CALL INFOG2L( I+DIM1,
+ $ (ICEIL(LIHIC,NB)+(INDX-2))*NB+1,
+ $ DESCT, NPROW, NPCOL, MYROW, MYCOL,
+ $ ILOC4, JLOC, RSRC4, CSRC )
+ END IF
+ IF( MYCOL.EQ.CSRC ) THEN
+ CALL DLAMOV( 'All', DIM4, TCOLS,
+ $ T((JLOC-1)*LLDT+ILOC4), LLDT,
+ $ WORK(IPW6+DIM1), NWIN )
+ IF( NPROW.GT.1 ) THEN
+ NORTH = MOD( MYROW-1+NPROW, NPROW )
+ CALL DGESD2D( ICTXT, DIM4, TCOLS,
+ $ WORK(IPW6+DIM1), NWIN, NORTH,
+ $ CSRC )
+ CALL DGERV2D( ICTXT, DIM1, TCOLS,
+ $ WORK(IPW6), NWIN, NORTH,
+ $ CSRC )
+ END IF
+ END IF
+ END IF
+ 420 CONTINUE
+ END IF
+ END IF
+*
+ IF( DIR.EQ.2 ) THEN
+ IF( WANTQ ) THEN
+ IF( MYCOL.EQ.CSRC1 .OR. MYCOL.EQ.CSRC4 ) THEN
+ DO 430 INDX = 1, NPROW
+ IF( MYCOL.EQ.CSRC1 ) THEN
+ CALL INFOG2L( 1+(INDX-1)*NB, I, DESCQ,
+ $ NPROW, NPCOL, MYROW, MYCOL, ILOC,
+ $ JLOC1, RSRC, CSRC1 )
+ IF( MYROW.EQ.RSRC ) THEN
+ CALL DLAMOV( 'All', QROWS, DIM1,
+ $ Q((JLOC1-1)*LLDQ+ILOC), LLDQ,
+ $ WORK(IPW7), QROWS )
+ IF( NPCOL.GT.1 ) THEN
+ EAST = MOD( MYCOL + 1, NPCOL )
+ CALL DGESD2D( ICTXT, QROWS, DIM1,
+ $ WORK(IPW7), QROWS, RSRC,
+ $ EAST )
+ CALL DGERV2D( ICTXT, QROWS, DIM4,
+ $ WORK(IPW7+QROWS*DIM1),
+ $ QROWS, RSRC, EAST )
+ END IF
+ END IF
+ END IF
+ IF( MYCOL.EQ.CSRC4 ) THEN
+ CALL INFOG2L( 1+(INDX-1)*NB, I+DIM1,
+ $ DESCQ, NPROW, NPCOL, MYROW, MYCOL,
+ $ ILOC, JLOC4, RSRC, CSRC4 )
+ IF( MYROW.EQ.RSRC ) THEN
+ CALL DLAMOV( 'All', QROWS, DIM4,
+ $ Q((JLOC4-1)*LLDQ+ILOC), LLDQ,
+ $ WORK(IPW7+QROWS*DIM1), QROWS )
+ IF( NPCOL.GT.1 ) THEN
+ WEST = MOD( MYCOL-1+NPCOL,
+ $ NPCOL )
+ CALL DGESD2D( ICTXT, QROWS, DIM4,
+ $ WORK(IPW7+QROWS*DIM1),
+ $ QROWS, RSRC, WEST )
+ CALL DGERV2D( ICTXT, QROWS, DIM1,
+ $ WORK(IPW7), QROWS, RSRC,
+ $ WEST )
+ END IF
+ END IF
+ END IF
+ 430 CONTINUE
+ END IF
+ END IF
+ END IF
+*
+ 327 CONTINUE
+*
+ 322 CONTINUE
+*
+ DO 323 WINDOW = WINDOW0, WINE, 2
+ RSRC4 = IWORK(IRSRC+WINDOW-1)
+ CSRC4 = IWORK(ICSRC+WINDOW-1)
+ RSRC1 = MOD( RSRC4 - 1 + NPROW, NPROW )
+ CSRC1 = MOD( CSRC4 - 1 + NPCOL, NPCOL )
+ FLOPS = 0
+ IF( ((MYCOL.EQ.CSRC1.OR.MYCOL.EQ.CSRC4).AND.DIR.EQ.2)
+ $ .OR. ((MYROW.EQ.RSRC1.OR.MYROW.EQ.RSRC4).AND.
+ $ DIR.EQ.1) ) THEN
+*
+* Skip this part of the updates if appropriate.
+*
+ IF( WINDOW.EQ.1 .AND. SKIP1CR ) GO TO 328
+*
+* Count number of operations to decide whether to use
+* matrix-matrix multiplications for updating
+* off-diagonal parts or not.
+*
+ NITRAF = PITRAF - IPIW
+ ISHH = .FALSE.
+ DO 405 K = 1, NITRAF
+ IF( IWORK( IPIW + K - 1 ).LE.NWIN ) THEN
+ FLOPS = FLOPS + 6
+ ELSE
+ FLOPS = FLOPS + 11
+ ISHH = .TRUE.
+ END IF
+ 405 CONTINUE
+*
+* Perform updates in parallel.
+*
+ IF( FLOPS.NE.0 .AND.
+ $ ( 2*FLOPS*100 )/( 2*NWIN*NWIN ) .GE. MMULT )
+ $ THEN
+*
+ CALL DLASET( 'All', NWIN, NWIN, ZERO, ONE,
+ $ WORK( IPW4 ), NWIN )
+ WORK(IPW8) = DBLE(MYROW)
+ WORK(IPW8+1) = DBLE(MYCOL)
+ CALL BDLAAPP( 1, NWIN, NWIN, NCB, WORK( IPW4 ),
+ $ NWIN, NITRAF, IWORK(IPIW), WORK( IPW3 ),
+ $ WORK(IPW8) )
+*
+* Test if sparsity structure of orthogonal matrix
+* can be exploited (see below).
+*
+ IF( ISHH .OR. DIM1.NE.KS .OR. DIM4.NE.KS ) THEN
+*
+* Update the columns of T and Q affected by the
+* reordering.
+*
+ IF( DIR.EQ.2 ) THEN
+ DO 440 INDX = 1, MIN(I-1,1+(NPROW-1)*NB),
+ $ NB
+ IF( MYCOL.EQ.CSRC1 ) THEN
+ CALL INFOG2L( INDX, I, DESCT, NPROW,
+ $ NPCOL, MYROW, MYCOL, ILOC,
+ $ JLOC, RSRC, CSRC1 )
+ IF( MYROW.EQ.RSRC ) THEN
+ CALL DGEMM( 'No transpose',
+ $ 'No transpose', TROWS, DIM1,
+ $ NWIN, ONE, WORK( IPW5 ),
+ $ TROWS, WORK( IPW4 ), NWIN,
+ $ ZERO, WORK(IPW8), TROWS )
+ CALL DLAMOV( 'All', TROWS, DIM1,
+ $ WORK(IPW8), TROWS,
+ $ T((JLOC-1)*LLDT+ILOC),
+ $ LLDT )
+ END IF
+ END IF
+ IF( MYCOL.EQ.CSRC4 ) THEN
+ CALL INFOG2L( INDX, I+DIM1, DESCT,
+ $ NPROW, NPCOL, MYROW, MYCOL,
+ $ ILOC, JLOC, RSRC, CSRC4 )
+ IF( MYROW.EQ.RSRC ) THEN
+ CALL DGEMM( 'No transpose',
+ $ 'No transpose', TROWS, DIM4,
+ $ NWIN, ONE, WORK( IPW5 ),
+ $ TROWS,
+ $ WORK( IPW4+NWIN*DIM1 ),
+ $ NWIN, ZERO, WORK(IPW8),
+ $ TROWS )
+ CALL DLAMOV( 'All', TROWS, DIM4,
+ $ WORK(IPW8), TROWS,
+ $ T((JLOC-1)*LLDT+ILOC),
+ $ LLDT )
+ END IF
+ END IF
+ 440 CONTINUE
+*
+ IF( WANTQ ) THEN
+ DO 450 INDX = 1, MIN(N,1+(NPROW-1)*NB),
+ $ NB
+ IF( MYCOL.EQ.CSRC1 ) THEN
+ CALL INFOG2L( INDX, I, DESCQ,
+ $ NPROW, NPCOL, MYROW, MYCOL,
+ $ ILOC, JLOC, RSRC, CSRC1 )
+ IF( MYROW.EQ.RSRC ) THEN
+ CALL DGEMM( 'No transpose',
+ $ 'No transpose', QROWS,
+ $ DIM1, NWIN, ONE,
+ $ WORK( IPW7 ), QROWS,
+ $ WORK( IPW4 ), NWIN,
+ $ ZERO, WORK(IPW8),
+ $ QROWS )
+ CALL DLAMOV( 'All', QROWS,
+ $ DIM1, WORK(IPW8), QROWS,
+ $ Q((JLOC-1)*LLDQ+ILOC),
+ $ LLDQ )
+ END IF
+ END IF
+ IF( MYCOL.EQ.CSRC4 ) THEN
+ CALL INFOG2L( INDX, I+DIM1,
+ $ DESCQ, NPROW, NPCOL, MYROW,
+ $ MYCOL, ILOC, JLOC, RSRC,
+ $ CSRC4 )
+ IF( MYROW.EQ.RSRC ) THEN
+ CALL DGEMM( 'No transpose',
+ $ 'No transpose', QROWS,
+ $ DIM4, NWIN, ONE,
+ $ WORK( IPW7 ), QROWS,
+ $ WORK( IPW4+NWIN*DIM1 ),
+ $ NWIN, ZERO, WORK(IPW8),
+ $ QROWS )
+ CALL DLAMOV( 'All', QROWS,
+ $ DIM4, WORK(IPW8), QROWS,
+ $ Q((JLOC-1)*LLDQ+ILOC),
+ $ LLDQ )
+ END IF
+ END IF
+ 450 CONTINUE
+ END IF
+ END IF
+*
+* Update the rows of T affected by the
+* reordering.
+*
+ IF( DIR.EQ.1 ) THEN
+ IF ( LIHIC.LT.N ) THEN
+ IF( MYROW.EQ.RSRC1.AND.MYCOL.EQ.CSRC4
+ $ .AND.MOD(LIHIC,NB).NE.0 ) THEN
+ INDX = LIHIC + 1
+ CALL INFOG2L( I, INDX, DESCT, NPROW,
+ $ NPCOL, MYROW, MYCOL, ILOC,
+ $ JLOC, RSRC1, CSRC4 )
+ CALL DGEMM( 'Transpose',
+ $ 'No Transpose', DIM1, TCOLS,
+ $ NWIN, ONE, WORK(IPW4), NWIN,
+ $ WORK( IPW6 ), NWIN, ZERO,
+ $ WORK(IPW8), DIM1 )
+ CALL DLAMOV( 'All', DIM1, TCOLS,
+ $ WORK(IPW8), DIM1,
+ $ T((JLOC-1)*LLDT+ILOC), LLDT )
+ END IF
+ IF( MYROW.EQ.RSRC4.AND.MYCOL.EQ.CSRC4
+ $ .AND.MOD(LIHIC,NB).NE.0 ) THEN
+ INDX = LIHIC + 1
+ CALL INFOG2L( I+DIM1, INDX, DESCT,
+ $ NPROW, NPCOL, MYROW, MYCOL,
+ $ ILOC, JLOC, RSRC4, CSRC4 )
+ CALL DGEMM( 'Transpose',
+ $ 'No Transpose', DIM4, TCOLS,
+ $ NWIN, ONE,
+ $ WORK( IPW4+DIM1*NWIN ), NWIN,
+ $ WORK( IPW6), NWIN, ZERO,
+ $ WORK(IPW8), DIM4 )
+ CALL DLAMOV( 'All', DIM4, TCOLS,
+ $ WORK(IPW8), DIM4,
+ $ T((JLOC-1)*LLDT+ILOC), LLDT )
+ END IF
+ INDXS = ICEIL(LIHIC,NB)*NB + 1
+ INDXE = MIN(N,INDXS+(NPCOL-2)*NB)
+ DO 460 INDX = INDXS, INDXE, NB
+ IF( MYROW.EQ.RSRC1 ) THEN
+ CALL INFOG2L( I, INDX, DESCT,
+ $ NPROW, NPCOL, MYROW, MYCOL,
+ $ ILOC, JLOC, RSRC1, CSRC )
+ IF( MYCOL.EQ.CSRC ) THEN
+ CALL DGEMM( 'Transpose',
+ $ 'No Transpose', DIM1,
+ $ TCOLS, NWIN, ONE,
+ $ WORK( IPW4 ), NWIN,
+ $ WORK( IPW6 ), NWIN,
+ $ ZERO, WORK(IPW8), DIM1 )
+ CALL DLAMOV( 'All', DIM1,
+ $ TCOLS, WORK(IPW8), DIM1,
+ $ T((JLOC-1)*LLDT+ILOC),
+ $ LLDT )
+ END IF
+ END IF
+ IF( MYROW.EQ.RSRC4 ) THEN
+ CALL INFOG2L( I+DIM1, INDX,
+ $ DESCT, NPROW, NPCOL, MYROW,
+ $ MYCOL, ILOC, JLOC, RSRC4,
+ $ CSRC )
+ IF( MYCOL.EQ.CSRC ) THEN
+ CALL DGEMM( 'Transpose',
+ $ 'No Transpose', DIM4,
+ $ TCOLS, NWIN, ONE,
+ $ WORK( IPW4+NWIN*DIM1 ),
+ $ NWIN, WORK( IPW6 ),
+ $ NWIN, ZERO, WORK(IPW8),
+ $ DIM4 )
+ CALL DLAMOV( 'All', DIM4,
+ $ TCOLS, WORK(IPW8), DIM4,
+ $ T((JLOC-1)*LLDT+ILOC),
+ $ LLDT )
+ END IF
+ END IF
+ 460 CONTINUE
+ END IF
+ END IF
+ ELSE
+*
+* The NWIN-by-NWIN matrix U containing the
+* accumulated orthogonal transformations has
+* the following structure:
+*
+* [ U11 U12 ]
+* U = [ ],
+* [ U21 U22 ]
+*
+* where U21 is KS-by-KS upper triangular and
+* U12 is (NWIN-KS)-by-(NWIN-KS) lower
+* triangular. For reordering over the border
+* the structure is only exploited when the
+* border cuts the columns of U conformally with
+* the structure itself. This happens exactly
+* when all eigenvalues in the subcluster was
+* moved to the other side of the border and
+* fits perfectly in their new positions, i.e.,
+* the reordering stops when the last eigenvalue
+* to cross the border is reordered to the
+* position closest to the border. Tested by
+* checking is KS = DIM1 = DIM4 (see above).
+* This should hold quite often. But this branch
+* is entered only if all involved eigenvalues
+* are real.
+*
+* Update the columns of T and Q affected by the
+* reordering.
+*
+* Compute T2*U21 + T1*U11 on the left side of
+* the border.
+*
+ IF( DIR.EQ.2 ) THEN
+ INDXE = MIN(I-1,1+(NPROW-1)*NB)
+ DO 470 INDX = 1, INDXE, NB
+ IF( MYCOL.EQ.CSRC1 ) THEN
+ CALL INFOG2L( INDX, I, DESCT, NPROW,
+ $ NPCOL, MYROW, MYCOL, ILOC,
+ $ JLOC, RSRC, CSRC1 )
+ IF( MYROW.EQ.RSRC ) THEN
+ CALL DLAMOV( 'All', TROWS, KS,
+ $ WORK( IPW5+TROWS*DIM4),
+ $ TROWS, WORK(IPW8), TROWS )
+ CALL DTRMM( 'Right', 'Upper',
+ $ 'No transpose',
+ $ 'Non-unit', TROWS, KS,
+ $ ONE, WORK( IPW4+DIM4 ),
+ $ NWIN, WORK(IPW8), TROWS )
+ CALL DGEMM( 'No transpose',
+ $ 'No transpose', TROWS, KS,
+ $ DIM4, ONE, WORK( IPW5 ),
+ $ TROWS, WORK( IPW4 ), NWIN,
+ $ ONE, WORK(IPW8), TROWS )
+ CALL DLAMOV( 'All', TROWS, KS,
+ $ WORK(IPW8), TROWS,
+ $ T((JLOC-1)*LLDT+ILOC),
+ $ LLDT )
+ END IF
+ END IF
+*
+* Compute T1*U12 + T2*U22 on the right
+* side of the border.
+*
+ IF( MYCOL.EQ.CSRC4 ) THEN
+ CALL INFOG2L( INDX, I+DIM1, DESCT,
+ $ NPROW, NPCOL, MYROW, MYCOL,
+ $ ILOC, JLOC, RSRC, CSRC4 )
+ IF( MYROW.EQ.RSRC ) THEN
+ CALL DLAMOV( 'All', TROWS, DIM4,
+ $ WORK(IPW5), TROWS,
+ $ WORK( IPW8 ), TROWS )
+ CALL DTRMM( 'Right', 'Lower',
+ $ 'No transpose',
+ $ 'Non-unit', TROWS, DIM4,
+ $ ONE, WORK( IPW4+NWIN*KS ),
+ $ NWIN, WORK( IPW8 ), TROWS )
+ CALL DGEMM( 'No transpose',
+ $ 'No transpose', TROWS, DIM4,
+ $ KS, ONE,
+ $ WORK( IPW5+TROWS*DIM4),
+ $ TROWS,
+ $ WORK( IPW4+NWIN*KS+DIM4 ),
+ $ NWIN, ONE, WORK( IPW8 ),
+ $ TROWS )
+ CALL DLAMOV( 'All', TROWS, DIM4,
+ $ WORK(IPW8), TROWS,
+ $ T((JLOC-1)*LLDT+ILOC),
+ $ LLDT )
+ END IF
+ END IF
+ 470 CONTINUE
+ IF( WANTQ ) THEN
+*
+* Compute Q2*U21 + Q1*U11 on the left
+* side of border.
+*
+ INDXE = MIN(N,1+(NPROW-1)*NB)
+ DO 480 INDX = 1, INDXE, NB
+ IF( MYCOL.EQ.CSRC1 ) THEN
+ CALL INFOG2L( INDX, I, DESCQ,
+ $ NPROW, NPCOL, MYROW, MYCOL,
+ $ ILOC, JLOC, RSRC, CSRC1 )
+ IF( MYROW.EQ.RSRC ) THEN
+ CALL DLAMOV( 'All', QROWS, KS,
+ $ WORK( IPW7+QROWS*DIM4),
+ $ QROWS, WORK(IPW8),
+ $ QROWS )
+ CALL DTRMM( 'Right', 'Upper',
+ $ 'No transpose',
+ $ 'Non-unit', QROWS,
+ $ KS, ONE,
+ $ WORK( IPW4+DIM4 ), NWIN,
+ $ WORK(IPW8), QROWS )
+ CALL DGEMM( 'No transpose',
+ $ 'No transpose', QROWS,
+ $ KS, DIM4, ONE,
+ $ WORK( IPW7 ), QROWS,
+ $ WORK( IPW4 ), NWIN, ONE,
+ $ WORK(IPW8), QROWS )
+ CALL DLAMOV( 'All', QROWS, KS,
+ $ WORK(IPW8), QROWS,
+ $ Q((JLOC-1)*LLDQ+ILOC),
+ $ LLDQ )
+ END IF
+ END IF
+*
+* Compute Q1*U12 + Q2*U22 on the right
+* side of border.
+*
+ IF( MYCOL.EQ.CSRC4 ) THEN
+ CALL INFOG2L( INDX, I+DIM1,
+ $ DESCQ, NPROW, NPCOL, MYROW,
+ $ MYCOL, ILOC, JLOC, RSRC,
+ $ CSRC4 )
+ IF( MYROW.EQ.RSRC ) THEN
+ CALL DLAMOV( 'All', QROWS,
+ $ DIM4, WORK(IPW7), QROWS,
+ $ WORK( IPW8 ), QROWS )
+ CALL DTRMM( 'Right', 'Lower',
+ $ 'No transpose',
+ $ 'Non-unit', QROWS,
+ $ DIM4, ONE,
+ $ WORK( IPW4+NWIN*KS ),
+ $ NWIN, WORK( IPW8 ),
+ $ QROWS )
+ CALL DGEMM( 'No transpose',
+ $ 'No transpose', QROWS,
+ $ DIM4, KS, ONE,
+ $ WORK(IPW7+QROWS*(DIM4)),
+ $ QROWS,
+ $ WORK(IPW4+NWIN*KS+DIM4),
+ $ NWIN, ONE, WORK( IPW8 ),
+ $ QROWS )
+ CALL DLAMOV( 'All', QROWS,
+ $ DIM4, WORK(IPW8), QROWS,
+ $ Q((JLOC-1)*LLDQ+ILOC),
+ $ LLDQ )
+ END IF
+ END IF
+ 480 CONTINUE
+ END IF
+ END IF
+*
+ IF( DIR.EQ.1 ) THEN
+ IF ( LIHIC.LT.N ) THEN
+*
+* Compute U21**T*T2 + U11**T*T1 on the
+* upper side of the border.
+*
+ IF( MYROW.EQ.RSRC1.AND.MYCOL.EQ.CSRC4
+ $ .AND.MOD(LIHIC,NB).NE.0 ) THEN
+ INDX = LIHIC + 1
+ CALL INFOG2L( I, INDX, DESCT, NPROW,
+ $ NPCOL, MYROW, MYCOL, ILOC,
+ $ JLOC, RSRC1, CSRC4 )
+ CALL DLAMOV( 'All', KS, TCOLS,
+ $ WORK( IPW6+DIM4 ), NWIN,
+ $ WORK(IPW8), KS )
+ CALL DTRMM( 'Left', 'Upper',
+ $ 'Transpose', 'Non-unit',
+ $ KS, TCOLS, ONE,
+ $ WORK( IPW4+DIM4 ), NWIN,
+ $ WORK(IPW8), KS )
+ CALL DGEMM( 'Transpose',
+ $ 'No transpose', KS, TCOLS,
+ $ DIM4, ONE, WORK(IPW4), NWIN,
+ $ WORK(IPW6), NWIN, ONE,
+ $ WORK(IPW8), KS )
+ CALL DLAMOV( 'All', KS, TCOLS,
+ $ WORK(IPW8), KS,
+ $ T((JLOC-1)*LLDT+ILOC), LLDT )
+ END IF
+*
+* Compute U12**T*T1 + U22**T*T2 on the
+* lower side of the border.
+*
+ IF( MYROW.EQ.RSRC4.AND.MYCOL.EQ.CSRC4
+ $ .AND.MOD(LIHIC,NB).NE.0 ) THEN
+ INDX = LIHIC + 1
+ CALL INFOG2L( I+DIM1, INDX, DESCT,
+ $ NPROW, NPCOL, MYROW, MYCOL,
+ $ ILOC, JLOC, RSRC4, CSRC4 )
+ CALL DLAMOV( 'All', DIM4, TCOLS,
+ $ WORK( IPW6 ), NWIN,
+ $ WORK( IPW8 ), DIM4 )
+ CALL DTRMM( 'Left', 'Lower',
+ $ 'Transpose', 'Non-unit',
+ $ DIM4, TCOLS, ONE,
+ $ WORK( IPW4+NWIN*KS ), NWIN,
+ $ WORK( IPW8 ), DIM4 )
+ CALL DGEMM( 'Transpose',
+ $ 'No Transpose', DIM4, TCOLS,
+ $ KS, ONE,
+ $ WORK( IPW4+NWIN*KS+DIM4 ),
+ $ NWIN, WORK( IPW6+DIM1 ), NWIN,
+ $ ONE, WORK( IPW8), DIM4 )
+ CALL DLAMOV( 'All', DIM4, TCOLS,
+ $ WORK(IPW8), DIM4,
+ $ T((JLOC-1)*LLDT+ILOC), LLDT )
+ END IF
+*
+* Compute U21**T*T2 + U11**T*T1 on upper
+* side on border.
+*
+ INDXS = ICEIL(LIHIC,NB)*NB+1
+ INDXE = MIN(N,INDXS+(NPCOL-2)*NB)
+ DO 490 INDX = INDXS, INDXE, NB
+ IF( MYROW.EQ.RSRC1 ) THEN
+ CALL INFOG2L( I, INDX, DESCT,
+ $ NPROW, NPCOL, MYROW, MYCOL,
+ $ ILOC, JLOC, RSRC1, CSRC )
+ IF( MYCOL.EQ.CSRC ) THEN
+ CALL DLAMOV( 'All', KS, TCOLS,
+ $ WORK( IPW6+DIM4 ), NWIN,
+ $ WORK(IPW8), KS )
+ CALL DTRMM( 'Left', 'Upper',
+ $ 'Transpose',
+ $ 'Non-unit', KS,
+ $ TCOLS, ONE,
+ $ WORK( IPW4+DIM4 ), NWIN,
+ $ WORK(IPW8), KS )
+ CALL DGEMM( 'Transpose',
+ $ 'No transpose', KS,
+ $ TCOLS, DIM4, ONE,
+ $ WORK(IPW4), NWIN,
+ $ WORK(IPW6), NWIN, ONE,
+ $ WORK(IPW8), KS )
+ CALL DLAMOV( 'All', KS, TCOLS,
+ $ WORK(IPW8), KS,
+ $ T((JLOC-1)*LLDT+ILOC),
+ $ LLDT )
+ END IF
+ END IF
+*
+* Compute U12**T*T1 + U22**T*T2 on
+* lower side of border.
+*
+ IF( MYROW.EQ.RSRC4 ) THEN
+ CALL INFOG2L( I+DIM1, INDX,
+ $ DESCT, NPROW, NPCOL, MYROW,
+ $ MYCOL, ILOC, JLOC, RSRC4,
+ $ CSRC )
+ IF( MYCOL.EQ.CSRC ) THEN
+ CALL DLAMOV( 'All', DIM4,
+ $ TCOLS, WORK( IPW6 ),
+ $ NWIN, WORK( IPW8 ),
+ $ DIM4 )
+ CALL DTRMM( 'Left', 'Lower',
+ $ 'Transpose',
+ $ 'Non-unit', DIM4,
+ $ TCOLS, ONE,
+ $ WORK( IPW4+NWIN*KS ),
+ $ NWIN, WORK( IPW8 ),
+ $ DIM4 )
+ CALL DGEMM( 'Transpose',
+ $ 'No Transpose', DIM4,
+ $ TCOLS, KS, ONE,
+ $ WORK(IPW4+NWIN*KS+DIM4),
+ $ NWIN, WORK( IPW6+DIM1 ),
+ $ NWIN, ONE, WORK( IPW8),
+ $ DIM4 )
+ CALL DLAMOV( 'All', DIM4,
+ $ TCOLS, WORK(IPW8), DIM4,
+ $ T((JLOC-1)*LLDT+ILOC),
+ $ LLDT )
+ END IF
+ END IF
+ 490 CONTINUE
+ END IF
+ END IF
+ END IF
+ ELSEIF( FLOPS.NE.0 ) THEN
+*
+* Update off-diagonal blocks and Q using the
+* pipelined elementary transformations. Now we
+* have a delicate problem: how to do this without
+* redundant work? For now, we let the processes
+* involved compute the whole crossborder block
+* rows and column saving only the part belonging
+* to the corresponding side of the border. To make
+* this a realistic alternative, we have modified
+* the ratio r_flops (see Reference [2] above) to
+* give more favor to the ordinary matrix
+* multiplication.
+*
+ IF( DIR.EQ.2 ) THEN
+ INDXE = MIN(I-1,1+(NPROW-1)*NB)
+ DO 500 INDX = 1, INDXE, NB
+ CALL INFOG2L( INDX, I, DESCT, NPROW,
+ $ NPCOL, MYROW, MYCOL, ILOC, JLOC,
+ $ RSRC, CSRC )
+ IF( MYROW.EQ.RSRC .AND. MYCOL.EQ.CSRC )
+ $ THEN
+ CALL BDLAAPP( 1, TROWS, NWIN, NCB,
+ $ WORK(IPW5), TROWS, NITRAF,
+ $ IWORK(IPIW), WORK( IPW3 ),
+ $ WORK(IPW8) )
+ CALL DLAMOV( 'All', TROWS, DIM1,
+ $ WORK(IPW5), TROWS,
+ $ T((JLOC-1)*LLDT+ILOC ), LLDT )
+ END IF
+ CALL INFOG2L( INDX, I+DIM1, DESCT, NPROW,
+ $ NPCOL, MYROW, MYCOL, ILOC, JLOC,
+ $ RSRC, CSRC )
+ IF( MYROW.EQ.RSRC .AND. MYCOL.EQ.CSRC )
+ $ THEN
+ IF( NPCOL.GT.1 )
+ $ CALL BDLAAPP( 1, TROWS, NWIN, NCB,
+ $ WORK(IPW5), TROWS, NITRAF,
+ $ IWORK(IPIW), WORK( IPW3 ),
+ $ WORK(IPW8) )
+ CALL DLAMOV( 'All', TROWS, DIM4,
+ $ WORK(IPW5+TROWS*DIM1), TROWS,
+ $ T((JLOC-1)*LLDT+ILOC ), LLDT )
+ END IF
+ 500 CONTINUE
+ IF( WANTQ ) THEN
+ INDXE = MIN(N,1+(NPROW-1)*NB)
+ DO 510 INDX = 1, INDXE, NB
+ CALL INFOG2L( INDX, I, DESCQ, NPROW,
+ $ NPCOL, MYROW, MYCOL, ILOC, JLOC,
+ $ RSRC, CSRC )
+ IF( MYROW.EQ.RSRC .AND. MYCOL.EQ.CSRC )
+ $ THEN
+ CALL BDLAAPP( 1, QROWS, NWIN, NCB,
+ $ WORK(IPW7), QROWS, NITRAF,
+ $ IWORK(IPIW), WORK( IPW3 ),
+ $ WORK(IPW8) )
+ CALL DLAMOV( 'All', QROWS, DIM1,
+ $ WORK(IPW7), QROWS,
+ $ Q((JLOC-1)*LLDQ+ILOC ), LLDQ )
+ END IF
+ CALL INFOG2L( INDX, I+DIM1, DESCQ,
+ $ NPROW, NPCOL, MYROW, MYCOL, ILOC,
+ $ JLOC, RSRC, CSRC )
+ IF( MYROW.EQ.RSRC .AND. MYCOL.EQ.CSRC )
+ $ THEN
+ IF( NPCOL.GT.1 )
+ $ CALL BDLAAPP( 1, QROWS, NWIN,
+ $ NCB, WORK(IPW7), QROWS,
+ $ NITRAF, IWORK(IPIW),
+ $ WORK( IPW3 ), WORK(IPW8) )
+ CALL DLAMOV( 'All', QROWS, DIM4,
+ $ WORK(IPW7+QROWS*DIM1), QROWS,
+ $ Q((JLOC-1)*LLDQ+ILOC ), LLDQ )
+ END IF
+ 510 CONTINUE
+ END IF
+ END IF
+*
+ IF( DIR.EQ.1 ) THEN
+ IF( LIHIC.LT.N ) THEN
+ INDX = LIHIC + 1
+ CALL INFOG2L( I, INDX, DESCT, NPROW,
+ $ NPCOL, MYROW, MYCOL, ILOC, JLOC,
+ $ RSRC, CSRC )
+ IF( MYROW.EQ.RSRC .AND. MYCOL.EQ.CSRC.AND.
+ $ MOD(LIHIC,NB).NE.0 ) THEN
+ CALL BDLAAPP( 0, NWIN, TCOLS, NCB,
+ $ WORK( IPW6 ), NWIN, NITRAF,
+ $ IWORK(IPIW), WORK( IPW3 ),
+ $ WORK(IPW8) )
+ CALL DLAMOV( 'All', DIM1, TCOLS,
+ $ WORK( IPW6 ), NWIN,
+ $ T((JLOC-1)*LLDT+ILOC), LLDT )
+ END IF
+ CALL INFOG2L( I+DIM1, INDX, DESCT, NPROW,
+ $ NPCOL, MYROW, MYCOL, ILOC, JLOC,
+ $ RSRC, CSRC )
+ IF( MYROW.EQ.RSRC .AND. MYCOL.EQ.CSRC.AND.
+ $ MOD(LIHIC,NB).NE.0 ) THEN
+ IF( NPROW.GT.1 )
+ $ CALL BDLAAPP( 0, NWIN, TCOLS, NCB,
+ $ WORK( IPW6 ), NWIN, NITRAF,
+ $ IWORK(IPIW), WORK( IPW3 ),
+ $ WORK(IPW8) )
+ CALL DLAMOV( 'All', DIM4, TCOLS,
+ $ WORK( IPW6+DIM1 ), NWIN,
+ $ T((JLOC-1)*LLDT+ILOC), LLDT )
+ END IF
+ INDXS = ICEIL(LIHIC,NB)*NB + 1
+ INDXE = MIN(N,INDXS+(NPCOL-2)*NB)
+ DO 520 INDX = INDXS, INDXE, NB
+ CALL INFOG2L( I, INDX, DESCT, NPROW,
+ $ NPCOL, MYROW, MYCOL, ILOC, JLOC,
+ $ RSRC, CSRC )
+ IF( MYROW.EQ.RSRC .AND. MYCOL.EQ.CSRC )
+ $ THEN
+ CALL BDLAAPP( 0, NWIN, TCOLS, NCB,
+ $ WORK(IPW6), NWIN, NITRAF,
+ $ IWORK(IPIW), WORK( IPW3 ),
+ $ WORK(IPW8) )
+ CALL DLAMOV( 'All', DIM1, TCOLS,
+ $ WORK( IPW6 ), NWIN,
+ $ T((JLOC-1)*LLDT+ILOC), LLDT )
+ END IF
+ CALL INFOG2L( I+DIM1, INDX, DESCT,
+ $ NPROW, NPCOL, MYROW, MYCOL, ILOC,
+ $ JLOC, RSRC, CSRC )
+ IF( MYROW.EQ.RSRC .AND. MYCOL.EQ.CSRC )
+ $ THEN
+ IF( NPROW.GT.1 )
+ $ CALL BDLAAPP( 0, NWIN, TCOLS,
+ $ NCB, WORK(IPW6), NWIN, NITRAF,
+ $ IWORK(IPIW), WORK( IPW3 ),
+ $ WORK(IPW8) )
+ CALL DLAMOV( 'All', DIM4, TCOLS,
+ $ WORK( IPW6+DIM1 ), NWIN,
+ $ T((JLOC-1)*LLDT+ILOC), LLDT )
+ END IF
+ 520 CONTINUE
+ END IF
+ END IF
+ END IF
+ END IF
+*
+ 328 CONTINUE
+*
+ 323 CONTINUE
+*
+* End of loops over directions (DIR).
+*
+ 2222 CONTINUE
+*
+* End of loops over diagonal blocks for reordering over the
+* block diagonal.
+*
+ 310 CONTINUE
+ LAST = LAST + 1
+ IF( LASTWAIT .AND. LAST.LT.2 ) GO TO 308
+*
+* Barrier to collect the processes before proceeding.
+*
+ CALL BLACS_BARRIER( ICTXT, 'All' )
+*
+* Compute global maximum of IERR so that we know if some process
+* experienced a failure in the reordering.
+*
+ MYIERR = IERR
+ IF( NPROCS.GT.1 )
+ $ CALL IGAMX2D( ICTXT, 'All', TOP, 1, 1, IERR, 1, -1,
+ $ -1, -1, -1, -1 )
+*
+ IF( IERR.NE.0 ) THEN
+*
+* When calling BDTREXC, the block at position I+KKS-1 failed
+* to swap.
+*
+ IF( MYIERR.NE.0 ) INFO = MAX(1,I+KKS-1)
+ IF( NPROCS.GT.1 )
+ $ CALL IGAMX2D( ICTXT, 'All', TOP, 1, 1, INFO, 1, -1,
+ $ -1, -1, -1, -1 )
+ GO TO 300
+ END IF
+*
+* Do a global update of the SELECT vector.
+*
+ DO 530 K = 1, N
+ RSRC = INDXG2P( K, NB, MYROW, DESCT( RSRC_ ), NPROW )
+ CSRC = INDXG2P( K, NB, MYCOL, DESCT( CSRC_ ), NPCOL )
+ IF( MYROW.NE.RSRC .OR. MYCOL.NE.CSRC )
+ $ SELECT( K ) = 0
+ 530 CONTINUE
+ IF( NPROCS.GT.1 )
+ $ CALL IGSUM2D( ICTXT, 'All', TOP, N, 1, SELECT, N, -1, -1 )
+*
+* Find the global minumum of ILO and IHI.
+*
+ ILO = ILO - 1
+ 523 CONTINUE
+ ILO = ILO + 1
+ IF( ILO.LE.N ) THEN
+ IF( SELECT(ILO).NE.0 ) GO TO 523
+ END IF
+ IHI = IHI + 1
+ 527 CONTINUE
+ IHI = IHI - 1
+ IF( IHI.GE.1 ) THEN
+ IF( SELECT(IHI).EQ.0 ) GO TO 527
+ END IF
+*
+* End While ( ILO <= M )
+ GO TO 50
+ END IF
+*
+ 300 CONTINUE
+*
+* In case an error occured, do an additional global update of
+* SELECT.
+*
+ IF( INFO.NE.0 ) THEN
+ DO 540 K = 1, N
+ RSRC = INDXG2P( K, NB, MYROW, DESCT( RSRC_ ), NPROW )
+ CSRC = INDXG2P( K, NB, MYCOL, DESCT( CSRC_ ), NPCOL )
+ IF( MYROW.NE.RSRC .OR. MYCOL.NE.CSRC )
+ $ SELECT( K ) = 0
+ 540 CONTINUE
+ IF( NPROCS.GT.1 )
+ $ CALL IGSUM2D( ICTXT, 'All', TOP, N, 1, SELECT, N, -1, -1 )
+ END IF
+*
+ 545 CONTINUE
+*
+* Store the output eigenvalues in WR and WI: first let all the
+* processes compute the eigenvalue inside their diagonal blocks in
+* parallel, except for the eigenvalue located next to a block
+* border. After that, compute all eigenvalues located next to the
+* block borders. Finally, do a global summation over WR and WI so
+* that all processors receive the result. Notice: real eigenvalues
+* extracted from a non-canonical 2-by-2 block are not stored in
+* any particular order.
+*
+ DO 550 K = 1, N
+ WR( K ) = ZERO
+ WI( K ) = ZERO
+ 550 CONTINUE
+*
+* Loop 560: extract eigenvalues from the blocks which are not laid
+* out across a border of the processor mesh, except for those 1x1
+* blocks on the border.
+*
+ PAIR = .FALSE.
+ DO 560 K = 1, N
+ IF( .NOT. PAIR ) THEN
+ BORDER = ( K.NE.N .AND. MOD( K, NB ).EQ.0 ) .OR.
+ % ( K.NE.1 .AND. MOD( K, NB ).EQ.1 )
+ IF( .NOT. BORDER ) THEN
+ CALL INFOG2L( K, K, DESCT, NPROW, NPCOL, MYROW, MYCOL,
+ $ ILOC1, JLOC1, TRSRC1, TCSRC1 )
+ IF( MYROW.EQ.TRSRC1 .AND. MYCOL.EQ.TCSRC1 ) THEN
+ ELEM1 = T((JLOC1-1)*LLDT+ILOC1)
+ IF( K.LT.N ) THEN
+ ELEM3 = T((JLOC1-1)*LLDT+ILOC1+1)
+ ELSE
+ ELEM3 = ZERO
+ END IF
+ IF( ELEM3.NE.ZERO ) THEN
+ ELEM2 = T((JLOC1)*LLDT+ILOC1)
+ ELEM4 = T((JLOC1)*LLDT+ILOC1+1)
+ CALL DLANV2( ELEM1, ELEM2, ELEM3, ELEM4,
+ $ WR( K ), WI( K ), WR( K+1 ), WI( K+1 ), SN,
+ $ CS )
+ PAIR = .TRUE.
+ ELSE
+ IF( K.GT.1 ) THEN
+ TMP = T((JLOC1-2)*LLDT+ILOC1)
+ IF( TMP.NE.ZERO ) THEN
+ ELEM1 = T((JLOC1-2)*LLDT+ILOC1-1)
+ ELEM2 = T((JLOC1-1)*LLDT+ILOC1-1)
+ ELEM3 = T((JLOC1-2)*LLDT+ILOC1)
+ ELEM4 = T((JLOC1-1)*LLDT+ILOC1)
+ CALL DLANV2( ELEM1, ELEM2, ELEM3, ELEM4,
+ $ WR( K-1 ), WI( K-1 ), WR( K ),
+ $ WI( K ), SN, CS )
+ ELSE
+ WR( K ) = ELEM1
+ END IF
+ ELSE
+ WR( K ) = ELEM1
+ END IF
+ END IF
+ END IF
+ END IF
+ ELSE
+ PAIR = .FALSE.
+ END IF
+ 560 CONTINUE
+*
+* Loop 570: extract eigenvalues from the blocks which are laid
+* out across a border of the processor mesh. The processors are
+* numbered as below:
+*
+* 1 | 2
+* --+--
+* 3 | 4
+*
+ DO 570 K = NB, N-1, NB
+ CALL INFOG2L( K, K, DESCT, NPROW, NPCOL, MYROW, MYCOL,
+ $ ILOC1, JLOC1, TRSRC1, TCSRC1 )
+ CALL INFOG2L( K, K+1, DESCT, NPROW, NPCOL, MYROW, MYCOL,
+ $ ILOC2, JLOC2, TRSRC2, TCSRC2 )
+ CALL INFOG2L( K+1, K, DESCT, NPROW, NPCOL, MYROW, MYCOL,
+ $ ILOC3, JLOC3, TRSRC3, TCSRC3 )
+ CALL INFOG2L( K+1, K+1, DESCT, NPROW, NPCOL, MYROW, MYCOL,
+ $ ILOC4, JLOC4, TRSRC4, TCSRC4 )
+ IF( MYROW.EQ.TRSRC2 .AND. MYCOL.EQ.TCSRC2 ) THEN
+ ELEM2 = T((JLOC2-1)*LLDT+ILOC2)
+ IF( TRSRC1.NE.TRSRC2 .OR. TCSRC1.NE.TCSRC2 )
+ $ CALL DGESD2D( ICTXT, 1, 1, ELEM2, 1, TRSRC1, TCSRC1 )
+ END IF
+ IF( MYROW.EQ.TRSRC3 .AND. MYCOL.EQ.TCSRC3 ) THEN
+ ELEM3 = T((JLOC3-1)*LLDT+ILOC3)
+ IF( TRSRC1.NE.TRSRC3 .OR. TCSRC1.NE.TCSRC3 )
+ $ CALL DGESD2D( ICTXT, 1, 1, ELEM3, 1, TRSRC1, TCSRC1 )
+ END IF
+ IF( MYROW.EQ.TRSRC4 .AND. MYCOL.EQ.TCSRC4 ) THEN
+ WORK(1) = T((JLOC4-1)*LLDT+ILOC4)
+ IF( K+1.LT.N ) THEN
+ WORK(2) = T((JLOC4-1)*LLDT+ILOC4+1)
+ ELSE
+ WORK(2) = ZERO
+ END IF
+ IF( TRSRC1.NE.TRSRC4 .OR. TCSRC1.NE.TCSRC4 )
+ $ CALL DGESD2D( ICTXT, 2, 1, WORK, 2, TRSRC1, TCSRC1 )
+ END IF
+ IF( MYROW.EQ.TRSRC1 .AND. MYCOL.EQ.TCSRC1 ) THEN
+ ELEM1 = T((JLOC1-1)*LLDT+ILOC1)
+ IF( TRSRC1.NE.TRSRC2 .OR. TCSRC1.NE.TCSRC2 )
+ $ CALL DGERV2D( ICTXT, 1, 1, ELEM2, 1, TRSRC2, TCSRC2 )
+ IF( TRSRC1.NE.TRSRC3 .OR. TCSRC1.NE.TCSRC3 )
+ $ CALL DGERV2D( ICTXT, 1, 1, ELEM3, 1, TRSRC3, TCSRC3 )
+ IF( TRSRC1.NE.TRSRC4 .OR. TCSRC1.NE.TCSRC4 )
+ $ CALL DGERV2D( ICTXT, 2, 1, WORK, 2, TRSRC4, TCSRC4 )
+ ELEM4 = WORK(1)
+ ELEM5 = WORK(2)
+ IF( ELEM5.EQ.ZERO ) THEN
+ IF( WR( K ).EQ.ZERO .AND. WI( K ).EQ.ZERO ) THEN
+ CALL DLANV2( ELEM1, ELEM2, ELEM3, ELEM4, WR( K ),
+ $ WI( K ), WR( K+1 ), WI( K+1 ), SN, CS )
+ ELSEIF( WR( K+1 ).EQ.ZERO .AND. WI( K+1 ).EQ.ZERO ) THEN
+ WR( K+1 ) = ELEM4
+ END IF
+ ELSEIF( WR( K ).EQ.ZERO .AND. WI( K ).EQ.ZERO ) THEN
+ WR( K ) = ELEM1
+ END IF
+ END IF
+ 570 CONTINUE
+*
+ IF( NPROCS.GT.1 ) THEN
+ CALL DGSUM2D( ICTXT, 'All', TOP, N, 1, WR, N, -1, -1 )
+ CALL DGSUM2D( ICTXT, 'All', TOP, N, 1, WI, N, -1, -1 )
+ END IF
+*
+* Store storage requirements in workspaces.
+*
+ WORK( 1 ) = DBLE(LWMIN)
+ IWORK( 1 ) = LIWMIN
+*
+* Return to calling program.
+*
+ RETURN
+*
+* End of PDTRORD
+*
+ END
+*
diff --git a/SRC/pdtrsen.f b/SRC/pdtrsen.f
new file mode 100644
index 0000000..78c5599
--- /dev/null
+++ b/SRC/pdtrsen.f
@@ -0,0 +1,709 @@
+ SUBROUTINE PDTRSEN( JOB, COMPQ, SELECT, PARA, N, T, IT, JT,
+ $ DESCT, Q, IQ, JQ, DESCQ, WR, WI, M, S, SEP, WORK, LWORK,
+ $ IWORK, LIWORK, INFO )
+*
+* Contribution from the Department of Computing Science and HPC2N,
+* Umea University, Sweden
+*
+* -- ScaLAPACK computational routine (version 2.0.1) --
+* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
+* Univ. of Colorado Denver and University of California, Berkeley.
+* January, 2012
+*
+ IMPLICIT NONE
+*
+* .. Scalar Arguments ..
+ CHARACTER COMPQ, JOB
+ INTEGER INFO, LIWORK, LWORK, M, N,
+ $ IT, JT, IQ, JQ
+ DOUBLE PRECISION S, SEP
+* ..
+* .. Array Arguments ..
+ LOGICAL SELECT( N )
+ INTEGER PARA( 6 ), DESCT( * ), DESCQ( * ), IWORK( * )
+ DOUBLE PRECISION Q( * ), T( * ), WI( * ), WORK( * ), WR( * )
+* ..
+*
+* Purpose
+* =======
+*
+* PDTRSEN 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. The reordering is performed
+* by PDTRORD.
+*
+* Optionally the routine computes the reciprocal condition numbers of
+* the cluster of eigenvalues and/or the invariant subspace. SCASY
+* library is needed for condition estimation.
+*
+* T must be in Schur form (as returned by PDLAHQR), that is, block
+* upper triangular with 1-by-1 and 2-by-2 diagonal blocks.
+*
+* Notes
+* =====
+*
+* Each global data object is described by an associated description
+* vector. This vector stores the information required to establish
+* the mapping between an object element and its corresponding process
+* and memory location.
+*
+* Let A be a generic term for any 2D block cyclicly distributed array.
+* Such a global array has an associated description vector DESCA.
+* In the following comments, the character _ should be read as
+* "of the global array".
+*
+* NOTATION STORED IN EXPLANATION
+* --------------- -------------- --------------------------------------
+* DTYPE_A(global) DESCA( DTYPE_ )The descriptor type. In this case,
+* DTYPE_A = 1.
+* CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating
+* the BLACS process grid A is distribu-
+* ted over. The context itself is glo-
+* bal, but the handle (the integer
+* value) may vary.
+* M_A (global) DESCA( M_ ) The number of rows in the global
+* array A.
+* N_A (global) DESCA( N_ ) The number of columns in the global
+* array A.
+* MB_A (global) DESCA( MB_ ) The blocking factor used to distribute
+* the rows of the array.
+* NB_A (global) DESCA( NB_ ) The blocking factor used to distribute
+* the columns of the array.
+* RSRC_A (global) DESCA( RSRC_ ) The process row over which the first
+* row of the array A is distributed.
+* CSRC_A (global) DESCA( CSRC_ ) The process column over which the
+* first column of the array A is
+* distributed.
+* LLD_A (local) DESCA( LLD_ ) The leading dimension of the local
+* array. LLD_A >= MAX(1,LOCr(M_A)).
+*
+* Let K be the number of rows or columns of a distributed matrix,
+* and assume that its process grid has dimension p x q.
+* LOCr( K ) denotes the number of elements of K that a process
+* would receive if K were distributed over the p processes of its
+* process column.
+* Similarly, LOCc( K ) denotes the number of elements of K that a
+* process would receive if K were distributed over the q processes of
+* its process row.
+* The values of LOCr() and LOCc() may be determined via a call to the
+* ScaLAPACK tool function, NUMROC:
+* LOCr( M ) = NUMROC( M, MB_A, MYROW, RSRC_A, NPROW ),
+* LOCc( N ) = NUMROC( N, NB_A, MYCOL, CSRC_A, NPCOL ).
+* An upper bound for these quantities may be computed by:
+* LOCr( M ) <= ceil( ceil(M/MB_A)/NPROW )*MB_A
+* LOCc( N ) <= ceil( ceil(N/NB_A)/NPCOL )*NB_A
+*
+* Arguments
+* =========
+*
+* JOB (global input) CHARACTER*1
+* Specifies whether condition numbers are required for the
+* cluster of eigenvalues (S) or the invariant subspace (SEP):
+* = 'N': none;
+* = 'E': for eigenvalues only (S);
+* = 'V': for invariant subspace only (SEP);
+* = 'B': for both eigenvalues and invariant subspace (S and
+* SEP).
+*
+* COMPQ (global input) CHARACTER*1
+* = 'V': update the matrix Q of Schur vectors;
+* = 'N': do not update Q.
+*
+* SELECT (global input) LOGICAL array, dimension (N)
+* SELECT specifies the eigenvalues in the selected cluster. To
+* select a real eigenvalue w(j), SELECT(j) must be set to
+* .TRUE.. To select a complex conjugate pair of eigenvalues
+* w(j) and w(j+1), corresponding to a 2-by-2 diagonal block,
+* either SELECT(j) or SELECT(j+1) or both must be set to
+* .TRUE.; a complex conjugate pair of eigenvalues must be
+* either both included in the cluster or both excluded.
+*
+* PARA (global input) INTEGER*6
+* Block parameters (some should be replaced by calls to
+* PILAENV and others by meaningful default values):
+* PARA(1) = maximum number of concurrent computational windows
+* allowed in the algorithm;
+* 0 < PARA(1) <= min(NPROW,NPCOL) must hold;
+* PARA(2) = number of eigenvalues in each window;
+* 0 < PARA(2) < PARA(3) must hold;
+* PARA(3) = window size; PARA(2) < PARA(3) < DESCT(MB_)
+* must hold;
+* PARA(4) = minimal percentage of flops required for
+* performing matrix-matrix multiplications instead
+* of pipelined orthogonal transformations;
+* 0 <= PARA(4) <= 100 must hold;
+* PARA(5) = width of block column slabs for row-wise
+* application of pipelined orthogonal
+* transformations in their factorized form;
+* 0 < PARA(5) <= DESCT(MB_) must hold.
+* PARA(6) = the maximum number of eigenvalues moved together
+* over a process border; in practice, this will be
+* approximately half of the cross border window size
+* 0 < PARA(6) <= PARA(2) must hold;
+*
+* N (global input) INTEGER
+* The order of the globally distributed matrix T. N >= 0.
+*
+* T (local input/output) DOUBLE PRECISION array,
+* dimension (LLD_T,LOCc(N)).
+* On entry, the local pieces of the global distributed
+* upper quasi-triangular matrix T, in Schur form. On exit, T is
+* overwritten by the local pieces of the reordered matrix T,
+* again in Schur form, with the selected eigenvalues in the
+* globally leading diagonal blocks.
+*
+* IT (global input) INTEGER
+* JT (global input) INTEGER
+* The row and column index in the global array T indicating the
+* first column of sub( T ). IT = JT = 1 must hold.
+*
+* DESCT (global and local input) INTEGER array of dimension DLEN_.
+* The array descriptor for the global distributed matrix T.
+*
+* Q (local input/output) DOUBLE PRECISION array,
+* dimension (LLD_Q,LOCc(N)).
+* On entry, if COMPQ = 'V', the local pieces of the global
+* distributed matrix Q of Schur vectors.
+* On exit, if COMPQ = 'V', Q has been postmultiplied by the
+* global 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.
+*
+* IQ (global input) INTEGER
+* JQ (global input) INTEGER
+* The column index in the global array Q indicating the
+* first column of sub( Q ). IQ = JQ = 1 must hold.
+*
+* DESCQ (global and local input) INTEGER array of dimension DLEN_.
+* The array descriptor for the global distributed matrix Q.
+*
+* WR (global output) DOUBLE PRECISION array, dimension (N)
+* WI (global output) DOUBLE PRECISION array, dimension (N)
+* The real and imaginary parts, respectively, of the reordered
+* eigenvalues of T. The eigenvalues are in principle 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 also that if a complex eigenvalue is sufficiently
+* ill-conditioned, then its value may differ significantly
+* from its value before reordering.
+*
+* M (global output) INTEGER
+* The dimension of the specified invariant subspace.
+* 0 <= M <= N.
+*
+* S (global output) DOUBLE PRECISION
+* If JOB = 'E' or 'B', S is a lower bound on the reciprocal
+* condition number for the selected cluster of eigenvalues.
+* S cannot underestimate the true reciprocal condition number
+* by more than a factor of sqrt(N). If M = 0 or N, S = 1.
+* If JOB = 'N' or 'V', S is not referenced.
+*
+* SEP (global output) DOUBLE PRECISION
+* If JOB = 'V' or 'B', SEP is the estimated reciprocal
+* condition number of the specified invariant subspace. If
+* M = 0 or N, SEP = norm(T).
+* If JOB = 'N' or 'E', SEP is not referenced.
+*
+* WORK (local workspace/output) DOUBLE PRECISION array,
+* dimension (LWORK)
+* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*
+* LWORK (local input) 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 PXERBLA.
+*
+* IWORK (local workspace/output) INTEGER array, dimension (LIWORK)
+*
+* LIWORK (local input) INTEGER
+* The dimension of the array IWORK.
+*
+* 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 PXERBLA.
+*
+* INFO (global output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value.
+* If the i-th argument is an array and the j-entry had
+* an illegal value, then INFO = -(i*1000+j), if the i-th
+* argument is a scalar and had an illegal value, then INFO = -i.
+* > 0: here we have several possibilites
+* *) 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.
+* On exit, INFO = {the index of T where the swap failed}.
+* *) A 2-by-2 block to be reordered split into two 1-by-1
+* blocks and the second block failed to swap with an
+* adjacent block.
+* On exit, INFO = {the index of T where the swap failed}.
+* *) If INFO = N+1, there is no valid BLACS context (see the
+* BLACS documentation for details).
+* *) If INFO = N+2, the routines used in the calculation of
+* the condition numbers raised a positive warning flag
+* (see the documentation for PGESYCTD and PSYCTCON of the
+* SCASY library).
+* *) If INFO = N+3, PGESYCTD raised an input error flag;
+* please report this bug to the authors (see below).
+* If INFO = N+4, PSYCTCON raised an input error flag;
+* please report this bug to the authors (see below).
+* In a future release this subroutine may distinguish between
+* the case 1 and 2 above.
+*
+* Method
+* ======
+*
+* This routine performs parallel eigenvalue reordering in real Schur
+* form by parallelizing the approach proposed in [3]. The condition
+* number estimation part is performed by using techniques and code
+* from SCASY, see http://www.cs.umu.se/research/parallel/scasy.
+*
+* Additional requirements
+* =======================
+*
+* The following alignment requirements must hold:
+* (a) DESCT( MB_ ) = DESCT( NB_ ) = DESCQ( MB_ ) = DESCQ( NB_ )
+* (b) DESCT( RSRC_ ) = DESCQ( RSRC_ )
+* (c) DESCT( CSRC_ ) = DESCQ( CSRC_ )
+*
+* All matrices must be blocked by a block factor larger than or
+* equal to two (3). This to simplify reordering across processor
+* borders in the presence of 2-by-2 blocks.
+*
+* Limitations
+* ===========
+*
+* This algorithm cannot work on submatrices of T and Q, i.e.,
+* IT = JT = IQ = JQ = 1 must hold. This is however no limitation
+* since PDLAHQR does not compute Schur forms of submatrices anyway.
+*
+* References
+* ==========
+*
+* [1] Z. Bai and J. W. Demmel; On swapping diagonal blocks in real
+* Schur form, Linear Algebra Appl., 186:73--95, 1993. Also as
+* LAPACK Working Note 54.
+*
+* [2] Z. Bai, J. W. Demmel, and A. McKenney; On computing condition
+* numbers for the nonsymmetric eigenvalue problem, ACM Trans.
+* Math. Software, 19(2):202--223, 1993. Also as LAPACK Working
+* Note 13.
+*
+* [3] D. Kressner; Block algorithms for reordering standard and
+* generalized Schur forms, ACM TOMS, 32(4):521-532, 2006.
+* Also LAPACK Working Note 171.
+*
+* [4] R. Granat, B. Kagstrom, and D. Kressner; Parallel eigenvalue
+* reordering in real Schur form, Concurrency and Computations:
+* Practice and Experience, 21(9):1225-1250, 2009. Also as
+* LAPACK Working Note 192.
+*
+* Parallel execution recommendations
+* ==================================
+*
+* Use a square grid, if possible, for maximum performance. The block
+* parameters in PARA should be kept well below the data distribution
+* block size. In particular, see [3,4] for recommended settings for
+* these parameters.
+*
+* In general, the parallel algorithm strives to perform as much work
+* as possible without crossing the block borders on the main block
+* diagonal.
+*
+* Contributors
+* ============
+*
+* Implemented by Robert Granat, Dept. of Computing Science and HPC2N,
+* Umea University, Sweden, March 2007,
+* in collaboration with Bo Kagstrom and Daniel Kressner.
+* Modified by Meiyue Shao, October 2011.
+*
+* Revisions
+* =========
+*
+* Please send bug-reports to granat at cs.umu.se
+*
+* Keywords
+* ========
+*
+* Real Schur form, eigenvalue reordering, Sylvester matrix equation
+*
+* =====================================================================
+* ..
+* .. Parameters ..
+ CHARACTER TOP
+ INTEGER BLOCK_CYCLIC_2D, CSRC_, CTXT_, DLEN_, DTYPE_,
+ $ LLD_, MB_, M_, NB_, N_, RSRC_
+ DOUBLE PRECISION ZERO, ONE
+ PARAMETER ( TOP = '1-Tree',
+ $ BLOCK_CYCLIC_2D = 1, DLEN_ = 9, DTYPE_ = 1,
+ $ CTXT_ = 2, M_ = 3, N_ = 4, MB_ = 5, NB_ = 6,
+ $ RSRC_ = 7, CSRC_ = 8, LLD_ = 9,
+ $ ZERO = 0.0D+0, ONE = 1.0D+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL LQUERY, WANTBH, WANTQ, WANTS, WANTSP
+ INTEGER ICOFFT12, ICTXT, IDUM1, IDUM2, IERR, ILOC1,
+ $ IPW1, ITER, ITT, JLOC1, JTT, K, LIWMIN, LLDT,
+ $ LLDQ, LWMIN, MMAX, MMIN, MYROW, MYCOL, N1, N2,
+ $ NB, NOEXSY, NPCOL, NPROCS, NPROW, SPACE,
+ $ T12ROWS, T12COLS, TCOLS, TCSRC, TROWS, TRSRC,
+ $ WRK1, IWRK1, WRK2, IWRK2, WRK3, IWRK3
+ DOUBLE PRECISION DPDUM1, ELEM, EST, SCALE, RNORM
+* .. Local Arrays ..
+ INTEGER DESCT12( DLEN_ ), MBNB2( 2 )
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ INTEGER NUMROC
+ DOUBLE PRECISION PDLANGE
+ EXTERNAL LSAME, NUMROC, PDLANGE
+* ..
+* .. External Subroutines ..
+ EXTERNAL BLACS_GRIDINFO, CHK1MAT, DESCINIT,
+ $ IGAMX2D, INFOG2L, PDLACPY, PDTRORD, PXERBLA,
+ $ PCHK1MAT, PCHK2MAT
+* $ , PGESYCTD, PSYCTCON
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, MIN, SQRT
+* ..
+* .. Executable Statements ..
+*
+* Get grid parameters
+*
+ ICTXT = DESCT( CTXT_ )
+ CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL )
+ NPROCS = NPROW*NPCOL
+*
+* Test if grid is O.K., i.e., the context is valid
+*
+ INFO = 0
+ IF( NPROW.EQ.-1 ) THEN
+ INFO = N+1
+ END IF
+*
+* Check if workspace
+*
+ LQUERY = LWORK.EQ.-1 .OR. LIWORK.EQ.-1
+*
+* Test dimensions for local sanity
+*
+ IF( INFO.EQ.0 ) THEN
+ CALL CHK1MAT( N, 5, N, 5, IT, JT, DESCT, 9, INFO )
+ END IF
+ IF( INFO.EQ.0 ) THEN
+ CALL CHK1MAT( N, 5, N, 5, IQ, JQ, DESCQ, 13, INFO )
+ END IF
+*
+* Check the blocking sizes for alignment requirements
+*
+ IF( INFO.EQ.0 ) THEN
+ IF( DESCT( MB_ ).NE.DESCT( NB_ ) ) INFO = -(1000*9 + MB_)
+ END IF
+ IF( INFO.EQ.0 ) THEN
+ IF( DESCQ( MB_ ).NE.DESCQ( NB_ ) ) INFO = -(1000*13 + MB_)
+ END IF
+ IF( INFO.EQ.0 ) THEN
+ IF( DESCT( MB_ ).NE.DESCQ( MB_ ) ) INFO = -(1000*9 + MB_)
+ END IF
+*
+* Check the blocking sizes for minimum sizes
+*
+ IF( INFO.EQ.0 ) THEN
+ IF( N.NE.DESCT( MB_ ) .AND. DESCT( MB_ ).LT.3 )
+ $ INFO = -(1000*9 + MB_)
+ IF( N.NE.DESCQ( MB_ ) .AND. DESCQ( MB_ ).LT.3 )
+ $ INFO = -(1000*13 + MB_)
+ END IF
+*
+* Check parameters in PARA
+*
+ NB = DESCT( MB_ )
+ IF( INFO.EQ.0 ) THEN
+ IF( PARA(1).LT.1 .OR. PARA(1).GT.MIN(NPROW,NPCOL) )
+ $ INFO = -(1000 * 4 + 1)
+ IF( PARA(2).LT.1 .OR. PARA(2).GE.PARA(3) )
+ $ INFO = -(1000 * 4 + 2)
+ IF( PARA(3).LT.1 .OR. PARA(3).GT.NB )
+ $ INFO = -(1000 * 4 + 3)
+ IF( PARA(4).LT.0 .OR. PARA(4).GT.100 )
+ $ INFO = -(1000 * 4 + 4)
+ IF( PARA(5).LT.1 .OR. PARA(5).GT.NB )
+ $ INFO = -(1000 * 4 + 5)
+ IF( PARA(6).LT.1 .OR. PARA(6).GT.PARA(2) )
+ $ INFO = -(1000 * 4 + 6)
+ END IF
+*
+* Check requirements on IT, JT, IQ and JQ
+*
+ IF( INFO.EQ.0 ) THEN
+ IF( IT.NE.1 ) INFO = -7
+ IF( JT.NE.IT ) INFO = -8
+ IF( IQ.NE.1 ) INFO = -11
+ IF( JQ.NE.IQ ) INFO = -12
+ END IF
+*
+* Test input parameters for global sanity
+*
+ IF( INFO.EQ.0 ) THEN
+ CALL PCHK1MAT( N, 5, N, 5, IT, JT, DESCT, 9, 0, IDUM1,
+ $ IDUM2, INFO )
+ END IF
+ IF( INFO.EQ.0 ) THEN
+ CALL PCHK1MAT( N, 5, N, 5, IQ, JQ, DESCQ, 13, 0, IDUM1,
+ $ IDUM2, INFO )
+ END IF
+ IF( INFO.EQ.0 ) THEN
+ CALL PCHK2MAT( N, 5, N, 5, IT, JT, DESCT, 9, N, 5, N, 5,
+ $ IQ, JQ, DESCQ, 13, 0, IDUM1, IDUM2, INFO )
+ END IF
+*
+* Decode and test the input parameters
+*
+ IF( INFO.EQ.0 .OR. LQUERY ) THEN
+ WANTBH = LSAME( JOB, 'B' )
+ WANTS = LSAME( JOB, 'E' ) .OR. WANTBH
+ WANTSP = LSAME( JOB, 'V' ) .OR. WANTBH
+ WANTQ = LSAME( COMPQ, 'V' )
+*
+ IF( .NOT.LSAME( JOB, 'N' ) .AND. .NOT.WANTS .AND. .NOT.WANTSP )
+ $ THEN
+ INFO = -1
+ ELSEIF( .NOT.LSAME( COMPQ, 'N' ) .AND. .NOT.WANTQ ) THEN
+ INFO = -2
+ ELSEIF( N.LT.0 ) THEN
+ INFO = -4
+ ELSE
+*
+* Extract local leading dimension
+*
+ LLDT = DESCT( LLD_ )
+ LLDQ = DESCQ( LLD_ )
+*
+* Check the SELECT vector for consistency and set M to the
+* dimension of the specified invariant subspace.
+*
+ M = 0
+ DO 10 K = 1, N
+*
+* IWORK(1:N) is an integer copy of SELECT.
+*
+ IF( SELECT(K) ) THEN
+ IWORK(K) = 1
+ ELSE
+ IWORK(K) = 0
+ END IF
+ IF( K.LT.N ) THEN
+ CALL INFOG2L( K+1, K, DESCT, NPROW, NPCOL,
+ $ MYROW, MYCOL, ITT, JTT, TRSRC, TCSRC )
+ IF( MYROW.EQ.TRSRC .AND. MYCOL.EQ.TCSRC ) THEN
+ ELEM = T( (JTT-1)*LLDT + ITT )
+ IF( ELEM.NE.ZERO ) THEN
+ IF( SELECT(K) .AND. .NOT.SELECT(K+1) ) THEN
+* INFO = -3
+ IWORK(K+1) = 1
+ ELSEIF( .NOT.SELECT(K) .AND. SELECT(K+1) ) THEN
+* INFO = -3
+ IWORK(K) = 1
+ END IF
+ END IF
+ END IF
+ END IF
+ IF( SELECT(K) ) M = M + 1
+ 10 CONTINUE
+ MMAX = M
+ MMIN = M
+ IF( NPROCS.GT.1 )
+ $ CALL IGAMX2D( ICTXT, 'All', TOP, 1, 1, MMAX, 1, -1,
+ $ -1, -1, -1, -1 )
+ IF( NPROCS.GT.1 )
+ $ CALL IGAMN2D( ICTXT, 'All', TOP, 1, 1, MMIN, 1, -1,
+ $ -1, -1, -1, -1 )
+ IF( MMAX.GT.MMIN ) THEN
+ M = MMAX
+ IF( NPROCS.GT.1 )
+ $ CALL IGAMX2D( ICTXT, 'All', TOP, N, 1, IWORK, N,
+ $ -1, -1, -1, -1, -1 )
+ END IF
+*
+* Set parameters for deep pipelining in parallel
+* Sylvester solver.
+*
+ MBNB2( 1 ) = MIN( MAX( PARA( 3 ), PARA( 2 )*2 ), NB )
+ MBNB2( 2 ) = MBNB2( 1 )
+*
+* Compute needed workspace
+*
+ N1 = M
+ N2 = N - M
+ IF( WANTS ) THEN
+c CALL PGESYCTD( 'Solve', 'Schur', 'Schur', 'Notranspose',
+c $ 'Notranspose', -1, 'Demand', N1, N2, T, 1, 1, DESCT,
+c $ T, N1+1, N1+1, DESCT, T, 1, N1+1, DESCT, MBNB2,
+c $ WORK, -1, IWORK(N+1), -1, NOEXSY, SCALE, IERR )
+ WRK1 = INT(WORK(1))
+ IWRK1 = IWORK(N+1)
+ WRK1 = 0
+ IWRK1 = 0
+ ELSE
+ WRK1 = 0
+ IWRK1 = 0
+ END IF
+*
+ IF( WANTSP ) THEN
+c CALL PSYCTCON( 'Notranspose', 'Notranspose', -1,
+c $ 'Demand', N1, N2, T, 1, 1, DESCT, T, N1+1, N1+1,
+c $ DESCT, MBNB2, WORK, -1, IWORK(N+1), -1, EST, ITER,
+c $ IERR )
+ WRK2 = INT(WORK(1))
+ IWRK2 = IWORK(N+1)
+ WRK2 = 0
+ IWRK2 = 0
+ ELSE
+ WRK2 = 0
+ IWRK2 = 0
+ END IF
+*
+ TROWS = NUMROC( N, NB, MYROW, DESCT(RSRC_), NPROW )
+ TCOLS = NUMROC( N, NB, MYCOL, DESCT(CSRC_), NPCOL )
+ WRK3 = N + 7*NB**2 + 2*TROWS*PARA( 3 ) + TCOLS*PARA( 3 ) +
+ $ MAX( TROWS*PARA( 3 ), TCOLS*PARA( 3 ) )
+ IWRK3 = 5*PARA( 1 ) + PARA(2)*PARA(3) -
+ $ PARA(2) * (PARA(2) + 1 ) / 2
+*
+ IF( WANTSP ) THEN
+ LWMIN = MAX( 1, MAX( WRK2, WRK3) )
+ LIWMIN = MAX( 1, MAX( IWRK2, IWRK3 ) )+N
+ ELSE IF( LSAME( JOB, 'N' ) ) THEN
+ LWMIN = MAX( 1, WRK3 )
+ LIWMIN = IWRK3+N
+ ELSE IF( LSAME( JOB, 'E' ) ) THEN
+ LWMIN = MAX( 1, MAX( WRK1, WRK3) )
+ LIWMIN = MAX( 1, MAX( IWRK1, IWRK3 ) )+N
+ END IF
+*
+ IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN
+ INFO = -20
+ ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN
+ INFO = -22
+ END IF
+ END IF
+ END IF
+*
+* Global maximum on info
+*
+ IF( NPROCS.GT.1 )
+ $ CALL IGAMX2D( ICTXT, 'All', TOP, 1, 1, INFO, 1, -1, -1, -1,
+ $ -1, -1 )
+*
+* Return if some argument is incorrect
+*
+ IF( INFO.NE.0 .AND. .NOT.LQUERY ) THEN
+ M = 0
+ S = ONE
+ SEP = ZERO
+ CALL PXERBLA( ICTXT, 'PDTRSEN', -INFO )
+ RETURN
+ ELSEIF( LQUERY ) THEN
+ WORK( 1 ) = DBLE(LWMIN)
+ IWORK( 1 ) = LIWMIN
+ RETURN
+ END IF
+*
+* Quick return if possible.
+*
+ IF( M.EQ.N .OR. M.EQ.0 ) THEN
+ IF( WANTS )
+ $ S = ONE
+ IF( WANTSP )
+ $ SEP = PDLANGE( '1', N, N, T, IT, JT, DESCT, WORK )
+ GO TO 50
+ END IF
+*
+* Reorder the eigenvalues.
+*
+ CALL PDTRORD( COMPQ, IWORK, PARA, N, T, IT, JT,
+ $ DESCT, Q, IQ, JQ, DESCQ, WR, WI, M, WORK, LWORK,
+ $ IWORK(N+1), LIWORK-N, INFO )
+*
+ IF( WANTS ) THEN
+*
+* Solve Sylvester equation T11*R - R*T2 = scale*T12 for R in
+* parallel.
+*
+* Copy T12 to workspace.
+*
+ CALL INFOG2L( 1, N1+1, DESCT, NPROW, NPCOL, MYROW,
+ $ MYCOL, ILOC1, JLOC1, TRSRC, TCSRC )
+ ICOFFT12 = MOD( N1, NB )
+ T12ROWS = NUMROC( N1, NB, MYROW, TRSRC, NPROW )
+ T12COLS = NUMROC( N2+ICOFFT12, NB, MYCOL, TCSRC, NPCOL )
+ CALL DESCINIT( DESCT12, N1, N2+ICOFFT12, NB, NB, TRSRC,
+ $ TCSRC, ICTXT, MAX(1,T12ROWS), IERR )
+ CALL PDLACPY( 'All', N1, N2, T, 1, N1+1, DESCT, WORK,
+ $ 1, 1+ICOFFT12, DESCT12 )
+*
+* Solve the equation to get the solution in workspace.
+*
+ SPACE = DESCT12( LLD_ ) * T12COLS
+ IPW1 = 1 + SPACE
+c CALL PGESYCTD( 'Solve', 'Schur', 'Schur', 'Notranspose',
+c $ 'Notranspose', -1, 'Demand', N1, N2, T, 1, 1, DESCT, T,
+c $ N1+1, N1+1, DESCT, WORK, 1, 1+ICOFFT12, DESCT12, MBNB2,
+c $ WORK(IPW1), LWORK-SPACE+1, IWORK(N+1), LIWORK-N, NOEXSY,
+c $ SCALE, IERR )
+ IF( IERR.LT.0 ) THEN
+ INFO = N+3
+ ELSE
+ INFO = N+2
+ END IF
+*
+* Estimate the reciprocal of the condition number of the cluster
+* of eigenvalues.
+*
+ RNORM = PDLANGE( 'Frobenius', N1, N2, WORK, 1, 1+ICOFFT12,
+ $ DESCT12, DPDUM1 )
+ 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,T21) in parallel.
+*
+c CALL PSYCTCON( 'Notranspose', 'Notranspose', -1, 'Demand', N1,
+c $ N2, T, 1, 1, DESCT, T, N1+1, N1+1, DESCT, MBNB2, WORK,
+c $ LWORK, IWORK(N+1), LIWORK-N, EST, ITER, IERR )
+ EST = EST * SQRT(DBLE(N1*N2))
+ SEP = ONE / EST
+ IF( IERR.LT.0 ) THEN
+ INFO = N+4
+ ELSE
+ INFO = N+2
+ END IF
+ END IF
+*
+* Return to calling program.
+*
+ 50 CONTINUE
+*
+ RETURN
+*
+* End of PDTRSEN
+*
+ END
+*
diff --git a/SRC/pilaenvx.f b/SRC/pilaenvx.f
new file mode 100644
index 0000000..68a42e5
--- /dev/null
+++ b/SRC/pilaenvx.f
@@ -0,0 +1,649 @@
+ INTEGER FUNCTION PILAENVX( ICTXT, ISPEC, NAME, OPTS, N1, N2, N3,
+ $ N4 )
+*
+* Contribution from the Department of Computing Science and HPC2N,
+* Umea University, Sweden
+*
+* -- ScaLAPACK auxiliary routine (version 2.0.1) --
+* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
+* Univ. of Colorado Denver and University of California, Berkeley.
+* January, 2012
+*
+ IMPLICIT NONE
+*
+* .. Scalar Arguments ..
+ CHARACTER*( * ) NAME, OPTS
+ INTEGER ICTXT, ISPEC, N1, N2, N3, N4
+* ..
+*
+* Purpose
+* =======
+*
+* PILAENVX is called from the ScaLAPACK routines to choose problem-
+* dependent parameters for the local environment. See ISPEC for a
+* description of the parameters.
+*
+* This version provides a set of parameters which should give good,
+* but not optimal, performance on many of the currently available
+* computers. Users are encouraged to modify this subroutine to set
+* the tuning parameters for their particular machine using the option
+* and problem size information in the arguments.
+*
+* This routine will not function correctly if it is converted to all
+* lower case. Converting it to all upper case is allowed.
+*
+* Arguments
+* =========
+*
+* ICTXT (local input) INTEGER
+* On entry, ICTXT specifies the BLACS context handle, indica-
+* ting the global context of the operation. The context itself
+* is global, but the value of ICTXT is local.
+*
+* ISPEC (global input) INTEGER
+* Specifies the parameter to be returned as the value of
+* PILAENVX.
+* = 1: the optimal blocksize; if this value is 1, an unblocked
+* algorithm will give the best performance (unlikely).
+* = 2: the minimum block size for which the block routine
+* should be used; if the usable block size is less than
+* this value, an unblocked routine should be used.
+* = 3: the crossover point (in a block routine, for N less
+* than this value, an unblocked routine should be used)
+* = 4: the number of shifts, used in the nonsymmetric
+* eigenvalue routines (DEPRECATED)
+* = 5: the minimum column dimension for blocking to be used;
+* rectangular blocks must have dimension at least k by m,
+* where k is given by PILAENVX(2,...) and m by PILAENVX(5,...)
+* = 6: the crossover point for the SVD (when reducing an m by n
+* matrix to bidiagonal form, if max(m,n)/min(m,n) exceeds
+* this value, a QR factorization is used first to reduce
+* the matrix to a triangular form.)
+* = 7: the number of processors
+* = 8: the crossover point for the multishift QR method
+* for nonsymmetric eigenvalue problems (DEPRECATED)
+* = 9: maximum size of the subproblems at the bottom of the
+* computation tree in the divide-and-conquer algorithm
+* (used by xGELSD and xGESDD)
+* =10: ieee NaN arithmetic can be trusted not to trap
+* =11: infinity arithmetic can be trusted not to trap
+* 12 <= ISPEC <= 16:
+* PxHSEQR or one of its subroutines,
+* see PIPARMQ for detailed explanation
+* 17 <= ISPEC <= 22:
+* Parameters for PBxTRORD/PxHSEQR (not all), as follows:
+* =17: maximum number of concurrent computational windows;
+* =18: number of eigenvalues/bulges in each window;
+* =19: computational window size;
+* =20: minimal percentage of flops required for
+* performing matrix-matrix multiplications instead
+* of pipelined orthogonal transformations;
+* =21: width of block column slabs for row-wise
+* application of pipelined orthogonal
+* transformations in their factorized form;
+* =22: the maximum number of eigenvalues moved together
+* over a process border;
+* =23: the number of processors involved in AED;
+* =99: Maximum iteration chunksize in OpenMP parallelization
+*
+* NAME (global input) CHARACTER*(*)
+* The name of the calling subroutine, in either upper case or
+* lower case.
+*
+* OPTS (global input) CHARACTER*(*)
+* The character options to the subroutine NAME, concatenated
+* into a single character string. For example, UPLO = 'U',
+* TRANS = 'T', and DIAG = 'N' for a triangular routine would
+* be specified as OPTS = 'UTN'.
+*
+* N1 (global input) INTEGER
+* N2 (global input) INTEGER
+* N3 (global input) INTEGER
+* N4 (global input) INTEGER
+* Problem dimensions for the subroutine NAME; these may not all
+* be required.
+*
+* (PILAENVX) (global output) INTEGER
+* >= 0: the value of the parameter specified by ISPEC
+* < 0: if PILAENVX = -k, the k-th argument had an illegal value.
+*
+* Further Details
+* ===============
+*
+* The following conventions have been used when calling ILAENV from the
+* LAPACK routines:
+* 1) OPTS is a concatenation of all of the character options to
+* subroutine NAME, in the same order that they appear in the
+* argument list for NAME, even if they are not used in determining
+* the value of the parameter specified by ISPEC.
+* 2) The problem dimensions N1, N2, N3, N4 are specified in the order
+* that they appear in the argument list for NAME. N1 is used
+* first, N2 second, and so on, and unused problem dimensions are
+* passed a value of -1.
+* 3) The parameter value returned by ILAENV is checked for validity in
+* the calling subroutine. For example, ILAENV is used to retrieve
+* the optimal blocksize for STRTRI as follows:
+*
+* NB = ILAENV( 1, 'STRTRI', UPLO // DIAG, N, -1, -1, -1 )
+* IF( NB.LE.1 ) NB = MAX( 1, N )
+*
+* The same conventions will hold for this ScaLAPACK-style variant.
+*
+* =====================================================================
+*
+* .. Local Scalars ..
+ INTEGER I, IC, IZ, NB, NBMIN, NX, NPROW, NPCOL, MYROW,
+ $ MYCOL
+ LOGICAL CNAME, SNAME
+ CHARACTER C1*1, C2*2, C4*2, C3*3, SUBNAM*6
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC CHAR, ICHAR, INT, MIN, REAL
+* ..
+* .. External Functions ..
+ INTEGER IEEECK, PIPARMQ, ICEIL
+ EXTERNAL IEEECK, PIPARMQ, ICEIL
+* ..
+* .. Executable Statements ..
+*
+ IF( ISPEC.GT.23 ) GO TO 990
+ GO TO ( 10, 10, 10, 80, 90, 100, 110, 120,
+ $ 130, 140, 150, 160, 160, 160, 160, 160,
+ $ 170, 180, 190, 200, 210, 220, 230, 160)ISPEC
+*
+* Invalid value for ISPEC
+*
+ PILAENVX = -1
+ RETURN
+*
+ 10 CONTINUE
+*
+* Convert NAME to upper case if the first character is lower case.
+*
+ PILAENVX = 1
+ SUBNAM = NAME
+ IC = ICHAR( SUBNAM( 1: 1 ) )
+ IZ = ICHAR( 'Z' )
+ IF( IZ.EQ.90 .OR. IZ.EQ.122 ) THEN
+*
+* ASCII character set
+*
+ IF( IC.GE.97 .AND. IC.LE.122 ) THEN
+ SUBNAM( 1: 1 ) = CHAR( IC-32 )
+ DO 20 I = 2, 6
+ IC = ICHAR( SUBNAM( I: I ) )
+ IF( IC.GE.97 .AND. IC.LE.122 )
+ $ SUBNAM( I: I ) = CHAR( IC-32 )
+ 20 CONTINUE
+ END IF
+*
+ ELSE IF( IZ.EQ.233 .OR. IZ.EQ.169 ) THEN
+*
+* EBCDIC character set
+*
+ IF( ( IC.GE.129 .AND. IC.LE.137 ) .OR.
+ $ ( IC.GE.145 .AND. IC.LE.153 ) .OR.
+ $ ( IC.GE.162 .AND. IC.LE.169 ) ) THEN
+ SUBNAM( 1: 1 ) = CHAR( IC+64 )
+ DO 30 I = 2, 6
+ IC = ICHAR( SUBNAM( I: I ) )
+ IF( ( IC.GE.129 .AND. IC.LE.137 ) .OR.
+ $ ( IC.GE.145 .AND. IC.LE.153 ) .OR.
+ $ ( IC.GE.162 .AND. IC.LE.169 ) )SUBNAM( I:
+ $ I ) = CHAR( IC+64 )
+ 30 CONTINUE
+ END IF
+*
+ ELSE IF( IZ.EQ.218 .OR. IZ.EQ.250 ) THEN
+*
+* Prime machines: ASCII+128
+*
+ IF( IC.GE.225 .AND. IC.LE.250 ) THEN
+ SUBNAM( 1: 1 ) = CHAR( IC-32 )
+ DO 40 I = 2, 6
+ IC = ICHAR( SUBNAM( I: I ) )
+ IF( IC.GE.225 .AND. IC.LE.250 )
+ $ SUBNAM( I: I ) = CHAR( IC-32 )
+ 40 CONTINUE
+ END IF
+ END IF
+*
+ C1 = SUBNAM( 1: 1 )
+ SNAME = C1.EQ.'S' .OR. C1.EQ.'D'
+ CNAME = C1.EQ.'C' .OR. C1.EQ.'Z'
+ IF( .NOT.( CNAME .OR. SNAME ) )
+ $ RETURN
+ C2 = SUBNAM( 2: 3 )
+ C3 = SUBNAM( 4: 6 )
+ C4 = C3( 2: 3 )
+*
+ GO TO ( 50, 60, 70 )ISPEC
+*
+ 50 CONTINUE
+*
+* ISPEC = 1: block size
+*
+* In these examples, separate code is provided for setting NB for
+* real and complex. We assume that NB will take the same value in
+* single or double precision.
+*
+ NB = 1
+*
+ IF( C2.EQ.'GE' ) THEN
+ IF( C3.EQ.'TRF' ) THEN
+ IF( SNAME ) THEN
+ NB = 64
+ ELSE
+ NB = 64
+ END IF
+ ELSE IF( C3.EQ.'QRF' .OR. C3.EQ.'RQF' .OR. C3.EQ.'LQF' .OR.
+ $ C3.EQ.'QLF' ) THEN
+ IF( SNAME ) THEN
+ NB = 32
+ ELSE
+ NB = 32
+ END IF
+ ELSE IF( C3.EQ.'HRD' ) THEN
+ IF( SNAME ) THEN
+ NB = 32
+ ELSE
+ NB = 32
+ END IF
+ ELSE IF( C3.EQ.'BRD' ) THEN
+ IF( SNAME ) THEN
+ NB = 32
+ ELSE
+ NB = 32
+ END IF
+ ELSE IF( C3.EQ.'TRI' ) THEN
+ IF( SNAME ) THEN
+ NB = 64
+ ELSE
+ NB = 64
+ END IF
+ END IF
+ ELSE IF( C2.EQ.'PO' ) THEN
+ IF( C3.EQ.'TRF' ) THEN
+ IF( SNAME ) THEN
+ NB = 64
+ ELSE
+ NB = 64
+ END IF
+ END IF
+ ELSE IF( C2.EQ.'SY' ) THEN
+ IF( C3.EQ.'TRF' ) THEN
+ IF( SNAME ) THEN
+ NB = 64
+ ELSE
+ NB = 64
+ END IF
+ ELSE IF( SNAME .AND. C3.EQ.'TRD' ) THEN
+ NB = 32
+ ELSE IF( SNAME .AND. C3.EQ.'GST' ) THEN
+ NB = 64
+ END IF
+ ELSE IF( CNAME .AND. C2.EQ.'HE' ) THEN
+ IF( C3.EQ.'TRF' ) THEN
+ NB = 64
+ ELSE IF( C3.EQ.'TRD' ) THEN
+ NB = 32
+ ELSE IF( C3.EQ.'GST' ) THEN
+ NB = 64
+ END IF
+ ELSE IF( SNAME .AND. C2.EQ.'OR' ) THEN
+ IF( C3( 1: 1 ).EQ.'G' ) THEN
+ IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ.
+ $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' )
+ $ THEN
+ NB = 32
+ END IF
+ ELSE IF( C3( 1: 1 ).EQ.'M' ) THEN
+ IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ.
+ $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' )
+ $ THEN
+ NB = 32
+ END IF
+ END IF
+ ELSE IF( CNAME .AND. C2.EQ.'UN' ) THEN
+ IF( C3( 1: 1 ).EQ.'G' ) THEN
+ IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ.
+ $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' )
+ $ THEN
+ NB = 32
+ END IF
+ ELSE IF( C3( 1: 1 ).EQ.'M' ) THEN
+ IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ.
+ $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' )
+ $ THEN
+ NB = 32
+ END IF
+ END IF
+ ELSE IF( C2.EQ.'GB' ) THEN
+ IF( C3.EQ.'TRF' ) THEN
+ IF( SNAME ) THEN
+ IF( N4.LE.64 ) THEN
+ NB = 1
+ ELSE
+ NB = 32
+ END IF
+ ELSE
+ IF( N4.LE.64 ) THEN
+ NB = 1
+ ELSE
+ NB = 32
+ END IF
+ END IF
+ END IF
+ ELSE IF( C2.EQ.'PB' ) THEN
+ IF( C3.EQ.'TRF' ) THEN
+ IF( SNAME ) THEN
+ IF( N2.LE.64 ) THEN
+ NB = 1
+ ELSE
+ NB = 32
+ END IF
+ ELSE
+ IF( N2.LE.64 ) THEN
+ NB = 1
+ ELSE
+ NB = 32
+ END IF
+ END IF
+ END IF
+ ELSE IF( C2.EQ.'TR' ) THEN
+ IF( C3.EQ.'TRI' ) THEN
+ IF( SNAME ) THEN
+ NB = 64
+ ELSE
+ NB = 64
+ END IF
+ END IF
+ ELSE IF( C2.EQ.'LA' ) THEN
+ IF( C3.EQ.'UUM' ) THEN
+ IF( SNAME ) THEN
+ NB = 64
+ ELSE
+ NB = 64
+ END IF
+ END IF
+ ELSE IF( SNAME .AND. C2.EQ.'ST' ) THEN
+ IF( C3.EQ.'EBZ' ) THEN
+ NB = 1
+ END IF
+ END IF
+ PILAENVX = NB
+ RETURN
+*
+ 60 CONTINUE
+*
+* ISPEC = 2: minimum block size
+*
+ NBMIN = 2
+ IF( C2.EQ.'GE' ) THEN
+ IF( C3.EQ.'QRF' .OR. C3.EQ.'RQF' .OR. C3.EQ.'LQF' .OR. C3.EQ.
+ $ 'QLF' ) THEN
+ IF( SNAME ) THEN
+ NBMIN = 2
+ ELSE
+ NBMIN = 2
+ END IF
+ ELSE IF( C3.EQ.'HRD' ) THEN
+ IF( SNAME ) THEN
+ NBMIN = 2
+ ELSE
+ NBMIN = 2
+ END IF
+ ELSE IF( C3.EQ.'BRD' ) THEN
+ IF( SNAME ) THEN
+ NBMIN = 2
+ ELSE
+ NBMIN = 2
+ END IF
+ ELSE IF( C3.EQ.'TRI' ) THEN
+ IF( SNAME ) THEN
+ NBMIN = 2
+ ELSE
+ NBMIN = 2
+ END IF
+ END IF
+ ELSE IF( C2.EQ.'SY' ) THEN
+ IF( C3.EQ.'TRF' ) THEN
+ IF( SNAME ) THEN
+ NBMIN = 8
+ ELSE
+ NBMIN = 8
+ END IF
+ ELSE IF( SNAME .AND. C3.EQ.'TRD' ) THEN
+ NBMIN = 2
+ END IF
+ ELSE IF( CNAME .AND. C2.EQ.'HE' ) THEN
+ IF( C3.EQ.'TRD' ) THEN
+ NBMIN = 2
+ END IF
+ ELSE IF( SNAME .AND. C2.EQ.'OR' ) THEN
+ IF( C3( 1: 1 ).EQ.'G' ) THEN
+ IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ.
+ $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' )
+ $ THEN
+ NBMIN = 2
+ END IF
+ ELSE IF( C3( 1: 1 ).EQ.'M' ) THEN
+ IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ.
+ $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' )
+ $ THEN
+ NBMIN = 2
+ END IF
+ END IF
+ ELSE IF( CNAME .AND. C2.EQ.'UN' ) THEN
+ IF( C3( 1: 1 ).EQ.'G' ) THEN
+ IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ.
+ $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' )
+ $ THEN
+ NBMIN = 2
+ END IF
+ ELSE IF( C3( 1: 1 ).EQ.'M' ) THEN
+ IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ.
+ $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' )
+ $ THEN
+ NBMIN = 2
+ END IF
+ END IF
+ END IF
+ PILAENVX = NBMIN
+ RETURN
+*
+ 70 CONTINUE
+*
+* ISPEC = 3: crossover point
+*
+ NX = 0
+ IF( C2.EQ.'GE' ) THEN
+ IF( C3.EQ.'QRF' .OR. C3.EQ.'RQF' .OR. C3.EQ.'LQF' .OR. C3.EQ.
+ $ 'QLF' ) THEN
+ IF( SNAME ) THEN
+ NX = 128
+ ELSE
+ NX = 128
+ END IF
+ ELSE IF( C3.EQ.'HRD' ) THEN
+ IF( SNAME ) THEN
+ NX = 128
+ ELSE
+ NX = 128
+ END IF
+ ELSE IF( C3.EQ.'BRD' ) THEN
+ IF( SNAME ) THEN
+ NX = 128
+ ELSE
+ NX = 128
+ END IF
+ END IF
+ ELSE IF( C2.EQ.'SY' ) THEN
+ IF( SNAME .AND. C3.EQ.'TRD' ) THEN
+ NX = 32
+ END IF
+ ELSE IF( CNAME .AND. C2.EQ.'HE' ) THEN
+ IF( C3.EQ.'TRD' ) THEN
+ NX = 32
+ END IF
+ ELSE IF( SNAME .AND. C2.EQ.'OR' ) THEN
+ IF( C3( 1: 1 ).EQ.'G' ) THEN
+ IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ.
+ $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' )
+ $ THEN
+ NX = 128
+ END IF
+ END IF
+ ELSE IF( CNAME .AND. C2.EQ.'UN' ) THEN
+ IF( C3( 1: 1 ).EQ.'G' ) THEN
+ IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ.
+ $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' )
+ $ THEN
+ NX = 128
+ END IF
+ END IF
+ END IF
+ PILAENVX = NX
+ RETURN
+*
+ 80 CONTINUE
+*
+* ISPEC = 4: number of shifts (used by xHSEQR)
+*
+ PILAENVX = 6
+ RETURN
+*
+ 90 CONTINUE
+*
+* ISPEC = 5: minimum column dimension (not used)
+*
+ PILAENVX = 2
+ RETURN
+*
+ 100 CONTINUE
+*
+* ISPEC = 6: crossover point for SVD (used by xGELSS and xGESVD)
+*
+ PILAENVX = INT( REAL( MIN( N1, N2 ) )*1.6E0 )
+ RETURN
+*
+ 110 CONTINUE
+*
+* ISPEC = 7: number of processors (not used)
+*
+ PILAENVX = 1
+ RETURN
+*
+ 120 CONTINUE
+*
+* ISPEC = 8: crossover point for multishift (used by xHSEQR)
+*
+ PILAENVX = 50
+ RETURN
+*
+ 130 CONTINUE
+*
+* ISPEC = 9: maximum size of the subproblems at the bottom of the
+* computation tree in the divide-and-conquer algorithm
+* (used by xGELSD and xGESDD)
+*
+ PILAENVX = 25
+ RETURN
+*
+ 140 CONTINUE
+*
+* ISPEC = 10: ieee NaN arithmetic can be trusted not to trap
+*
+* PILAENVX = 0
+ PILAENVX = 1
+ IF( PILAENVX.EQ.1 ) THEN
+ PILAENVX = IEEECK( 0, 0.0, 1.0 )
+ END IF
+ RETURN
+*
+ 150 CONTINUE
+*
+* ISPEC = 11: infinity arithmetic can be trusted not to trap
+*
+* PILAENVX = 0
+ PILAENVX = 1
+ IF( PILAENVX.EQ.1 ) THEN
+ PILAENVX = IEEECK( 1, 0.0, 1.0 )
+ END IF
+ RETURN
+*
+ 160 CONTINUE
+*
+* 12 <= ISPEC <= 16 or ISPEC = 24: xHSEQR or one of its subroutines.
+*
+ PILAENVX = PIPARMQ( ICTXT, ISPEC, NAME, OPTS, N1, N2, N3, N4 )
+ RETURN
+*
+ 170 CONTINUE
+*
+* ISPEC = 17: maximum number of independent computational windows
+*
+ CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL )
+ PILAENVX = MIN( ICEIL(N1,N2), MIN( NPROW, NPCOL) )
+ RETURN
+*
+ 180 CONTINUE
+*
+* ISPEC = 18: number of eigenvalues in each window
+*
+ PILAENVX = MIN(N2/2,40)
+ RETURN
+*
+ 190 CONTINUE
+*
+* ISPEC = 19: computational window size
+*
+ PILAENVX = MIN(N2,80)
+ RETURN
+*
+ 200 CONTINUE
+*
+* ISPEC = 20: minimal percentage of flops required for
+* performing matrix-matrix multiplications instead of
+* pipelined orthogonal transformations
+*
+*
+ PILAENVX = 50
+ RETURN
+*
+ 210 CONTINUE
+*
+* ISPEC = 21: width of block column slabs for row-wise
+* application of pipelined orthogonal transformations in
+* their factorized form
+*
+*
+ PILAENVX = MIN(N2,32)
+ RETURN
+*
+ 220 CONTINUE
+*
+* ISPEC = 22: maximum number of eigenvalues to bring over
+* the block border
+*
+*
+ PILAENVX = MIN(N2/2,40)
+ RETURN
+ 230 CONTINUE
+*
+* ISPEC = 23: number of processors involved in AED
+*
+*
+ PILAENVX = ICEIL(N1, ICEIL(384, N2)*N2)
+ RETURN
+ 990 CONTINUE
+*
+* ISPEC = 99: maximum chunksize of iterations in OpenMP
+* parallelization
+*
+ PILAENVX = 32
+ RETURN
+*
+* End of PILAENVX
+*
+ END
diff --git a/SRC/pilaver.f b/SRC/pilaver.f
new file mode 100644
index 0000000..08b8167
--- /dev/null
+++ b/SRC/pilaver.f
@@ -0,0 +1,32 @@
+ SUBROUTINE PILAVER( VERS_MAJOR, VERS_MINOR, VERS_PATCH )
+C
+C -- ScaLAPACK computational routine (version 2.0.1 ) --
+C -- ScaLAPACK is a software package provided by Univ. of Tennessee, --
+C -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+C January 2012
+C
+C Purpose
+C =======
+C
+C This subroutine return the ScaLAPACK version.
+C
+C Arguments
+C =========
+C VERS_MAJOR (output) INTEGER
+C return the scalapack major version
+C VERS_MINOR (output) INTEGER
+C return the scalapack minor version from the major version
+C VERS_PATCH (output) INTEGER
+C return the scalapack patch version from the minor version
+C =====================================================================
+C
+ INTEGER VERS_MAJOR, VERS_MINOR, VERS_PATCH
+C =====================================================================
+ VERS_MAJOR = 2
+ VERS_MINOR = 0
+ VERS_PATCH = 1
+C =====================================================================
+C
+ RETURN
+ END
+
diff --git a/SRC/piparmq.f b/SRC/piparmq.f
new file mode 100644
index 0000000..8bb7395
--- /dev/null
+++ b/SRC/piparmq.f
@@ -0,0 +1,304 @@
+ INTEGER FUNCTION PIPARMQ( ICTXT, ISPEC, NAME, OPTS, N, ILO, IHI,
+ $ LWORKNB )
+*
+* Contribution from the Department of Computing Science and HPC2N,
+* Umea University, Sweden
+*
+* -- ScaLAPACK auxiliary routine (version 2.0.1) --
+* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
+* Univ. of Colorado Denver and University of California, Berkeley.
+* January, 2012
+*
+ IMPLICIT NONE
+*
+* .. Scalar Arguments ..
+ INTEGER ICTXT, IHI, ILO, ISPEC, LWORKNB, N
+ CHARACTER NAME*( * ), OPTS*( * )
+*
+* Purpose
+* =======
+*
+* This program sets problem and machine dependent parameters
+* useful for PxHSEQR and its subroutines. It is called whenever
+* PILAENVX is called with 12 <= ISPEC <= 16
+*
+* Arguments
+* =========
+*
+* ICTXT (local input) INTEGER
+* On entry, ICTXT specifies the BLACS context handle,
+* indicating the global context of the operation. The
+* context itself is global, but the value of ICTXT is
+* local.
+*
+* ISPEC (global input) INTEGER
+* ISPEC specifies which tunable parameter PIPARMQ should
+* return.
+*
+* ISPEC=12: (INMIN) Matrices of order nmin or less
+* are sent directly to PxLAHQR, the implicit
+* double shift QR algorithm. NMIN must be
+* at least 11.
+*
+* ISPEC=13: (INWIN) Size of the deflation window.
+* This is best set greater than or equal to
+* the number of simultaneous shifts NS.
+* Larger matrices benefit from larger deflation
+* windows.
+*
+* ISPEC=14: (INIBL) Determines when to stop nibbling and
+* invest in an (expensive) multi-shift QR sweep.
+* If the aggressive early deflation subroutine
+* finds LD converged eigenvalues from an order
+* NW deflation window and LD.GT.(NW*NIBBLE)/100,
+* then the next QR sweep is skipped and early
+* deflation is applied immediately to the
+* remaining active diagonal block. Setting
+* PIPARMQ(ISPEC=14) = 0 causes PxLAQR0 to skip a
+* multi-shift QR sweep whenever early deflation
+* finds a converged eigenvalue. Setting
+* PIPARMQ(ISPEC=14) greater than or equal to 100
+* prevents PxLAQR0 from skipping a multi-shift
+* QR sweep.
+*
+* ISPEC=15: (NSHFTS) The number of simultaneous shifts in
+* a multi-shift QR iteration.
+*
+* ISPEC=16: (IACC22) PIPARMQ is set to 1 or 2 with the
+* following meanings.
+* 1: During the multi-shift QR sweep,
+* PxLAQR5 and/or xLAQR6 accumulates reflections
+* and uses matrix-matrix multiply to update
+* the far-from-diagonal matrix entries.
+* 2: During the multi-shift QR sweep.
+* PxLAQR5 accumulates reflections and takes
+* advantage of 2-by-2 block structure during
+* matrix-matrix multiplies.
+*
+* ( IACC22=0 is valid in LAPACK but not here.
+* Householder reflections are always accumulated
+* for the performance consideration.
+* If xTRMM is slower than xGEMM or NB is small,
+* PIPARMQ(ISPEC=16)=1 may be more efficient than
+* PIPARMQ(ISPEC=16)=2 despite the greater level of
+* arithmetic work implied by the latter choice. )
+*
+* NAME (global input) character string
+* Name of the calling subroutine
+*
+* OPTS (global input) character string
+* This is a concatenation of the string arguments to
+* TTQRE.
+*
+* N (global input) integer scalar
+* N is the order of the Hessenberg matrix H.
+*
+* ILO (global input) INTEGER
+* IHI (global input) INTEGER
+* It is assumed that H is already upper triangular
+* in rows and columns 1:ILO-1 and IHI+1:N.
+*
+* LWORKNB (global input) INTEGER
+* The amount of workspace available or the blockfactor.
+*
+* Further Details
+* ===============
+*
+* Little is known about how best to choose these parameters.
+* It is possible to use different values of the parameters
+* for each of PCHSEQR, PDHSEQR, PSHSEQR and PZHSEQR.
+*
+* It is probably best to choose different parameters for
+* different matrices and different parameters at different
+* times during the iteration, but this has not been fully
+* implemented --- yet.
+*
+*
+* The best choices of most of the parameters depend
+* in an ill-understood way on the relative execution
+* rate of PxLAQR3 and PxLAQR5 and on the nature of each
+* particular eigenvalue problem. Experiment may be the
+* only practical way to determine which choices are most
+* effective.
+*
+* Following is a list of default values supplied by PIPARMQ.
+* These defaults may be adjusted in order to attain better
+* performance in any particular computational environment.
+*
+* PIPARMQ(ISPEC=12) The PxLAQR1 vs PxLAQR0 crossover point.
+* Default: 220. (Must be at least 11.)
+*
+* PIPARMQ(ISPEC=13) Recommended deflation window size.
+* This depends on ILO, IHI and NS, the
+* number of simultaneous shifts returned
+* by PIPARMQ(ISPEC=15). The default for
+* (IHI-ILO+1).LE.500 is NS. The default
+* for (IHI-ILO+1).GT.500 is 3*NS/2.
+*
+* PIPARMQ(ISPEC=14) Nibble crossover point.
+* The default for the serial case is 14.
+* The default for the parallel case is
+* 335 * N**(-0.44) * NPROCS.
+*
+* PIPARMQ(ISPEC=15) Number of simultaneous shifts, NS.
+* a multi-shift QR iteration.
+*
+* If IHI-ILO+1 is ...
+*
+* greater than ...but less ... the
+* or equal to ... than default is
+*
+* 0 30 NS = 2+
+* 30 60 NS = 4+
+* 60 150 NS = 10
+* 150 590 NS = **
+* 590 3000 NS = 64
+* 3000 6000 NS = 128
+* 6000 12000 NS = 256
+* 12000 24000 NS = 512
+* 24000 48000 NS = 1024
+* 48000 96000 NS = 2048
+* 96000 INFINITY NS = 4096
+*
+* (+) By default matrices of this order are
+* passed to the implicit double shift routine
+* PxLAQR1. See PIPARMQ(ISPEC=12) above. These
+* values of NS are used only in case of a rare
+* PxLAQR1 failure.
+*
+* (**) The asterisks (**) indicate an ad-hoc
+* function increasing from 10 to 64.
+*
+* PIPARMQ(ISPEC=16) Select structured matrix multiply.
+* (See ISPEC=16 above for details.)
+* Default: 3.
+*
+* ================================================================
+* .. Parameters ..
+ INTEGER INMIN, INWIN, INIBL, ISHFTS, IACC22
+ PARAMETER ( INMIN = 12, INWIN = 13, INIBL = 14,
+ $ ISHFTS = 15, IACC22 = 16 )
+ INTEGER NMIN, NMIN2, K22MIN, KACMIN, NIBBLE, KNWSWP
+ PARAMETER ( NMIN = 220, K22MIN = 14, KACMIN = 14,
+ $ NIBBLE = 14, KNWSWP = 500, NMIN2 = 770 )
+ REAL TWO
+ PARAMETER ( TWO = 2.0 )
+* ..
+* .. Local Scalars ..
+ INTEGER NH, NS, MYROW, MYCOL, NPROW, NPCOL, NP
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC LOG, MAX, MOD, NINT, REAL
+* ..
+* .. External functions ..
+ INTEGER ICEIL
+ EXTERNAL ICEIL
+* ..
+* .. External Subroutines ..
+ EXTERNAL BLACS_GRIDINFO
+* ..
+* .. Executable Statements ..
+ CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL )
+*
+ IF( ( ISPEC.EQ.ISHFTS ) .OR. ( ISPEC.EQ.INWIN ) .OR.
+ $ ( ISPEC.EQ.IACC22 ) ) THEN
+*
+* ==== Set the number simultaneous shifts ====
+*
+ NH = IHI - ILO + 1
+ NS = 2
+ IF( NH.GE.30 )
+ $ NS = 4
+ IF( NH.GE.60 )
+ $ NS = 10
+ IF( NH.GE.150 )
+ $ NS = MAX( 10, NH / NINT( LOG( REAL( NH ) ) / LOG( TWO ) ))
+ IF( NH.GE.590 )
+ $ NS = 64
+ IF( NH.GE.3000 )
+ $ NS = 128
+ IF( NH.GE.6000 )
+ $ NS = 256
+ IF( NH.GE.12000 )
+ $ NS = 512
+ IF( NH.GE.24000 )
+ $ NS = 1024
+ IF( NH.GE.48000 )
+ $ NS = 2048
+ IF( NH.GE.96000 )
+ $ NS = 4096
+ IF( NH.GE.192000 )
+ $ NS = 8192
+ IF( NH.GE.384000 )
+ $ NS = 16384
+ IF( NH.GE.768000 )
+ $ NS = 32768
+ IF( NH.GE.1000000 )
+ $ NS = ICEIL( NH, 25 )
+ NS = MAX( NS, 2*MIN(NPROW,NPCOL) )
+ NS = MAX( 2, NS-MOD( NS, 2 ) )
+ END IF
+*
+ IF( ISPEC.EQ.INMIN ) THEN
+*
+*
+* ===== Submatrices of order smaller than NMIN*min(P_r,P_c)
+* . get sent to PxLAHQR, the classic ScaLAPACK algorithm.
+* . This must be at least 11. ====
+*
+ PIPARMQ = NMIN * MIN( NPROW, NPCOL )
+*
+ ELSE IF( ISPEC.EQ.INIBL ) THEN
+*
+* ==== INIBL: skip a multi-shift QR iteration and
+* . whenever aggressive early deflation finds
+* . at least (NIBBLE*(window size)/100) deflations. ====
+*
+ NP = MIN( NPROW, NPCOL )
+ IF( NP.EQ.1 ) THEN
+ PIPARMQ = NIBBLE
+ ELSE
+ NH = IHI - ILO + 1
+ PIPARMQ = MIN( 100,
+ $ CEILING( 335.0D+0 * NH**(-0.44D+0) * NP ) )
+ END IF
+*
+ ELSE IF( ISPEC.EQ.ISHFTS ) THEN
+*
+* ==== NSHFTS: The number of simultaneous shifts =====
+*
+ PIPARMQ = NS
+*
+ ELSE IF( ISPEC.EQ.INWIN ) THEN
+*
+* ==== NW: deflation window size. ====
+*
+ IF( NH.LE.KNWSWP ) THEN
+ PIPARMQ = NS
+ ELSE
+ PIPARMQ = 3*NS / 2
+ END IF
+*
+ ELSE IF( ISPEC.EQ.IACC22 ) THEN
+*
+* ==== IACC22: Whether to use 2-by-2 block structure while
+* . doing it. A small amount of work could be saved
+* . by making this choice dependent also upon the
+* . NH=IHI-ILO+1.
+*
+ PIPARMQ = 1
+c PIPARMQ = 0
+c IF( NS.GE.KACMIN )
+c $ PIPARMQ = 1
+ IF( NS.GE.K22MIN )
+ $ PIPARMQ = 2
+*
+ ELSE
+* ===== invalid value of ispec =====
+ PIPARMQ = -1
+*
+ END IF
+*
+* ==== End of PIPARMQ ====
+*
+ END
diff --git a/SRC/pjlaenv.f b/SRC/pjlaenv.f
index 006b725..0efc82b 100644
--- a/SRC/pjlaenv.f
+++ b/SRC/pjlaenv.f
@@ -351,6 +351,7 @@
100 CONTINUE
*
IF( GLOBAL ) THEN
+ IDUMM = 0
CALL IGAMX2D( ICTXT, 'All', ' ', 1, 1, PJLAENV, 1, IDUMM,
$ IDUMM, -1, -1, IDUMM )
END IF
diff --git a/SRC/pmpcol.f b/SRC/pmpcol.f
new file mode 100644
index 0000000..498d55b
--- /dev/null
+++ b/SRC/pmpcol.f
@@ -0,0 +1,109 @@
+***********************************************************************
+*
+* Auxiliary subroutine for eigenpair assignments
+*
+***********************************************************************
+ SUBROUTINE PMPCOL( MYPROC, NPROCS, IIL, NEEDIL, NEEDIU,
+ $ PMYILS, PMYIUS,
+ $ COLBRT, FRSTCL, LASTCL )
+
+ IMPLICIT NONE
+*
+* -- ScaLAPACK auxiliary routine (version 2.0.2) --
+* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver
+* May 1 2012
+*
+* .. Scalar Arguments ..
+ INTEGER FRSTCL, IIL, LASTCL, MYPROC, NEEDIL, NEEDIU,
+ $ NPROCS
+ LOGICAL COLBRT
+* ..
+* .. Array Arguments ..
+ INTEGER PMYILS( * ), PMYIUS( * )
+* ..
+*
+* Purpose
+* =======
+*
+* Using the output from PMPIM2 and given the information on
+* eigenvalue clusters, PMPCOL finds the collaborators of MYPROC.
+*
+* Arguments
+* =========
+*
+* MYPROC (input) INTEGER
+* The processor number, 0 <= MYPROC < NPROCS
+*
+* NPROCS (input) INTEGER
+* The total number of processors available
+*
+* IIL (input) INTEGER
+* The index of the leftmost eigenvalue in W
+*
+* NEEDIL (input) INTEGER
+* The leftmost position in W needed by MYPROC
+*
+* NEEDIU (input) INTEGER
+* The rightmost position in W needed by MYPROC
+*
+* PMYILS (input) INTEGER array
+* For each processor p, PMYILS(p) is the index
+* of the first eigenvalue in W to be computed
+* PMYILS(p) equals zero if p stays idle
+*
+* PMYIUS (input) INTEGER array
+* For each processor p, PMYIUS(p) is the index
+* of the last eigenvalue in W to be computed
+* PMYIUS(p) equals zero if p stays idle
+*
+* COLBRT (output) LOGICAL
+* TRUE if MYPROC collaborates.
+*
+* FRSTCL (output) INTEGER
+* LASTCL FIRST and LAST collaborator of MYPROC
+* MYPROC collaborates with
+* FRSTCL, ..., MYPROC-1, MYPROC+1, ...,LASTCL
+* If MYPROC == FRSTCL, there are no collaborators
+* on the left. IF MYPROC == LASTCL, there are no
+* collaborators on the right.
+* If FRSTCL == 0 and LASTCL = NPROCS-1, then
+* MYPROC collaborates with everybody
+*
+
+* .. Local Scalars ..
+ INTEGER I, NEEDIIL, NEEDIIU
+* ..
+* .. Executable Statements ..
+* Compute global eigenvalue index from position in W
+ NEEDIIL = NEEDIL + IIL - 1
+ NEEDIIU = NEEDIU + IIL - 1
+
+* Find processor responsible for NEEDIL, this is the first
+* collaborator
+ DO 1 I = 1, NPROCS
+ IF( PMYILS(I).GT.NEEDIIL) GOTO 2
+ FRSTCL = I-1
+ 1 CONTINUE
+ 2 CONTINUE
+
+* Find processor responsible for NEEDIU, this is the last
+* collaborator
+ DO 3 I = NPROCS,1,-1
+ IF( PMYIUS(I).LT.NEEDIIU ) THEN
+* Need to check special case: does this proc work at all?
+ IF( PMYIUS(I).GT.0 )
+ $ GOTO 4
+ ENDIF
+ LASTCL = I-1
+ 3 CONTINUE
+ 4 CONTINUE
+
+* Decide if there is a collaboration
+ IF( (FRSTCL.LT.MYPROC).OR.(LASTCL.GT.MYPROC) ) THEN
+ COLBRT = .TRUE.
+ ELSE
+ COLBRT = .FALSE.
+ ENDIF
+
+ RETURN
+ END
diff --git a/SRC/pmpim2.f b/SRC/pmpim2.f
new file mode 100644
index 0000000..90f9a8e
--- /dev/null
+++ b/SRC/pmpim2.f
@@ -0,0 +1,76 @@
+***********************************************************************
+*
+* Auxiliary subroutine for eigenpair assignments
+*
+***********************************************************************
+ SUBROUTINE PMPIM2( IL, IU, NPROCS, PMYILS, PMYIUS )
+
+ IMPLICIT NONE
+*
+* -- ScaLAPACK auxiliary routine (version 2.0.2) --
+* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver
+* May 1 2012
+*
+* .. Scalar Arguments ..
+ INTEGER PMYILS( * ), PMYIUS( * )
+* ..
+* .. Array Arguments ..
+ INTEGER IL, IU, M, NPROCS, PRCCTR
+* ..
+*
+* Purpose
+* =======
+*
+* PMPIM2 is the scheduling subroutine.
+* It computes for all processors the eigenpair range assignments.
+*
+* Arguments
+* =========
+*
+* IL, IU (input) INTEGER
+* The range of eigenpairs to be computed
+*
+* NPROCS (input) INTEGER
+* The total number of processors available
+*
+* PMYILS (output) INTEGER array
+* For each processor p, PMYILS(p) is the index
+* of the first eigenvalue in W to be computed
+* PMYILS(p) equals zero if p stays idle
+*
+* PMYIUS (output) INTEGER array
+* For each processor p, PMYIUS(p) is the index
+* of the last eigenvalue in W to be computed
+* PMYIUS(p) equals zero if p stays idle
+*
+
+* .. Executable Statements ..
+ M = IU - IL + 1
+
+ IF ( NPROCS.GT.M ) THEN
+ DO 10 PRCCTR = 0, NPROCS-1
+ IF ( PRCCTR.LT.M ) THEN
+ PMYILS(PRCCTR+1) = PRCCTR + IL
+ PMYIUS(PRCCTR+1) = PRCCTR + IL
+ ELSE
+ PMYILS(PRCCTR+1) = 0
+ PMYIUS(PRCCTR+1) = 0
+ END IF
+ 10 CONTINUE
+ ELSE
+ DO 20 PRCCTR = 0, NPROCS-1
+ PMYILS(PRCCTR+1) = (PRCCTR * (M / NPROCS)) + IL
+ IF (PRCCTR.LT.MOD(M, NPROCS)) THEN
+ PMYILS(PRCCTR+1) = PMYILS(PRCCTR+1) + PRCCTR
+ PMYIUS(PRCCTR+1) = PMYILS(PRCCTR+1) + M / NPROCS
+ ELSE
+ PMYILS(PRCCTR+1) = PMYILS(PRCCTR+1) + MOD(M, NPROCS)
+ PMYIUS(PRCCTR+1) = PMYILS(PRCCTR+1) + M / NPROCS - 1
+ END IF
+ 20 CONTINUE
+ END IF
+
+ RETURN
+ END
+
+
diff --git a/SRC/psdbtrf.f b/SRC/psdbtrf.f
index a251310..be99d85 100644
--- a/SRC/psdbtrf.f
+++ b/SRC/psdbtrf.f
@@ -1,10 +1,9 @@
SUBROUTINE PSDBTRF( N, BWL, BWU, A, JA, DESCA, AF, LAF, WORK,
$ LWORK, INFO )
*
-* -- ScaLAPACK routine (version 1.7) --
-* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
-* and University of California, Berkeley.
-* March 12, 2002
+* -- ScaLAPACK routine (version 2.0.2) --
+* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver
+* May 1 2012
*
* .. Scalar Arguments ..
INTEGER BWL, BWU, INFO, JA, LAF, LWORK, N
@@ -371,7 +370,7 @@
* .. External Subroutines ..
EXTERNAL BLACS_GRIDEXIT, BLACS_GRIDINFO, SAXPY, SDBTRF,
$ DESC_CONVERT, SGEMM, SGEMV, SGERV2D, SGESD2D,
- $ SLACPY, SLATCPY, STBTRS, STRMM, STRRV2D,
+ $ SLAMOV, SLATCPY, STBTRS, STRMM, STRRV2D,
$ STRSD2D, GLOBCHK, IGAMX2D, IGEBR2D, IGEBS2D,
$ PXERBLA, RESHAPE
* ..
@@ -723,7 +722,7 @@
CALL SLATCPY( 'U', BWL, BWL, A( ( OFST+( BWL+BWU+1 )+
$ ( ODD_SIZE-BWL )*LLDA ) ), LLDA-1,
$ AF( ODD_SIZE*BWU+2*MBW2+1+MAX_BW-BWL ), MAX_BW )
- CALL SLACPY( 'L', BWU, BWU, A( ( OFST+1+ODD_SIZE*LLDA ) ),
+ CALL SLAMOV( 'L', BWU, BWU, A( ( OFST+1+ODD_SIZE*LLDA ) ),
$ LLDA-1, AF( WORK_U+ODD_SIZE*BWL+2*MBW2+1+MAX_BW-
$ BWU ), MAX_BW )
*
@@ -750,7 +749,7 @@
*
* Move the resulting block back to its location in main storage.
*
- CALL SLACPY( 'L', BWU, BWU, AF( WORK_U+ODD_SIZE*BWL+2*MBW2+1+
+ CALL SLAMOV( 'L', BWU, BWU, AF( WORK_U+ODD_SIZE*BWL+2*MBW2+1+
$ MAX_BW-BWU ), MAX_BW, A( ( OFST+1+ODD_SIZE*
$ LLDA ) ), LLDA-1 )
*
@@ -816,7 +815,7 @@
*
* Copy D block into AF storage for solve.
*
- CALL SLACPY( 'L', UP_PREV_TRI_SIZE_N, UP_PREV_TRI_SIZE_M,
+ CALL SLAMOV( 'L', UP_PREV_TRI_SIZE_N, UP_PREV_TRI_SIZE_M,
$ A( OFST+1 ), LLDA-1, AF( 1 ), BWU )
*
DO 80 I1 = 1, ODD_SIZE
@@ -865,7 +864,7 @@
* Since we have GU_i stored,
* transpose HU_i to HU_i^T.
*
- CALL SLACPY( 'N', BWL, BWL,
+ CALL SLAMOV( 'N', BWL, BWL,
$ AF( WORK_U+( ODD_SIZE-BWL )*BWL+1 ), BWL,
$ AF( ( ODD_SIZE )*BWU+1+( MAX_BW-BWL ) ),
$ MAX_BW )
@@ -881,7 +880,7 @@
* Since we have GL_i^T stored,
* transpose HL_i^T to HL_i.
*
- CALL SLACPY( 'N', BWU, BWU, AF( ( ODD_SIZE-BWU )*BWU+1 ),
+ CALL SLAMOV( 'N', BWU, BWU, AF( ( ODD_SIZE-BWU )*BWU+1 ),
$ BWU, AF( WORK_U+( ODD_SIZE )*BWL+1+MAX_BW-
$ BWU ), MAX_BW )
*
@@ -946,7 +945,7 @@
* Copy last diagonal block into AF storage for subsequent
* operations.
*
- CALL SLACPY( 'N', MAX_BW, MAX_BW, A( OFST+ODD_SIZE*LLDA+BWU+1 ),
+ CALL SLAMOV( 'N', MAX_BW, MAX_BW, A( OFST+ODD_SIZE*LLDA+BWU+1 ),
$ LLDA-1, AF( ODD_SIZE*BWU+MBW2+1 ), MAX_BW )
*
* Receive cont. to diagonal block that is stored on this proc.
@@ -1030,10 +1029,10 @@
* Move block into place that it will be expected to be for
* calcs.
*
- CALL SLACPY( 'N', MAX_BW, MAX_BW, AF( ODD_SIZE*BWU+1 ), MAX_BW,
+ CALL SLAMOV( 'N', MAX_BW, MAX_BW, AF( ODD_SIZE*BWU+1 ), MAX_BW,
$ AF( WORK_U+ODD_SIZE*BWL+2*MBW2+1 ), MAX_BW )
*
- CALL SLACPY( 'N', MAX_BW, MAX_BW, AF( WORK_U+ODD_SIZE*BWL+1 ),
+ CALL SLAMOV( 'N', MAX_BW, MAX_BW, AF( WORK_U+ODD_SIZE*BWL+1 ),
$ MAX_BW, AF( ODD_SIZE*BWU+2*MBW2+1 ), MAX_BW )
*
ELSE
diff --git a/SRC/psdbtrsv.f b/SRC/psdbtrsv.f
index b6f733b..370fda3 100644
--- a/SRC/psdbtrsv.f
+++ b/SRC/psdbtrsv.f
@@ -1,10 +1,9 @@
SUBROUTINE PSDBTRSV( UPLO, TRANS, N, BWL, BWU, NRHS, A, JA, DESCA,
$ B, IB, DESCB, AF, LAF, WORK, LWORK, INFO )
*
-* -- ScaLAPACK routine (version 1.7) --
-* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
-* and University of California, Berkeley.
-* April 3, 2000
+* -- ScaLAPACK routine (version 2.0.2) --
+* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver
+* May 1 2012
*
* .. Scalar Arguments ..
CHARACTER TRANS, UPLO
@@ -399,7 +398,7 @@
* ..
* .. External Subroutines ..
EXTERNAL BLACS_GRIDEXIT, BLACS_GRIDINFO, DESC_CONVERT,
- $ SGEMM, SGERV2D, SGESD2D, SLACPY, SMATADD,
+ $ SGEMM, SGERV2D, SGESD2D, SLAMOV, SMATADD,
$ STBTRS, STRMM, GLOBCHK, PXERBLA, RESHAPE
* ..
* .. External Functions ..
@@ -777,7 +776,7 @@
* First copy and multiply it into temporary storage,
* then use it on RHS
*
- CALL SLACPY( 'N', BWL, NRHS,
+ CALL SLAMOV( 'N', BWL, NRHS,
$ B( PART_OFFSET+ODD_SIZE-BWL+1 ), LLDB,
$ WORK( 1 ), MAX_BW )
*
@@ -1111,7 +1110,7 @@
* First copy and multiply it into temporary storage,
* then use it on RHS
*
- CALL SLACPY( 'N', BWL, NRHS, B( PART_OFFSET+ODD_SIZE+1 ),
+ CALL SLAMOV( 'N', BWL, NRHS, B( PART_OFFSET+ODD_SIZE+1 ),
$ LLDB, WORK( 1+MAX_BW-BWL ), MAX_BW )
*
CALL STRMM( 'L', 'U', 'T', 'N', BWL, NRHS, -ONE,
@@ -1163,7 +1162,7 @@
* First copy and multiply it into temporary storage,
* then use it on RHS
*
- CALL SLACPY( 'N', BWU, NRHS,
+ CALL SLAMOV( 'N', BWU, NRHS,
$ B( PART_OFFSET+ODD_SIZE-BWU+1 ), LLDB,
$ WORK( 1 ), MAX_BW )
*
@@ -1497,7 +1496,7 @@
* First copy and multiply it into temporary storage,
* then use it on RHS
*
- CALL SLACPY( 'N', BWU, NRHS, B( PART_OFFSET+ODD_SIZE+1 ),
+ CALL SLAMOV( 'N', BWU, NRHS, B( PART_OFFSET+ODD_SIZE+1 ),
$ LLDB, WORK( 1+MAX_BW-BWU ), MAX_BW+BWL )
*
CALL STRMM( 'L', 'L', 'N', 'N', BWU, NRHS, -ONE,
diff --git a/SRC/psgbtrf.f b/SRC/psgbtrf.f
index 0e2b80c..338d79b 100644
--- a/SRC/psgbtrf.f
+++ b/SRC/psgbtrf.f
@@ -1,10 +1,9 @@
SUBROUTINE PSGBTRF( N, BWL, BWU, A, JA, DESCA, IPIV, AF, LAF,
$ WORK, LWORK, INFO )
*
-* -- ScaLAPACK routine (version 1.7) --
-* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
-* and University of California, Berkeley.
-* April 3, 2000
+* -- ScaLAPACK routine (version 2.0.2) --
+* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver
+* May 1 2012
*
* .. Scalar Arguments ..
INTEGER BWL, BWU, INFO, JA, LAF, LWORK, N
@@ -385,7 +384,7 @@
* .. External Subroutines ..
EXTERNAL BLACS_GRIDEXIT, BLACS_GRIDINFO, DESC_CONVERT,
$ SGBTRF, SGEMM, SGER, SGERV2D, SGESD2D, SGETRF,
- $ SLACPY, SLASWP, SLATCPY, SSWAP, STRRV2D,
+ $ SLAMOV, SLASWP, SLATCPY, SSWAP, STRRV2D,
$ STRSD2D, STRSM, GLOBCHK, IGAMX2D, IGEBR2D,
$ IGEBS2D, PXERBLA, RESHAPE
* ..
@@ -834,7 +833,7 @@
* DBPTR = Pointer to diagonal blocks in A
DBPTR = BW + 1 + LBWU + LN*LLDA
*
- CALL SLACPY( 'G', BM, BN, A( DBPTR ), LLDA-1, AF( BBPTR+BW*LDBB ),
+ CALL SLAMOV( 'G', BM, BN, A( DBPTR ), LLDA-1, AF( BBPTR+BW*LDBB ),
$ LDBB )
*
* Zero out any junk entries that were copied
@@ -919,7 +918,7 @@
*
* Copy diagonal block to align whole system
*
- CALL SLACPY( 'G', BMN, BW, AF( BBPTR+BM ), LDBB,
+ CALL SLAMOV( 'G', BMN, BW, AF( BBPTR+BM ), LDBB,
$ AF( BBPTR+2*BW*LDBB+BM ), LDBB )
END IF
*
@@ -945,7 +944,7 @@
CALL SGESD2D( ICTXT, BM, 2*BW, AF( BBPTR+BW*LDBB ), LDBB, 0,
$ NEICOL )
*
- CALL SLACPY( 'G', BM, 2*BW, AF( BBPTR+BW*LDBB ), LDBB,
+ CALL SLAMOV( 'G', BM, 2*BW, AF( BBPTR+BW*LDBB ), LDBB,
$ AF( BBPTR+BMN ), LDBB )
*
DO 130 J = BBPTR + 2*BW*LDBB, BBPTR + 3*BW*LDBB - 1, LDBB
@@ -961,7 +960,7 @@
*
* Copy diagonal block to align whole system
*
- CALL SLACPY( 'G', BM, BW, AF( BBPTR+BMN ), LDBB,
+ CALL SLAMOV( 'G', BM, BW, AF( BBPTR+BMN ), LDBB,
$ AF( BBPTR+2*BW*LDBB+BMN ), LDBB )
END IF
*
@@ -1023,9 +1022,9 @@
* Local copying in the block bidiagonal area
*
*
- CALL SLACPY( 'G', BM, BW, AF( BBPTR+BW ), LDBB,
+ CALL SLAMOV( 'G', BM, BW, AF( BBPTR+BW ), LDBB,
$ AF( BBPTR+BW*LDBB ), LDBB )
- CALL SLACPY( 'G', BM, BW, AF( BBPTR+2*BW*LDBB+BW ), LDBB,
+ CALL SLAMOV( 'G', BM, BW, AF( BBPTR+2*BW*LDBB+BW ), LDBB,
$ AF( BBPTR+2*BW*LDBB ), LDBB )
*
* Zero out space that held original copy
diff --git a/SRC/psgbtrs.f b/SRC/psgbtrs.f
index 6efe7e5..e0edcf5 100644
--- a/SRC/psgbtrs.f
+++ b/SRC/psgbtrs.f
@@ -1,10 +1,9 @@
SUBROUTINE PSGBTRS( TRANS, N, BWL, BWU, NRHS, A, JA, DESCA, IPIV,
$ B, IB, DESCB, AF, LAF, WORK, LWORK, INFO )
*
-* -- ScaLAPACK routine (version 1.7) --
-* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
-* and University of California, Berkeley.
-* April 3, 2000
+* -- ScaLAPACK routine (version 2.0.2) --
+* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver
+* May 1 2012
*
* .. Scalar Arguments ..
CHARACTER TRANS
@@ -397,7 +396,7 @@
* .. External Subroutines ..
EXTERNAL BLACS_GRIDEXIT, BLACS_GRIDINFO, SCOPY,
$ DESC_CONVERT, SGEMM, SGEMV, SGER, SGERV2D,
- $ SGESD2D, SGETRS, SLACPY, SLASWP, SSCAL, SSWAP,
+ $ SGESD2D, SGETRS, SLAMOV, SLASWP, SSCAL, SSWAP,
$ STRSM, GLOBCHK, PXERBLA, RESHAPE
* ..
* .. External Functions ..
@@ -725,7 +724,7 @@
*
LDW = NB + BWU + 2*BW + BWU
*
- CALL SLACPY( 'G', LM, NRHS, B( 1 ), LLDB, WORK( WPTR ), LDW )
+ CALL SLAMOV( 'G', LM, NRHS, B( 1 ), LLDB, WORK( WPTR ), LDW )
*
* Zero out rest of work
*
@@ -872,7 +871,7 @@
BMN = BW
END IF
*
- CALL SLACPY( 'G', BM, NRHS, WORK( LN+1 ), LDW,
+ CALL SLAMOV( 'G', BM, NRHS, WORK( LN+1 ), LDW,
$ WORK( NB+BWU+BMN+1 ), LDW )
*
CALL SGERV2D( ICTXT, BMN, NRHS, WORK( NB+BWU+1 ), LDW, 0,
@@ -1023,7 +1022,7 @@
*
* Move RHS to make room for received solutions
*
- CALL SLACPY( 'G', BW, NRHS, WORK( NB+BWU+1 ), LDW,
+ CALL SLAMOV( 'G', BW, NRHS, WORK( NB+BWU+1 ), LDW,
$ WORK( NB+BWU+BW+1 ), LDW )
*
CALL SGERV2D( ICTXT, 2*BW, NRHS, WORK( LN+1 ), LDW, 0,
@@ -1053,7 +1052,7 @@
*
* Copy new solution into expected place
*
- CALL SLACPY( 'G', BW, NRHS, WORK( NB+BWU+1+BW ), LDW,
+ CALL SLAMOV( 'G', BW, NRHS, WORK( NB+BWU+1+BW ), LDW,
$ WORK( LN+BW+1 ), LDW )
*
ELSE
@@ -1071,7 +1070,7 @@
*
* Shift solutions into expected positions
*
- CALL SLACPY( 'G', BNN+BN-BW, NRHS, WORK( NB+BWU+1+BW ), LDW,
+ CALL SLAMOV( 'G', BNN+BN-BW, NRHS, WORK( NB+BWU+1+BW ), LDW,
$ WORK( LN+1 ), LDW )
*
*
@@ -1147,7 +1146,7 @@
*
*
*
- CALL SLACPY( 'G', ODD_SIZE, NRHS, WORK( 1 ), LDW, B( 1 ), LLDB )
+ CALL SLAMOV( 'G', ODD_SIZE, NRHS, WORK( 1 ), LDW, B( 1 ), LLDB )
*
* Free BLACS space used to hold standard-form grid.
*
diff --git a/SRC/psgebal.f b/SRC/psgebal.f
new file mode 100644
index 0000000..ee5c0d4
--- /dev/null
+++ b/SRC/psgebal.f
@@ -0,0 +1,443 @@
+ SUBROUTINE PSGEBAL( JOB, N, A, DESCA, ILO, IHI, SCALE, INFO )
+*
+* Contribution from the Department of Computing Science and HPC2N,
+* Umea University, Sweden
+*
+* -- ScaLAPACK computational routine (version 2.0.1) --
+* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
+* Univ. of Colorado Denver and University of California, Berkeley.
+* January, 2012
+*
+ IMPLICIT NONE
+*
+* .. Scalar Arguments ..
+ CHARACTER JOB
+ INTEGER IHI, ILO, INFO, N
+* ..
+* .. Array Arguments ..
+ INTEGER DESCA( * )
+ REAL A( * ), SCALE( * )
+* ..
+*
+* Purpose
+* =======
+*
+* PSGEBAL 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.
+*
+* Notes
+* =====
+*
+* Each global data object is described by an associated description
+* vector. This vector stores the information required to establish
+* the mapping between an object element and its corresponding process
+* and memory location.
+*
+* Let A be a generic term for any 2D block cyclicly distributed array.
+* Such a global array has an associated description vector DESCA.
+* In the following comments, the character _ should be read as
+* "of the global array".
+*
+* NOTATION STORED IN EXPLANATION
+* --------------- -------------- --------------------------------------
+* DTYPE_A(global) DESCA( DTYPE_ )The descriptor type. In this case,
+* DTYPE_A = 1.
+* CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating
+* the BLACS process grid A is distribu-
+* ted over. The context itself is glo-
+* bal, but the handle (the integer
+* value) may vary.
+* M_A (global) DESCA( M_ ) The number of rows in the global
+* array A.
+* N_A (global) DESCA( N_ ) The number of columns in the global
+* array A.
+* MB_A (global) DESCA( MB_ ) The blocking factor used to distribute
+* the rows of the array.
+* NB_A (global) DESCA( NB_ ) The blocking factor used to distribute
+* the columns of the array.
+* RSRC_A (global) DESCA( RSRC_ ) The process row over which the first
+* row of the array A is distributed.
+* CSRC_A (global) DESCA( CSRC_ ) The process column over which the
+* first column of the array A is
+* distributed.
+* LLD_A (local) DESCA( LLD_ ) The leading dimension of the local
+* array. LLD_A >= MAX(1,LOCr(M_A)).
+*
+* Let K be the number of rows or columns of a distributed matrix,
+* and assume that its process grid has dimension p x q.
+* LOCr( K ) denotes the number of elements of K that a process
+* would receive if K were distributed over the p processes of its
+* process column.
+* Similarly, LOCc( K ) denotes the number of elements of K that a
+* process would receive if K were distributed over the q processes of
+* its process row.
+* The values of LOCr() and LOCc() may be determined via a call to the
+* ScaLAPACK tool function, NUMROC:
+* LOCr( M ) = NUMROC( M, MB_A, MYROW, RSRC_A, NPROW ),
+* LOCc( N ) = NUMROC( N, NB_A, MYCOL, CSRC_A, NPCOL ).
+* An upper bound for these quantities may be computed by:
+* LOCr( M ) <= ceil( ceil(M/MB_A)/NPROW )*MB_A
+* LOCc( N ) <= ceil( ceil(N/NB_A)/NPCOL )*NB_A
+*
+*
+* Arguments
+* =========
+*
+* JOB (global input) CHARACTER*1
+* Specifies the operations to be performed on A:
+* = 'N': none: simply set ILO = 1, IHI = N, SCALE(I) = 1.0
+* for i = 1,...,N;
+* = 'P': permute only;
+* = 'S': scale only;
+* = 'B': both permute and scale.
+*
+* N (global input) INTEGER
+* The order of the matrix A. N >= 0.
+*
+* A (local input/output) REAL array, dimension
+* (DESCA(LLD_,LOCc(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.
+*
+* DESCA (global and local input) INTEGER array of dimension DLEN_.
+* The array descriptor for the distributed matrix A.
+*
+* ILO (global output) INTEGER
+* IHI (global output) INTEGER
+* ILO and IHI are set to integers such that on exit
+* A(i,j) = 0 if i > j and j = 1,...,ILO-1 or I = IHI+1,...,N.
+* If JOB = 'N' or 'S', ILO = 1 and IHI = N.
+*
+* SCALE (global output) REAL array, dimension (N)
+* Details of the permutations and scaling factors applied to
+* A. If P(j) is the index of the row and column interchanged
+* with row and column j and D(j) is the scaling factor
+* applied to row and column j, then
+* SCALE(j) = P(j) for j = 1,...,ILO-1
+* = D(j) for j = ILO,...,IHI
+* = P(j) for j = IHI+1,...,N.
+* The order in which the interchanges are made is N to IHI+1,
+* then 1 to ILO-1.
+*
+* INFO (global output) INTEGER
+* = 0: successful exit.
+* < 0: if INFO = -i, the i-th argument had an illegal value.
+*
+* Further Details
+* ===============
+*
+* The permutations consist of row and column interchanges which put
+* the matrix in the form
+*
+* ( T1 X Y )
+* P A P = ( 0 B Z )
+* ( 0 0 T2 )
+*
+* where T1 and T2 are upper triangular matrices whose eigenvalues lie
+* along the diagonal. The column indices ILO and IHI mark the starting
+* and ending columns of the submatrix B. Balancing consists of applying
+* a diagonal similarity transformation inv(D) * B * D to make the
+* 1-norms of each row of B and its corresponding column nearly equal.
+* The output matrix is
+*
+* ( T1 X*D Y )
+* ( 0 inv(D)*B*D inv(D)*Z ).
+* ( 0 0 T2 )
+*
+* Information about the permutations P and the diagonal matrix D is
+* returned in the vector SCALE.
+*
+* This subroutine is based on the EISPACK routine BALANC. In principle,
+* the parallelism is extracted by using PBLAS and BLACS routines for
+* the permutation and balancing.
+*
+* Modified by Tzu-Yi Chen, Computer Science Division, University of
+* California at Berkeley, USA
+*
+* Parallel version by Robert Granat and Meiyue Shao, Department of
+* Computing Science and HPC2N, Umea University, Sweden
+*
+* =====================================================================
+*
+* .. Parameters ..
+ INTEGER BLOCK_CYCLIC_2D, CSRC_, CTXT_, DLEN_, DTYPE_,
+ $ LLD_, MB_, M_, NB_, N_, RSRC_
+ PARAMETER ( BLOCK_CYCLIC_2D = 1, DLEN_ = 9, DTYPE_ = 1,
+ $ CTXT_ = 2, M_ = 3, N_ = 4, MB_ = 5, NB_ = 6,
+ $ RSRC_ = 7, CSRC_ = 8, LLD_ = 9 )
+ REAL ZERO, ONE
+ PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
+ REAL SCLFAC
+ PARAMETER ( SCLFAC = 2.0E+0 )
+ REAL FACTOR
+ PARAMETER ( FACTOR = 0.95E+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL NOCONV
+ INTEGER I, ICA, IEXC, IRA, J, K, L, M, LLDA,
+ $ ICTXT, NPROW, NPCOL, MYROW, MYCOL, II, JJ,
+ $ ARSRC, ACSRC
+ REAL C, CA, F, G, R, RA, S, SFMAX1, SFMAX2, SFMIN1,
+ $ SFMIN2, ELEM
+* ..
+* .. Local Arrays ..
+ REAL CR( 2 )
+* ..
+* .. External Functions ..
+ LOGICAL SISNAN, LSAME
+ INTEGER IDAMAX
+ REAL SLAMCH
+ EXTERNAL SISNAN, LSAME, SLAMCH
+* ..
+* .. External Subroutines ..
+ EXTERNAL PSSCAL, PSSWAP, PSAMAX, PXERBLA,
+ $ BLACS_GRIDINFO, CHK1MAT, SGSUM2D,
+ $ INFOG2L, PSELGET
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX, MIN
+* ..
+* .. Executable Statements ..
+ INFO = 0
+ ICTXT = DESCA( CTXT_ )
+ CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL )
+*
+* Test the input parameters.
+*
+ 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
+ CALL CHK1MAT( N, 2, N, 2, 1, 1, DESCA, 4, INFO )
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL PXERBLA( 'PSGEBAL', -INFO )
+ RETURN
+ END IF
+*
+* Extract local leading dimension of A.
+*
+ LLDA = DESCA( LLD_ )
+*
+ 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 PSSWAP( L, A, 1, J, DESCA, 1, A, 1, M, DESCA, 1 )
+ CALL PSSWAP( N-K+1, A, J, K, DESCA, DESCA(M_), A, M, K, DESCA,
+ $ DESCA(M_) )
+*
+ 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
+*
+* All processors need the information to make correct decisions.
+*
+ CALL PSELGET( 'All', '1-Tree', ELEM, A, J, I, DESCA )
+ IF( ELEM.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
+*
+* All processors need the information to make correct decisions.
+*
+ CALL PSELGET( 'All', '1-Tree', ELEM, A, I, J, DESCA )
+ IF( ELEM.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 = SLAMCH( 'S' ) / SLAMCH( 'P' )
+ SFMAX1 = ONE / SFMIN1
+ SFMIN2 = SFMIN1*SCLFAC
+ SFMAX2 = ONE / SFMIN2
+ 140 CONTINUE
+ NOCONV = .FALSE.
+*
+ DO 200 I = K, L
+ C = ZERO
+ R = ZERO
+*
+* Compute local partial values of R and C in parallel and combine
+* with a call to the BLACS global summation routine distributing
+* information to all processors.
+*
+ DO 150 J = K, L
+ IF( J.EQ.I )
+ $ GO TO 150
+ CALL INFOG2L( J, I, DESCA, NPROW, NPCOL, MYROW,
+ $ MYCOL, II, JJ, ARSRC, ACSRC )
+ IF( MYROW.EQ.ARSRC .AND. MYCOL.EQ.ACSRC ) THEN
+ C = C + ABS( A( II + (JJ-1)*LLDA ) )
+ END IF
+ CALL INFOG2L( I, J, DESCA, NPROW, NPCOL, MYROW,
+ $ MYCOL, II, JJ, ARSRC, ACSRC )
+ IF( MYROW.EQ.ARSRC .AND. MYCOL.EQ.ACSRC ) THEN
+ R = R + ABS( A( II + (JJ-1)*LLDA ) )
+ END IF
+ 150 CONTINUE
+ CR( 1 ) = C
+ CR( 2 ) = R
+ CALL SGSUM2D( ICTXT, 'All', '1-Tree', 2, 1, CR, 2, -1, -1 )
+ C = CR( 1 )
+ R = CR( 2 )
+*
+* Find global maximum absolute values and indices in parallel.
+*
+ CALL PSAMAX( L, CA, ICA, A, 1, I, DESCA, 1 )
+ CALL PSAMAX( N-K+1, RA, IRA, A, I, K, DESCA, DESCA(M_) )
+*
+* 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( SISNAN( C+F+CA+R+G+RA ) ) THEN
+*
+* Exit if NaN to avoid infinite loop
+*
+ INFO = -3
+ CALL PXERBLA( 'PSGEBAL', -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 PSSCAL( N-K+1, G, A, I, K, DESCA, DESCA(M_) )
+ CALL PSSCAL( L, F, A, 1, I, DESCA, 1 )
+*
+ 200 CONTINUE
+*
+ IF( NOCONV )
+ $ GO TO 140
+*
+ 210 CONTINUE
+ ILO = K
+ IHI = L
+*
+ RETURN
+*
+* End of PSGEBAL
+*
+ END
diff --git a/SRC/psgecon.f b/SRC/psgecon.f
index d794c37..5a0ff15 100644
--- a/SRC/psgecon.f
+++ b/SRC/psgecon.f
@@ -153,7 +153,7 @@
* LIWORK (local or global input) INTEGER
* The dimension of the array IWORK.
* LIWORK is local input and must be at least
-* LIWORK >= LOCr(N+MOD(IA-1,MB_A)).
+* LIWORK >= MAX( 1, LOCr(N+MOD(IA-1,MB_A)) ).
*
* If LIWORK = -1, then LIWORK is global input and a workspace
* query is assumed; the routine only calculates the minimum
@@ -238,7 +238,7 @@
$ DESCA( NB_ )*
$ MAX( 1, ICEIL( NPCOL-1, NPROW ) ) ) )
WORK( 1 ) = REAL( LWMIN )
- LIWMIN = NPMOD
+ LIWMIN = MAX( 1, NPMOD )
IWORK( 1 ) = LIWMIN
LQUERY = ( LWORK.EQ.-1 .OR. LIWORK.EQ.-1 )
*
diff --git a/SRC/psgehrd.f b/SRC/psgehrd.f
index cb9537d..47ad296 100644
--- a/SRC/psgehrd.f
+++ b/SRC/psgehrd.f
@@ -90,7 +90,7 @@
* and JA+IHI:JA+N-1. See Further Details. If N > 0,
* 1 <= ILO <= IHI <= N; otherwise set ILO = 1, IHI = N.
*
-* A (local input/local output) REAL pointer into the
+* A (local input/local output) REAL pointer into the
* local memory to an array of dimension (LLD_A,LOCc(JA+N-1)).
* On entry, this array contains the local pieces of the N-by-N
* general distributed matrix sub( A ) to be reduced. On exit,
@@ -111,12 +111,12 @@
* DESCA (global and local input) INTEGER array of dimension DLEN_.
* The array descriptor for the distributed matrix A.
*
-* TAU (local output) REAL array, dimension LOCc(JA+N-2)
+* TAU (local output) REAL array, dimension LOCc(JA+N-2)
* The scalar factors of the elementary reflectors (see Further
* Details). Elements JA:JA+ILO-2 and JA+IHI:JA+N-2 of TAU are
* set to zero. TAU is tied to the distributed matrix A.
*
-* WORK (local workspace/local output) REAL array,
+* WORK (local workspace/local output) REAL array,
* dimension (LWORK)
* On exit, WORK( 1 ) returns the minimal and optimal LWORK.
*
@@ -225,7 +225,7 @@
EXTERNAL INDXG2P, NUMROC
* ..
* .. Intrinsic Functions ..
- INTRINSIC MAX, MIN, MOD, REAL
+ INTRINSIC FLOAT, MAX, MIN, MOD
* ..
* .. Executable Statements ..
*
@@ -257,13 +257,14 @@
INLQ = NUMROC( N-ILO+IOFF+1, NB, MYCOL, ILCOL, NPCOL )
LWMIN = NB*( NB + MAX( IHIP+1, IHLP+INLQ ) )
*
- WORK( 1 ) = REAL( LWMIN )
+ WORK( 1 ) = FLOAT( LWMIN )
LQUERY = ( LWORK.EQ.-1 )
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( IROFFA.NE.ICOFFA .OR. IROFFA.NE.0 ) THEN
+C ELSE IF( IROFFA.NE.ICOFFA .OR. IROFFA.NE.0 ) THEN
+ ELSE IF( IROFFA.NE.ICOFFA ) THEN
INFO = -6
ELSE IF( DESCA( MB_ ).NE.DESCA( NB_ ) ) THEN
INFO = -(700+NB_)
@@ -372,7 +373,7 @@
CALL PB_TOPSET( ICTXT, 'Combine', 'Columnwise', COLCTOP )
CALL PB_TOPSET( ICTXT, 'Combine', 'Rowwise', ROWCTOP )
*
- WORK( 1 ) = REAL( LWMIN )
+ WORK( 1 ) = FLOAT( LWMIN )
*
RETURN
*
diff --git a/SRC/psgels.f b/SRC/psgels.f
index c4bc6c8..75c7490 100644
--- a/SRC/psgels.f
+++ b/SRC/psgels.f
@@ -277,7 +277,11 @@
INFO = -( 800 + CTXT_ )
ELSE
CALL CHK1MAT( M, 2, N, 3, IA, JA, DESCA, 8, INFO )
- CALL CHK1MAT( N, 3, NRHS, 4, IB, JB, DESCB, 12, INFO )
+ IF ( M .GE. N ) THEN
+ CALL CHK1MAT( M, 2, NRHS, 4, IB, JB, DESCB, 12, INFO )
+ ELSE
+ CALL CHK1MAT( N, 3, NRHS, 4, IB, JB, DESCB, 12, INFO )
+ ENDIF
IF( INFO.EQ.0 ) THEN
IROFFA = MOD( IA-1, DESCA( MB_ ) )
ICOFFA = MOD( JA-1, DESCA( NB_ ) )
diff --git a/SRC/pshseqr.f b/SRC/pshseqr.f
new file mode 100644
index 0000000..3bd077f
--- /dev/null
+++ b/SRC/pshseqr.f
@@ -0,0 +1,682 @@
+ SUBROUTINE PSHSEQR( JOB, COMPZ, N, ILO, IHI, H, DESCH, WR, WI, Z,
+ $ DESCZ, WORK, LWORK, IWORK, LIWORK, INFO )
+*
+* Contribution from the Department of Computing Science and HPC2N,
+* Umea University, Sweden
+*
+* -- ScaLAPACK driver routine (version 2.0.1) --
+* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
+* Univ. of Colorado Denver and University of California, Berkeley.
+* January, 2012
+*
+ IMPLICIT NONE
+*
+* .. Scalar Arguments ..
+ INTEGER IHI, ILO, INFO, LWORK, LIWORK, N
+ CHARACTER COMPZ, JOB
+* ..
+* .. Array Arguments ..
+ INTEGER DESCH( * ) , DESCZ( * ), IWORK( * )
+ REAL H( * ), WI( N ), WORK( * ), WR( N ), Z( * )
+* ..
+* Purpose
+* =======
+*
+* PSHSEQR computes the eigenvalues of an upper 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.
+*
+* Notes
+* =====
+*
+* Each global data object is described by an associated description
+* vector. This vector stores the information required to establish
+* the mapping between an object element and its corresponding process
+* and memory location.
+*
+* Let A be a generic term for any 2D block cyclicly distributed array.
+* Such a global array has an associated description vector DESCA.
+* In the following comments, the character _ should be read as
+* "of the global array".
+*
+* NOTATION STORED IN EXPLANATION
+* --------------- -------------- --------------------------------------
+* DTYPE_A(global) DESCA( DTYPE_ )The descriptor type. In this case,
+* DTYPE_A = 1.
+* CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating
+* the BLACS process grid A is distribu-
+* ted over. The context itself is glo-
+* bal, but the handle (the integer
+* value) may vary.
+* M_A (global) DESCA( M_ ) The number of rows in the global
+* array A.
+* N_A (global) DESCA( N_ ) The number of columns in the global
+* array A.
+* MB_A (global) DESCA( MB_ ) The blocking factor used to distribute
+* the rows of the array.
+* NB_A (global) DESCA( NB_ ) The blocking factor used to distribute
+* the columns of the array.
+* RSRC_A (global) DESCA( RSRC_ ) The process row over which the first
+* row of the array A is distributed.
+* CSRC_A (global) DESCA( CSRC_ ) The process column over which the
+* first column of the array A is
+* distributed.
+* LLD_A (local) DESCA( LLD_ ) The leading dimension of the local
+* array. LLD_A >= MAX(1,LOCr(M_A)).
+*
+* Let K be the number of rows or columns of a distributed matrix,
+* and assume that its process grid has dimension p x q.
+* LOCr( K ) denotes the number of elements of K that a process
+* would receive if K were distributed over the p processes of its
+* process column.
+* Similarly, LOCc( K ) denotes the number of elements of K that a
+* process would receive if K were distributed over the q processes of
+* its process row.
+* The values of LOCr() and LOCc() may be determined via a call to the
+* ScaLAPACK tool function, NUMROC:
+* LOCr( M ) = NUMROC( M, MB_A, MYROW, RSRC_A, NPROW ),
+* LOCc( N ) = NUMROC( N, NB_A, MYCOL, CSRC_A, NPCOL ).
+* An upper bound for these quantities may be computed by:
+* LOCr( M ) <= ceil( ceil(M/MB_A)/NPROW )*MB_A
+* LOCc( N ) <= ceil( ceil(N/NB_A)/NPCOL )*NB_A
+*
+* Arguments
+* =========
+*
+* JOB (global input) CHARACTER*1
+* = 'E': compute eigenvalues only;
+* = 'S': compute eigenvalues and the Schur form T.
+*
+* COMPZ (global input) CHARACTER*1
+* = 'N': no Schur vectors are computed;
+* = 'I': Z is initialized to the unit matrix and the matrix Z
+* of Schur vectors of H is returned;
+* = 'V': Z must contain an orthogonal matrix Q on entry, and
+* the product Q*Z is returned.
+*
+* N (global input) INTEGER
+* The order of the Hessenberg matrix H (and Z if WANTZ).
+* N >= 0.
+*
+* ILO (global input) INTEGER
+* IHI (global input) INTEGER
+* It is assumed that H is already upper triangular in rows
+* and columns 1:ILO-1 and IHI+1:N. ILO and IHI are normally
+* set by a previous call to PSGEBAL, and then passed to PSGEHRD
+* when the matrix output by PSGEBAL is reduced to Hessenberg
+* form. Otherwise ILO and IHI should be set to 1 and N
+* respectively. If N.GT.0, then 1.LE.ILO.LE.IHI.LE.N.
+* If N = 0, then ILO = 1 and IHI = 0.
+*
+* H (global input/output) REAL array, dimension
+* (DESCH(LLD_),*)
+* On entry, the upper Hessenberg matrix H.
+* On exit, if JOB = 'S', H is upper quasi-triangular in
+* rows and columns ILO:IHI, with 1-by-1 and 2-by-2 blocks on
+* the main diagonal. The 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.
+*
+* DESCH (global and local input) INTEGER array of dimension DLEN_.
+* The array descriptor for the distributed matrix H.
+*
+* WR (global output) REAL array, dimension (N)
+* WI (global output) REAL array, dimension (N)
+* The real and imaginary parts, respectively, of the computed
+* eigenvalues ILO to IHI are stored in the corresponding
+* elements of WR and WI. If two eigenvalues are computed as a
+* complex conjugate pair, they are stored in consecutive
+* elements of WR and WI, say the i-th and (i+1)th, with
+* WI(i) > 0 and WI(i+1) < 0. If JOB = 'S', the
+* eigenvalues are stored in the same order as on the diagonal
+* of the Schur form returned in H.
+*
+* Z (global input/output) REAL array.
+* If COMPZ = 'V', on entry Z must contain the current
+* matrix Z of accumulated transformations from, e.g., PSGEHRD,
+* and on exit Z has been updated; transformations are applied
+* only to the submatrix Z(ILO:IHI,ILO:IHI).
+* 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.
+*
+* DESCZ (global and local input) INTEGER array of dimension DLEN_.
+* The array descriptor for the distributed matrix Z.
+*
+* WORK (local workspace) REAL array, dimension(LWORK)
+*
+* LWORK (local input) INTEGER
+* The length of the workspace array WORK.
+*
+* IWORK (local workspace) INTEGER array, dimension (LIWORK)
+*
+* LIWORK (local input) INTEGER
+* The length of the workspace array IWORK.
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* .LT. 0: if INFO = -i, the i-th argument had an illegal
+* value (see also below for -7777 and -8888).
+* .GT. 0: if INFO = i, PSHSEQR 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.
+*
+* = -7777: PSLAQR0 failed to converge and PSLAQR1 was called
+* instead. This could happen. Mostly due to a bug.
+* Please, send a bug report to the authors.
+* = -8888: PSLAQR1 failed to converge and PSLAQR0 was called
+* instead. This should not happen.
+*
+* ================================================================
+* Based on contributions by
+* Robert Granat, Department of Computing Science and HPC2N,
+* Umea University, Sweden.
+* ================================================================
+*
+* Restrictions: The block size in H and Z must be square and larger
+* than or equal to six (6) due to restrictions in PSLAQR1, PSLAQR5
+* and SLAQR6. Moreover, H and Z need to be distributed identically
+* with the same context.
+*
+* ================================================================
+* References:
+* K. Braman, R. Byers, and R. Mathias,
+* The Multi-Shift QR Algorithm Part I: Maintaining Well Focused
+* Shifts, and Level 3 Performance.
+* SIAM J. Matrix Anal. Appl., 23(4):929--947, 2002.
+*
+* K. Braman, R. Byers, and R. Mathias,
+* The Multi-Shift QR Algorithm Part II: Aggressive Early
+* Deflation.
+* SIAM J. Matrix Anal. Appl., 23(4):948--973, 2002.
+*
+* R. Granat, B. Kagstrom, and D. Kressner,
+* A Novel Parallel QR Algorithm for Hybrid Distributed Momory HPC
+* Systems.
+* SIAM J. Sci. Comput., 32(4):2345--2378, 2010.
+*
+* ================================================================
+* .. Parameters ..
+ INTEGER BLOCK_CYCLIC_2D, CSRC_, CTXT_, DLEN_, DTYPE_,
+ $ LLD_, MB_, M_, NB_, N_, RSRC_
+ LOGICAL CRSOVER
+ PARAMETER ( BLOCK_CYCLIC_2D = 1, DLEN_ = 9, DTYPE_ = 1,
+ $ CTXT_ = 2, M_ = 3, N_ = 4, MB_ = 5, NB_ = 6,
+ $ RSRC_ = 7, CSRC_ = 8, LLD_ = 9,
+ $ CRSOVER = .TRUE. )
+ INTEGER NTINY
+ PARAMETER ( NTINY = 11 )
+ INTEGER NL
+ PARAMETER ( NL = 49 )
+ REAL ZERO, ONE
+ PARAMETER ( ZERO = 0.0e0, ONE = 1.0e0 )
+* ..
+* .. Local Scalars ..
+ INTEGER I, KBOT, NMIN, LLDH, LLDZ, ICTXT, NPROW, NPCOL,
+ $ MYROW, MYCOL, HROWS, HCOLS, IPW, NH, NB,
+ $ II, JJ, HRSRC, HCSRC, NPROCS, ILOC1, JLOC1,
+ $ HRSRC1, HCSRC1, K, ILOC2, JLOC2, ILOC3, JLOC3,
+ $ ILOC4, JLOC4, HRSRC2, HCSRC2, HRSRC3, HCSRC3,
+ $ HRSRC4, HCSRC4, LIWKOPT
+ LOGICAL INITZ, LQUERY, WANTT, WANTZ, PAIR, BORDER
+ REAL TMP1, TMP2, TMP3, TMP4, DUM1, DUM2, DUM3,
+ $ DUM4, ELEM1, ELEM2, ELEM3, ELEM4,
+ $ CS, SN, ELEM5, TMP, LWKOPT
+* ..
+* .. Local Arrays ..
+ INTEGER DESCH2( DLEN_ )
+* ..
+* .. External Functions ..
+ INTEGER PILAENVX, NUMROC, ICEIL
+ LOGICAL LSAME
+ EXTERNAL PILAENVX, LSAME, NUMROC, ICEIL
+* ..
+* .. External Subroutines ..
+ EXTERNAL PSLACPY, PSLAQR1, PSLAQR0, PSLASET, PXERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC FLOAT, MAX, MIN
+* ..
+* .. Executable Statements ..
+*
+* Decode and check the input parameters.
+*
+ INFO = 0
+ ICTXT = DESCH( CTXT_ )
+ CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL )
+ NPROCS = NPROW*NPCOL
+ IF( NPROW.EQ.-1 ) INFO = -(600+CTXT_)
+ IF( INFO.EQ.0 ) THEN
+ WANTT = LSAME( JOB, 'S' )
+ INITZ = LSAME( COMPZ, 'I' )
+ WANTZ = INITZ .OR. LSAME( COMPZ, 'V' )
+ LLDH = DESCH( LLD_ )
+ LLDZ = DESCZ( LLD_ )
+ NB = DESCH( MB_ )
+ LQUERY = ( LWORK.EQ.-1 .OR. LIWORK.EQ.-1 )
+*
+ 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
+ ELSEIF( DESCZ( CTXT_ ).NE.DESCH( CTXT_ ) ) THEN
+ INFO = -( 1000+CTXT_ )
+ ELSEIF( DESCH( MB_ ).NE.DESCH( NB_ ) ) THEN
+ INFO = -( 700+NB_ )
+ ELSEIF( DESCZ( MB_ ).NE.DESCZ( NB_ ) ) THEN
+ INFO = -( 1000+NB_ )
+ ELSEIF( DESCH( MB_ ).NE.DESCZ( MB_ ) ) THEN
+ INFO = -( 1000+MB_ )
+ ELSEIF( DESCH( MB_ ).LT.6 ) THEN
+ INFO = -( 700+NB_ )
+ ELSEIF( DESCZ( MB_ ).LT.6 ) THEN
+ INFO = -( 1000+MB_ )
+ ELSE
+ CALL CHK1MAT( N, 3, N, 3, 1, 1, DESCH, 7, INFO )
+ IF( INFO.EQ.0 )
+ $ CALL CHK1MAT( N, 3, N, 3, 1, 1, DESCZ, 11, INFO )
+ IF( INFO.EQ.0 )
+ $ CALL PCHK2MAT( N, 3, N, 3, 1, 1, DESCH, 7, N, 3, N, 3,
+ $ 1, 1, DESCZ, 11, 0, IWORK, IWORK, INFO )
+ END IF
+ END IF
+*
+* Compute required workspace.
+*
+ CALL PSLAQR1( WANTT, WANTZ, N, ILO, IHI, H, DESCH, WR, WI,
+ $ ILO, IHI, Z, DESCZ, WORK, -1, IWORK, -1, INFO )
+ LWKOPT = WORK(1)
+ LIWKOPT = IWORK(1)
+ CALL PSLAQR0( WANTT, WANTZ, N, ILO, IHI, H, DESCH, WR, WI,
+ $ ILO, IHI, Z, DESCZ, WORK, -1, IWORK, -1, INFO, 0 )
+ IF( N.LT.NL ) THEN
+ HROWS = NUMROC( NL, NB, MYROW, DESCH(RSRC_), NPROW )
+ HCOLS = NUMROC( NL, NB, MYCOL, DESCH(CSRC_), NPCOL )
+ WORK(1) = WORK(1) + FLOAT(2*HROWS*HCOLS)
+ END IF
+ LWKOPT = MAX( LWKOPT, WORK(1) )
+ LIWKOPT = MAX( LIWKOPT, IWORK(1) )
+ WORK(1) = LWKOPT
+ IWORK(1) = LIWKOPT
+*
+ IF( .NOT.LQUERY .AND. LWORK.LT.INT(LWKOPT) ) THEN
+ INFO = -13
+ ELSEIF( .NOT.LQUERY .AND. LIWORK.LT.LIWKOPT ) THEN
+ INFO = -15
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+*
+* Quick return in case of invalid argument.
+*
+ CALL PXERBLA( 'PSHSEQR', -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.
+*
+ RETURN
+*
+ ELSE
+*
+* Copy eigenvalues isolated by PSGEBAL.
+*
+ DO 10 I = 1, ILO - 1
+ CALL INFOG2L( I, I, DESCH, NPROW, NPCOL, MYROW, MYCOL, II,
+ $ JJ, HRSRC, HCSRC )
+ IF( MYROW.EQ.HRSRC .AND. MYCOL.EQ.HCSRC ) THEN
+ WR( I ) = H( (JJ-1)*LLDH + II )
+ ELSE
+ WR( I ) = ZERO
+ END IF
+ WI( I ) = ZERO
+ 10 CONTINUE
+ IF( ILO.GT.1 )
+ $ CALL SGSUM2D( ICTXT, 'All', '1-Tree', ILO-1, 1, WR, N, -1,
+ $ -1 )
+ DO 20 I = IHI + 1, N
+ CALL INFOG2L( I, I, DESCH, NPROW, NPCOL, MYROW, MYCOL, II,
+ $ JJ, HRSRC, HCSRC )
+ IF( MYROW.EQ.HRSRC .AND. MYCOL.EQ.HCSRC ) THEN
+ WR( I ) = H( (JJ-1)*LLDH + II )
+ ELSE
+ WR( I ) = ZERO
+ END IF
+ WI( I ) = ZERO
+ 20 CONTINUE
+ IF( IHI.LT.N )
+ $ CALL SGSUM2D( ICTXT, 'All', '1-Tree', N-IHI, 1, WR(IHI+1),
+ $ N, -1, -1 )
+*
+* Initialize Z, if requested.
+*
+ IF( INITZ )
+ $ CALL PSLASET( 'A', N, N, ZERO, ONE, Z, 1, 1, DESCZ )
+*
+* Quick return if possible.
+*
+ NPROCS = NPROW*NPCOL
+ IF( ILO.EQ.IHI ) THEN
+ CALL INFOG2L( ILO, ILO, DESCH, NPROW, NPCOL, MYROW,
+ $ MYCOL, II, JJ, HRSRC, HCSRC )
+ IF( MYROW.EQ.HRSRC .AND. MYCOL.EQ.HCSRC ) THEN
+ WR( ILO ) = H( (JJ-1)*LLDH + II )
+ IF( NPROCS.GT.1 )
+ $ CALL SGEBS2D( ICTXT, 'All', '1-Tree', 1, 1, WR(ILO),
+ $ 1 )
+ ELSE
+ CALL SGEBR2D( ICTXT, 'All', '1-Tree', 1, 1, WR(ILO),
+ $ 1, HRSRC, HCSRC )
+ END IF
+ WI( ILO ) = ZERO
+ RETURN
+ END IF
+*
+* PSLAQR1/PSLAQR0 crossover point.
+*
+ NH = IHI-ILO+1
+ NMIN = PILAENVX( ICTXT, 12, 'PSHSEQR',
+ $ JOB( : 1 ) // COMPZ( : 1 ), N, ILO, IHI, LWORK )
+ NMIN = MAX( NTINY, NMIN )
+*
+* PSLAQR0 for big matrices; PSLAQR1 for small ones.
+*
+ IF( (.NOT. CRSOVER .AND. NH.GT.NTINY) .OR. NH.GT.NMIN .OR.
+ $ DESCH(RSRC_).NE.0 .OR. DESCH(CSRC_).NE.0 ) THEN
+ CALL PSLAQR0( WANTT, WANTZ, N, ILO, IHI, H, DESCH, WR, WI,
+ $ ILO, IHI, Z, DESCZ, WORK, LWORK, IWORK, LIWORK, INFO,
+ $ 0 )
+ IF( INFO.GT.0 .AND. ( DESCH(RSRC_).NE.0 .OR.
+ $ DESCH(CSRC_).NE.0 ) ) THEN
+*
+* A rare PSLAQR0 failure! PSLAQR1 sometimes succeeds
+* when PSLAQR0 fails.
+*
+ KBOT = INFO
+ CALL PSLAQR1( WANTT, WANTZ, N, ILO, IHI, H, DESCH, WR,
+ $ WI, ILO, IHI, Z, DESCZ, WORK, LWORK, IWORK,
+ $ LIWORK, INFO )
+ INFO = -7777
+ END IF
+ ELSE
+*
+* Small matrix.
+*
+ CALL PSLAQR1( WANTT, WANTZ, N, ILO, IHI, H, DESCH, WR, WI,
+ $ ILO, IHI, Z, DESCZ, WORK, LWORK, IWORK, LIWORK, INFO )
+*
+ IF( INFO.GT.0 ) THEN
+*
+* A rare PSLAQR1 failure! PSLAQR0 sometimes succeeds
+* when PSLAQR1 fails.
+*
+ KBOT = INFO
+*
+ IF( N.GE.NL ) THEN
+*
+* Larger matrices have enough subdiagonal scratch
+* space to call PSLAQR0 directly.
+*
+ CALL PSLAQR0( WANTT, WANTZ, N, ILO, KBOT, H, DESCH,
+ $ WR, WI, ILO, IHI, Z, DESCZ, WORK, LWORK,
+ $ IWORK, LIWORK, INFO, 0 )
+ ELSE
+*
+* Tiny matrices don't have enough subdiagonal
+* scratch space to benefit from PSLAQR0. Hence,
+* tiny matrices must be copied into a larger
+* array before calling PSLAQR0.
+*
+ HROWS = NUMROC( NL, NB, MYROW, DESCH(RSRC_), NPROW )
+ HCOLS = NUMROC( NL, NB, MYCOL, DESCH(CSRC_), NPCOL )
+ CALL DESCINIT( DESCH2, NL, NL, NB, NB, DESCH(RSRC_),
+ $ DESCH(CSRC_), ICTXT, MAX(1, HROWS), INFO )
+ CALL PSLACPY( 'All', N, N, H, 1, 1, DESCH, WORK, 1,
+ $ 1, DESCH2 )
+ CALL PSELSET( WORK, N+1, N, DESCH2, ZERO )
+ CALL PSLASET( 'All', NL, NL-N, ZERO, ZERO, WORK, 1,
+ $ N+1, DESCH2 )
+ IPW = 1 + DESCH2(LLD_)*HCOLS
+ CALL PSLAQR0( WANTT, WANTZ, NL, ILO, KBOT, WORK,
+ $ DESCH2, WR, WI, ILO, IHI, Z, DESCZ,
+ $ WORK(IPW), LWORK-IPW+1, IWORK,
+ $ LIWORK, INFO, 0 )
+ IF( WANTT .OR. INFO.NE.0 )
+ $ CALL PSLACPY( 'All', N, N, WORK, 1, 1, DESCH2,
+ $ H, 1, 1, DESCH )
+ END IF
+ INFO = -8888
+ END IF
+ END IF
+*
+* Clear out the trash, if necessary.
+*
+ IF( ( WANTT .OR. INFO.NE.0 ) .AND. N.GT.2 )
+ $ CALL PSLASET( 'L', N-2, N-2, ZERO, ZERO, H, 3, 1, DESCH )
+*
+* Force any 2-by-2 blocks to be complex conjugate pairs of
+* eigenvalues by removing false such blocks.
+*
+ DO 30 I = ILO, IHI-1
+ CALL PSELGET( 'All', ' ', TMP3, H, I+1, I, DESCH )
+ IF( TMP3.NE.0.0E+00 ) THEN
+ CALL PSELGET( 'All', ' ', TMP1, H, I, I, DESCH )
+ CALL PSELGET( 'All', ' ', TMP2, H, I, I+1, DESCH )
+ CALL PSELGET( 'All', ' ', TMP4, H, I+1, I+1, DESCH )
+ CALL SLANV2( TMP1, TMP2, TMP3, TMP4, DUM1, DUM2, DUM3,
+ $ DUM4, CS, SN )
+ IF( TMP3.EQ.0.0E+00 ) THEN
+ IF( WANTT ) THEN
+ IF( I+2.LE.N )
+ $ CALL PSROT( N-I-1, H, I, I+2, DESCH,
+ $ DESCH(M_), H, I+1, I+2, DESCH, DESCH(M_),
+ $ CS, SN, WORK, LWORK, INFO )
+ CALL PSROT( I-1, H, 1, I, DESCH, 1, H, 1, I+1,
+ $ DESCH, 1, CS, SN, WORK, LWORK, INFO )
+ END IF
+ IF( WANTZ ) THEN
+ CALL PSROT( N, Z, 1, I, DESCZ, 1, Z, 1, I+1, DESCZ,
+ $ 1, CS, SN, WORK, LWORK, INFO )
+ END IF
+ CALL PSELSET( H, I, I, DESCH, TMP1 )
+ CALL PSELSET( H, I, I+1, DESCH, TMP2 )
+ CALL PSELSET( H, I+1, I, DESCH, TMP3 )
+ CALL PSELSET( H, I+1, I+1, DESCH, TMP4 )
+ END IF
+ END IF
+ 30 CONTINUE
+*
+* Read out eigenvalues: first let all the processes compute the
+* eigenvalue inside their diagonal blocks in parallel, except for
+* the eigenvalue located next to a block border. After that,
+* compute all eigenvalues located next to the block borders.
+* Finally, do a global summation over WR and WI so that all
+* processors receive the result.
+*
+ DO 40 K = ILO, IHI
+ WR( K ) = ZERO
+ WI( K ) = ZERO
+ 40 CONTINUE
+ NB = DESCH( MB_ )
+*
+* Loop 50: extract eigenvalues from the blocks which are not laid
+* out across a border of the processor mesh, except for those 1x1
+* blocks on the border.
+*
+ PAIR = .FALSE.
+ DO 50 K = ILO, IHI
+ IF( .NOT. PAIR ) THEN
+ BORDER = MOD( K, NB ).EQ.0 .OR. ( K.NE.1 .AND.
+ $ MOD( K, NB ).EQ.1 )
+ IF( .NOT. BORDER ) THEN
+ CALL INFOG2L( K, K, DESCH, NPROW, NPCOL, MYROW,
+ $ MYCOL, ILOC1, JLOC1, HRSRC1, HCSRC1 )
+ IF( MYROW.EQ.HRSRC1 .AND. MYCOL.EQ.HCSRC1 ) THEN
+ ELEM1 = H((JLOC1-1)*LLDH+ILOC1)
+ IF( K.LT.N ) THEN
+ ELEM3 = H((JLOC1-1)*LLDH+ILOC1+1)
+ ELSE
+ ELEM3 = ZERO
+ END IF
+ IF( ELEM3.NE.ZERO ) THEN
+ ELEM2 = H((JLOC1)*LLDH+ILOC1)
+ ELEM4 = H((JLOC1)*LLDH+ILOC1+1)
+ CALL SLANV2( ELEM1, ELEM2, ELEM3, ELEM4,
+ $ WR( K ), WI( K ), WR( K+1 ), WI( K+1 ),
+ $ SN, CS )
+ PAIR = .TRUE.
+ ELSE
+ IF( K.GT.1 ) THEN
+ TMP = H((JLOC1-2)*LLDH+ILOC1)
+ IF( TMP.NE.ZERO ) THEN
+ ELEM1 = H((JLOC1-2)*LLDH+ILOC1-1)
+ ELEM2 = H((JLOC1-1)*LLDH+ILOC1-1)
+ ELEM3 = H((JLOC1-2)*LLDH+ILOC1)
+ ELEM4 = H((JLOC1-1)*LLDH+ILOC1)
+ CALL SLANV2( ELEM1, ELEM2, ELEM3,
+ $ ELEM4, WR( K-1 ), WI( K-1 ),
+ $ WR( K ), WI( K ), SN, CS )
+ ELSE
+ WR( K ) = ELEM1
+ END IF
+ ELSE
+ WR( K ) = ELEM1
+ END IF
+ END IF
+ END IF
+ END IF
+ ELSE
+ PAIR = .FALSE.
+ END IF
+ 50 CONTINUE
+*
+* Loop 60: extract eigenvalues from the blocks which are laid
+* out across a border of the processor mesh. The processors are
+* numbered as below:
+*
+* 1 | 2
+* --+--
+* 3 | 4
+*
+ DO 60 K = ICEIL(ILO,NB)*NB, IHI-1, NB
+ CALL INFOG2L( K, K, DESCH, NPROW, NPCOL, MYROW, MYCOL,
+ $ ILOC1, JLOC1, HRSRC1, HCSRC1 )
+ CALL INFOG2L( K, K+1, DESCH, NPROW, NPCOL, MYROW, MYCOL,
+ $ ILOC2, JLOC2, HRSRC2, HCSRC2 )
+ CALL INFOG2L( K+1, K, DESCH, NPROW, NPCOL, MYROW, MYCOL,
+ $ ILOC3, JLOC3, HRSRC3, HCSRC3 )
+ CALL INFOG2L( K+1, K+1, DESCH, NPROW, NPCOL, MYROW, MYCOL,
+ $ ILOC4, JLOC4, HRSRC4, HCSRC4 )
+ IF( MYROW.EQ.HRSRC2 .AND. MYCOL.EQ.HCSRC2 ) THEN
+ ELEM2 = H((JLOC2-1)*LLDH+ILOC2)
+ IF( HRSRC1.NE.HRSRC2 .OR. HCSRC1.NE.HCSRC2 )
+ $ CALL SGESD2D( ICTXT, 1, 1, ELEM2, 1, HRSRC1, HCSRC1)
+ END IF
+ IF( MYROW.EQ.HRSRC3 .AND. MYCOL.EQ.HCSRC3 ) THEN
+ ELEM3 = H((JLOC3-1)*LLDH+ILOC3)
+ IF( HRSRC1.NE.HRSRC3 .OR. HCSRC1.NE.HCSRC3 )
+ $ CALL SGESD2D( ICTXT, 1, 1, ELEM3, 1, HRSRC1, HCSRC1)
+ END IF
+ IF( MYROW.EQ.HRSRC4 .AND. MYCOL.EQ.HCSRC4 ) THEN
+ WORK(1) = H((JLOC4-1)*LLDH+ILOC4)
+ IF( K+1.LT.N ) THEN
+ WORK(2) = H((JLOC4-1)*LLDH+ILOC4+1)
+ ELSE
+ WORK(2) = ZERO
+ END IF
+ IF( HRSRC1.NE.HRSRC4 .OR. HCSRC1.NE.HCSRC4 )
+ $ CALL SGESD2D( ICTXT, 2, 1, WORK, 2, HRSRC1, HCSRC1 )
+ END IF
+ IF( MYROW.EQ.HRSRC1 .AND. MYCOL.EQ.HCSRC1 ) THEN
+ ELEM1 = H((JLOC1-1)*LLDH+ILOC1)
+ IF( HRSRC1.NE.HRSRC2 .OR. HCSRC1.NE.HCSRC2 )
+ $ CALL SGERV2D( ICTXT, 1, 1, ELEM2, 1, HRSRC2, HCSRC2)
+ IF( HRSRC1.NE.HRSRC3 .OR. HCSRC1.NE.HCSRC3 )
+ $ CALL SGERV2D( ICTXT, 1, 1, ELEM3, 1, HRSRC3, HCSRC3)
+ IF( HRSRC1.NE.HRSRC4 .OR. HCSRC1.NE.HCSRC4 )
+ $ CALL SGERV2D( ICTXT, 2, 1, WORK, 2, HRSRC4, HCSRC4 )
+ ELEM4 = WORK(1)
+ ELEM5 = WORK(2)
+ IF( ELEM5.EQ.ZERO ) THEN
+ IF( WR( K ).EQ.ZERO .AND. WI( K ).EQ.ZERO ) THEN
+ CALL SLANV2( ELEM1, ELEM2, ELEM3, ELEM4, WR( K ),
+ $ WI( K ), WR( K+1 ), WI( K+1 ), SN, CS )
+ ELSEIF( WR( K+1 ).EQ.ZERO .AND. WI( K+1 ).EQ.ZERO )
+ $ THEN
+ WR( K+1 ) = ELEM4
+ END IF
+ ELSEIF( WR( K ).EQ.ZERO .AND. WI( K ).EQ.ZERO )
+ $ THEN
+ WR( K ) = ELEM1
+ END IF
+ END IF
+ 60 CONTINUE
+*
+ IF( NPROCS.GT.1 ) THEN
+ CALL SGSUM2D( ICTXT, 'All', ' ', IHI-ILO+1, 1, WR(ILO), N,
+ $ -1, -1 )
+ CALL SGSUM2D( ICTXT, 'All', ' ', IHI-ILO+1, 1, WI(ILO), N,
+ $ -1, -1 )
+ END IF
+*
+ END IF
+*
+ WORK(1) = LWKOPT
+ IWORK(1) = LIWKOPT
+ RETURN
+*
+* End of PSHSEQR
+*
+ END
diff --git a/SRC/pslabad.f b/SRC/pslabad.f
index 51b559a..31e6d01 100644
--- a/SRC/pslabad.f
+++ b/SRC/pslabad.f
@@ -62,6 +62,7 @@
SMALL = SQRT( SMALL )
LARGE = SQRT( LARGE )
END IF
+ IDUMM = 0
*
CALL SGAMX2D( ICTXT, 'All', ' ', 1, 1, SMALL, 1, IDUMM,
$ IDUMM, -1, -1, IDUMM )
diff --git a/SRC/pslacp2.f b/SRC/pslacp2.f
index ddddb2b..f30317a 100644
--- a/SRC/pslacp2.f
+++ b/SRC/pslacp2.f
@@ -1,10 +1,9 @@
SUBROUTINE PSLACP2( UPLO, M, N, A, IA, JA, DESCA, B, IB, JB,
$ DESCB )
*
-* -- ScaLAPACK auxiliary routine (version 1.7) --
-* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
-* and University of California, Berkeley.
-* November 15, 1997
+* -- ScaLAPACK auxiliary routine (version 2.0.2) --
+* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver
+* May 1 2012
*
* .. Scalar Arguments ..
CHARACTER UPLO
@@ -157,7 +156,7 @@
$ NQ, NQAA, WIDE
* ..
* .. External Subroutines ..
- EXTERNAL BLACS_GRIDINFO, INFOG2L, SLACPY
+ EXTERNAL BLACS_GRIDINFO, INFOG2L, SLAMOV
* ..
* .. External Functions ..
LOGICAL LSAME
@@ -247,7 +246,7 @@
*
10 CONTINUE
IF( ( N-ITOP ).GT.0 ) THEN
- CALL SLACPY( UPLO, IINXTA-IIBEGA+1, N-ITOP,
+ CALL SLAMOV( UPLO, IINXTA-IIBEGA+1, N-ITOP,
$ A( IIBEGA+(JJA+ITOP-1)*LDA ), LDA,
$ B( IIBEGB+(JJB+ITOP-1)*LDB ), LDB )
MYDIST = MYDIST + NPROW
@@ -272,10 +271,10 @@
20 CONTINUE
IF( JJAA.LE.( JJA+N-1 ) ) THEN
HEIGHT = IBASE - ITOP
- CALL SLACPY( 'All', MPAA, ITOP-JJAA+JJA,
+ CALL SLAMOV( 'All', MPAA, ITOP-JJAA+JJA,
$ A( IIAA+(JJAA-1)*LDA ), LDA,
$ B( IIBB+(JJBB-1)*LDB ), LDB )
- CALL SLACPY( UPLO, MPAA, HEIGHT,
+ CALL SLAMOV( UPLO, MPAA, HEIGHT,
$ A( IIAA+(JJA+ITOP-1)*LDA ), LDA,
$ B( IIBB+(JJB+ITOP-1)*LDB ), LDB )
MPAA = MAX( 0, MPAA - HEIGHT )
@@ -292,7 +291,7 @@
*
ELSE
*
- CALL SLACPY( 'All', MP, N, A( IIA+(JJA-1)*LDA ),
+ CALL SLAMOV( 'All', MP, N, A( IIA+(JJA-1)*LDA ),
$ LDA, B( IIB+(JJB-1)*LDB ), LDB )
*
END IF
@@ -345,7 +344,7 @@
*
30 CONTINUE
IF( ( M-ILEFT ).GT.0 ) THEN
- CALL SLACPY( UPLO, M-ILEFT, JJNXTA-JJBEGA+1,
+ CALL SLAMOV( UPLO, M-ILEFT, JJNXTA-JJBEGA+1,
$ A( IIA+ILEFT+(JJBEGA-1)*LDA ), LDA,
$ B( IIB+ILEFT+(JJBEGB-1)*LDB ), LDB )
MYDIST = MYDIST + NPCOL
@@ -370,10 +369,10 @@
40 CONTINUE
IF( IIAA.LE.( IIA+M-1 ) ) THEN
WIDE = IRIGHT - ILEFT
- CALL SLACPY( 'All', ILEFT-IIAA+IIA, NQAA,
+ CALL SLAMOV( 'All', ILEFT-IIAA+IIA, NQAA,
$ A( IIAA+(JJAA-1)*LDA ), LDA,
$ B( IIBB+(JJBB-1)*LDB ), LDB )
- CALL SLACPY( UPLO, WIDE, NQAA,
+ CALL SLAMOV( UPLO, WIDE, NQAA,
$ A( IIA+ILEFT+(JJAA-1)*LDA ), LDA,
$ B( IIB+ILEFT+(JJBB-1)*LDB ), LDB )
NQAA = MAX( 0, NQAA - WIDE )
@@ -390,7 +389,7 @@
*
ELSE
*
- CALL SLACPY( 'All', M, NQ, A( IIA+(JJA-1)*LDA ),
+ CALL SLAMOV( 'All', M, NQ, A( IIA+(JJA-1)*LDA ),
$ LDA, B( IIB+(JJB-1)*LDB ), LDB )
*
END IF
diff --git a/SRC/pslacp3.f b/SRC/pslacp3.f
index efeb990..0207f84 100644
--- a/SRC/pslacp3.f
+++ b/SRC/pslacp3.f
@@ -1,9 +1,10 @@
SUBROUTINE PSLACP3( M, I, A, DESCA, B, LDB, II, JJ, REV )
+ IMPLICIT NONE
*
* -- ScaLAPACK routine (version 1.7) --
* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
* and University of California, Berkeley.
-* May 25, 2001
+* May 25, 2001
*
* .. Scalar Arguments ..
INTEGER I, II, JJ, LDB, M, REV
@@ -88,7 +89,7 @@
* A(I,I) is the global location that the copying starts from.
* Unchanged on exit.
*
-* A (global input/output) REAL array, dimension
+* A (global input/output) REAL array, dimension
* (DESCA(LLD_),*)
* On entry, the parallel matrix to be copied into or from.
* On exit, if REV=1, the copied data.
@@ -97,7 +98,7 @@
* DESCA (global and local input) INTEGER array of dimension DLEN_.
* The array descriptor for the distributed matrix A.
*
-* B (local input/output) REAL array of size (LDB,M)
+* B (local input/output) REAL array of size (LDB,M)
* If REV=0, this is the global portion of the array
* A(I:I+M-1,I:I+M-1).
* If REV=1, this is the unchanged on exit.
@@ -138,12 +139,13 @@
$ CTXT_ = 2, M_ = 3, N_ = 4, MB_ = 5, NB_ = 6,
$ RSRC_ = 7, CSRC_ = 8, LLD_ = 9 )
REAL ZERO
- PARAMETER ( ZERO = 0.0E+0 )
+ PARAMETER ( ZERO = 0.0 )
* ..
* .. Local Scalars ..
- INTEGER COL, CONTXT, HBL, ICOL1, ICOL2, IDI, IDJ, IFIN,
- $ III, IROW1, IROW2, ISTOP, ISTOPI, ISTOPJ, ITMP,
- $ JJJ, LDA, MYCOL, MYROW, NPCOL, NPROW, ROW
+ INTEGER COL, CONTXT, HBL, IAFIRST, ICOL1, ICOL2, IDI,
+ $ IDJ, IFIN, III, IROW1, IROW2, ISTOP, ISTOPI,
+ $ ISTOPJ, ITMP, JAFIRST, JJJ, LDA, MYCOL, MYROW,
+ $ NPCOL, NPROW, ROW
* ..
* .. External Functions ..
INTEGER NUMROC
@@ -164,6 +166,8 @@
HBL = DESCA( MB_ )
CONTXT = DESCA( CTXT_ )
LDA = DESCA( LLD_ )
+ IAFIRST = DESCA( RSRC_ )
+ JAFIRST = DESCA( CSRC_ )
*
CALL BLACS_GRIDINFO( CONTXT, NPROW, NPCOL, MYROW, MYCOL )
*
@@ -190,12 +194,12 @@
ISTOPI = ISTOP
IF( IDI.LE.IFIN ) THEN
40 CONTINUE
- ROW = MOD( ( IDI-1 ) / HBL, NPROW )
- COL = MOD( ( IDJ-1 ) / HBL, NPCOL )
- CALL INFOG1L( IDI, HBL, NPROW, ROW, 0, IROW1, ITMP )
- IROW2 = NUMROC( ISTOPI, HBL, ROW, 0, NPROW )
- CALL INFOG1L( IDJ, HBL, NPCOL, COL, 0, ICOL1, ITMP )
- ICOL2 = NUMROC( ISTOPJ, HBL, COL, 0, NPCOL )
+ ROW = MOD( ( IDI-1 ) / HBL + IAFIRST, NPROW )
+ COL = MOD( ( IDJ-1 ) / HBL + JAFIRST, NPCOL )
+ CALL INFOG1L( IDI, HBL, NPROW, ROW, IAFIRST, IROW1, ITMP )
+ IROW2 = NUMROC( ISTOPI, HBL, ROW, IAFIRST, NPROW )
+ CALL INFOG1L( IDJ, HBL, NPCOL, COL, JAFIRST, ICOL1, ITMP )
+ ICOL2 = NUMROC( ISTOPJ, HBL, COL, JAFIRST, NPCOL )
IF( ( MYROW.EQ.ROW ) .AND. ( MYCOL.EQ.COL ) ) THEN
IF( ( II.EQ.-1 ) .AND. ( JJ.EQ.-1 ) ) THEN
*
@@ -287,6 +291,8 @@
CALL SGESD2D( CONTXT, IROW2-IROW1+1, ICOL2-ICOL1+1,
$ B( IDI-I+1, IDJ-I+1 ), LDB, ROW,
$ COL )
+* CALL SGESD2D(CONTXT, IROW2-IROW1+1, ICOL2-ICOL1+1,
+* $ A((ICOL1-1)*LDA+IROW1),LDA, ROW, COL)
END IF
END IF
END IF
diff --git a/SRC/pslahqr.f b/SRC/pslahqr.f
index c3c9f1b..0753f51 100644
--- a/SRC/pslahqr.f
+++ b/SRC/pslahqr.f
@@ -2,13 +2,9 @@
$ ILOZ, IHIZ, Z, DESCZ, WORK, LWORK, IWORK,
$ ILWORK, INFO )
*
-* -- ScaLAPACK routine (version 1.7.3) --
-* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
-* and University of California, Berkeley.
-* 1.7.3: March 22, 2006
-* modification suggested by Mark Fahey and Greg Henry
-* 1.7.1: January 30, 2006
-* 1.7.0: December 31, 1998
+* -- ScaLAPACK routine (version 2.0.2) --
+* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver
+* May 1 2012
*
* .. Scalar Arguments ..
LOGICAL WANTT, WANTZ
@@ -239,9 +235,9 @@
$ CTXT_ = 2, M_ = 3, N_ = 4, MB_ = 5, NB_ = 6,
$ RSRC_ = 7, CSRC_ = 8, LLD_ = 9 )
REAL ZERO, ONE, HALF
- PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0, HALF = 0.5E+0 )
+ PARAMETER ( ZERO = 0.0, ONE = 1.0, HALF = 0.5 )
REAL CONST
- PARAMETER ( CONST = 1.50E+0 )
+ PARAMETER ( CONST = 1.50 )
INTEGER IBLK
PARAMETER ( IBLK = 32 )
* ..
@@ -259,7 +255,7 @@
REAL AVE, DISC, H00, H10, H11, H12, H21, H22, H33,
$ H43H34, H44, OVFL, S, SMLNUM, SUM, T1, T1COPY,
$ T2, T3, ULP, UNFL, V1SAVE, V2, V2SAVE, V3,
- $ V3SAVE
+ $ V3SAVE, CS, SN
* ..
* .. Local Arrays ..
INTEGER ICURCOL( IBLK ), ICURROW( IBLK ), K1( IBLK ),
@@ -274,11 +270,11 @@
EXTERNAL ILCM, NUMROC, PSLAMCH
* ..
* .. External Subroutines ..
- EXTERNAL BLACS_GRIDINFO, IGAMN2D, INFOG1L, INFOG2L,
- $ PSLABAD, PSLACONSB, PSLACP3, PSLASMSUB,
- $ PSLAWIL, PXERBLA, SCOPY, SGEBR2D, SGEBS2D,
+ EXTERNAL BLACS_GRIDINFO, SCOPY, SGEBR2D, SGEBS2D,
$ SGERV2D, SGESD2D, SGSUM2D, SLAHQR, SLAREF,
- $ SLARFG, SLASORTE
+ $ SLARFG, SLASORTE, IGAMN2D, INFOG1L, INFOG2L,
+ $ PSLABAD, PSLACONSB, PSLACP3, PSLASMSUB,
+ $ PSLAWIL, PXERBLA, SLANV2
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, MIN, MOD, SIGN, SQRT
@@ -523,14 +519,24 @@
* Look for two consecutive small subdiagonal elements:
* PSLACONSB is the routine that does this.
*
- CALL PSLACONSB( A, DESCA, I, L, M, H44, H33, H43H34,
- $ WORK( IRBUF+1 ), LWORK-IRBUF )
+c CALL PSLACONSB( A, DESCA, I, L, M, H44, H33, H43H34,
+c $ WORK( IRBUF+1 ), LWORK-IRBUF )
*
* Skip small submatrices
*
* IF ( M .GE. I - 5 )
* $ GO TO 80
*
+* In principle PSLACONSB needs to check all shifts to decide
+* whether two consecutive small subdiagonal entries are suitable
+* as the starting position of the bulge chasing phase. It can be
+* dangerous to check the first pair of shifts only. Moreover it
+* is quite rare to obtain an M which is much larger than L. This
+* process is a bit expensive compared with the benefit.
+* Therefore it is sensible to abandon this routine. Total amount
+* of communications is saved in average.
+*
+ M = L
* Double-shift QR step
*
* NBULGE is the number of bulges that will be attempted
@@ -2016,79 +2022,18 @@
*
* H(I-1,I-2) is negligible: a pair of eigenvalues have converged.
*
- WR( I-1 ) = ZERO
- WR( I ) = ZERO
- WI( I-1 ) = ZERO
- WI( I ) = ZERO
- MODKM1 = MOD( I-1+HBL, HBL )
- CALL INFOG2L( I-1, I-1, DESCA, NPROW, NPCOL, MYROW, MYCOL,
- $ IROW1, ICOL1, II, JJ )
- IF( ( MYROW.EQ.II ) .AND. ( MYCOL.EQ.JJ ) ) THEN
- H11 = A( ( ICOL1-1 )*LDA+IROW1 )
- IF( MODKM1.NE.0 ) THEN
- H21 = A( ( ICOL1-1 )*LDA+IROW1+1 )
- H12 = A( ICOL1*LDA+IROW1 )
- H22 = A( ICOL1*LDA+IROW1+1 )
- ELSE
- IF( NPROW.GT.1 ) THEN
- CALL SGERV2D( CONTXT, 1, 1, H21, 1, DOWN, MYCOL )
- ELSE
- H21 = A( ( ICOL1-1 )*LDA+IROW1+1 )
- END IF
- IF( NPCOL.GT.1 ) THEN
- CALL SGERV2D( CONTXT, 1, 1, H12, 1, MYROW, RIGHT )
- ELSE
- H12 = A( ICOL1*LDA+IROW1 )
- END IF
- IF( NUM.GT.1 ) THEN
- CALL SGERV2D( CONTXT, 1, 1, H22, 1, DOWN, RIGHT )
- ELSE
- H22 = A( ICOL1*LDA+IROW1+1 )
- END IF
- END IF
- H00 = HALF*( H11+H22 )
- H10 = H11*H22 - H12*H21
- ELSE
- IF( MODKM1.EQ.0 ) THEN
- IF( ( NPROW.GT.1 ) .AND. ( MYCOL.EQ.JJ ) .AND.
- $ ( UP.EQ.II ) ) THEN
- CALL INFOG2L( I, I-1, DESCA, NPROW, NPCOL, MYROW,
- $ MYCOL, IROW1, ICOL1, ITMP1, ITMP2 )
- CALL SGESD2D( CONTXT, 1, 1,
- $ A( ( ICOL1-1 )*LDA+IROW1 ), 1, II, JJ )
- END IF
- IF( ( NPCOL.GT.1 ) .AND. ( LEFT.EQ.JJ ) .AND.
- $ ( MYROW.EQ.II ) ) THEN
- CALL INFOG2L( I-1, I, DESCA, NPROW, NPCOL, MYROW,
- $ MYCOL, IROW1, ICOL1, ITMP1, ITMP2 )
- CALL SGESD2D( CONTXT, 1, 1,
- $ A( ( ICOL1-1 )*LDA+IROW1 ), 1, II, JJ )
- END IF
- IF( ( NUM.GT.1 ) .AND. ( LEFT.EQ.JJ ) .AND.
- $ ( UP.EQ.II ) ) THEN
- CALL INFOG2L( I, I, DESCA, NPROW, NPCOL, MYROW, MYCOL,
- $ IROW1, ICOL1, ITMP1, ITMP2 )
- CALL SGESD2D( CONTXT, 1, 1,
- $ A( ( ICOL1-1 )*LDA+IROW1 ), 1, II, JJ )
- END IF
- END IF
- H00 = ZERO
- H10 = ZERO
- END IF
- H21 = H00*H00 - H10
- IF( H21.GE.ZERO ) THEN
- H21 = SQRT( H21 )
- WR( I-1 ) = H00 + H21
- WI( I-1 ) = ZERO
- WR( I ) = H00 - H21
+ CALL PSELGET( 'All', ' ', H11, A, L, L, DESCA )
+ CALL PSELGET( 'All', ' ', H21, A, I, L, DESCA )
+ CALL PSELGET( 'All', ' ', H12, A, L, I, DESCA )
+ CALL PSELGET( 'All', ' ', H22, A, I, I, DESCA )
+ CALL SLANV2( H11, H12, H21, H22, WR( L ), WI( L ), WR( I ),
+ $ WI( I ), CS, SN )
+ IF( NODE .NE. 0 ) THEN
+ WR( L ) = ZERO
+ WR( I ) = ZERO
+ WI( L ) = ZERO
WI( I ) = ZERO
- ELSE
- H21 = SQRT( ABS( H21 ) )
- WR( I-1 ) = H00
- WI( I-1 ) = H21
- WR( I ) = H00
- WI( I ) = -H21
- END IF
+ ENDIF
ELSE
*
* Find the eigenvalues in H(L:I,L:I), L < I-1
diff --git a/SRC/pslaiect.c b/SRC/pslaiect.c
index e3f6004..5978c7a 100644
--- a/SRC/pslaiect.c
+++ b/SRC/pslaiect.c
@@ -19,11 +19,7 @@
#define proto(x) ()
-void pslasnbt_( ieflag )
-/*
-* .. Scalar Arguments ..
-*/
- int *ieflag;
+void pslasnbt_( int *ieflag )
{
/*
*
@@ -80,12 +76,7 @@ void pslasnbt_( ieflag )
#endif
}
-void pslaiect_( sigma, n, d, count )
-/*
-* .. Scalar Arguments ..
-*/
- float *sigma, *d;
- int *n, *count;
+void pslaiect_( float *sigma, int *n, float *d, int *count )
{
/*
*
@@ -150,12 +141,7 @@ void pslaiect_( sigma, n, d, count )
}
}
-pslachkieee_( isieee, rmax, rmin )
-/*
-* .. Scalar Arguments ..
-*/
- float *rmax, *rmin;
- int *isieee;
+void pslachkieee_( int *isieee, float *rmax, float *rmin )
{
/*
*
diff --git a/SRC/pslamch.f b/SRC/pslamch.f
index db7ea67..cddd765 100644
--- a/SRC/pslamch.f
+++ b/SRC/pslamch.f
@@ -65,6 +65,7 @@
* .. Executable Statements ..
*
TEMP = SLAMCH( CMACH )
+ IDUMM = 0
*
IF( LSAME( CMACH, 'E' ).OR.LSAME( CMACH, 'S' ).OR.
$ LSAME( CMACH, 'M' ).OR.LSAME( CMACH, 'U' ) ) THEN
diff --git a/SRC/pslamve.f b/SRC/pslamve.f
new file mode 100644
index 0000000..11247cd
--- /dev/null
+++ b/SRC/pslamve.f
@@ -0,0 +1,205 @@
+ SUBROUTINE PSLAMVE( UPLO, M, N, A, IA, JA, DESCA, B, IB, JB,
+ $ DESCB, DWORK )
+*
+* Contribution from the Department of Computing Science and HPC2N,
+* Umea University, Sweden
+*
+* -- ScaLAPACK auxiliary routine (version 2.0.2) --
+* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver
+* May 1 2012
+*
+ IMPLICIT NONE
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER IA, IB, JA, JB, M, N
+* ..
+* .. Array Arguments ..
+ INTEGER DESCA( * ), DESCB( * )
+ REAL A( * ), B( * ), DWORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* PSLAMVE copies all or part of a distributed matrix A to another
+* distributed matrix B. There is no alignment assumptions at all
+* except that A and B are of the same size.
+*
+* Notes
+* =====
+*
+* Each global data object is described by an associated description
+* vector. This vector stores the information required to establish
+* the mapping between an object element and its corresponding process
+* and memory location.
+*
+* Let A be a generic term for any 2D block cyclicly distributed array.
+* Such a global array has an associated description vector DESCA.
+* In the following comments, the character _ should be read as
+* "of the global array".
+*
+* NOTATION STORED IN EXPLANATION
+* --------------- -------------- --------------------------------------
+* DTYPE_A(global) DESCA( DTYPE_ )The descriptor type. In this case,
+* DTYPE_A = 1.
+* CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating
+* the BLACS process grid A is distribu-
+* ted over. The context itself is glo-
+* bal, but the handle (the integer
+* value) may vary.
+* M_A (global) DESCA( M_ ) The number of rows in the global
+* array A.
+* N_A (global) DESCA( N_ ) The number of columns in the global
+* array A.
+* MB_A (global) DESCA( MB_ ) The blocking factor used to distribute
+* the rows of the array.
+* NB_A (global) DESCA( NB_ ) The blocking factor used to distribute
+* the columns of the array.
+* RSRC_A (global) DESCA( RSRC_ ) The process row over which the first
+* row of the array A is distributed.
+* CSRC_A (global) DESCA( CSRC_ ) The process column over which the
+* first column of the array A is
+* distributed.
+* LLD_A (local) DESCA( LLD_ ) The leading dimension of the local
+* array. LLD_A >= MAX(1,LOCr(M_A)).
+*
+* Let K be the number of rows or columns of a distributed matrix,
+* and assume that its process grid has dimension p x q.
+* LOCr( K ) denotes the number of elements of K that a process
+* would receive if K were distributed over the p processes of its
+* process column.
+* Similarly, LOCc( K ) denotes the number of elements of K that a
+* process would receive if K were distributed over the q processes of
+* its process row.
+* The values of LOCr() and LOCc() may be determined via a call to the
+* ScaLAPACK tool function, NUMROC:
+* LOCr( M ) = NUMROC( M, MB_A, MYROW, RSRC_A, NPROW ),
+* LOCc( N ) = NUMROC( N, NB_A, MYCOL, CSRC_A, NPCOL ).
+* An upper bound for these quantities may be computed by:
+* LOCr( M ) <= ceil( ceil(M/MB_A)/NPROW )*MB_A
+* LOCc( N ) <= ceil( ceil(N/NB_A)/NPCOL )*NB_A
+*
+* Arguments
+* =========
+*
+* UPLO (global input) CHARACTER
+* Specifies the part of the distributed matrix sub( A ) to be
+* copied:
+* = 'U': Upper triangular part is copied; the strictly
+* lower triangular part of sub( A ) is not referenced;
+* = 'L': Lower triangular part is copied; the strictly
+* upper triangular part of sub( A ) is not referenced;
+* Otherwise: All of the matrix sub( A ) is copied.
+*
+* M (global input) INTEGER
+* The number of rows to be operated on i.e the number of rows
+* of the distributed submatrix sub( A ). M >= 0.
+*
+* N (global input) INTEGER
+* The number of columns to be operated on i.e the number of
+* columns of the distributed submatrix sub( A ). N >= 0.
+*
+* A (local input) REAL pointer into the local memory
+* to an array of dimension (LLD_A, LOCc(JA+N-1) ). This array
+* contains the local pieces of the distributed matrix sub( A )
+* to be copied from.
+*
+* IA (global input) INTEGER
+* The row index in the global array A indicating the first
+* row of sub( A ).
+*
+* JA (global input) INTEGER
+* The column index in the global array A indicating the
+* first column of sub( A ).
+*
+* DESCA (global and local input) INTEGER array of dimension DLEN_.
+* The array descriptor for the distributed matrix A.
+*
+* B (local output) REAL pointer into the local memory
+* to an array of dimension (LLD_B, LOCc(JB+N-1) ). This array
+* contains on exit the local pieces of the distributed matrix
+* sub( B ).
+*
+* IB (global input) INTEGER
+* The row index in the global array B indicating the first
+* row of sub( B ).
+*
+* JB (global input) INTEGER
+* The column index in the global array B indicating the
+* first column of sub( B ).
+*
+* DESCB (global and local input) INTEGER array of dimension DLEN_.
+* The array descriptor for the distributed matrix B.
+*
+* DWORK (local workspace) REAL array
+* If UPLO = 'U' or UPLO = 'L' and number of processors > 1,
+* the length of DWORK is at least as large as the length of B.
+* Otherwise, DWORK is not referenced.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ INTEGER BLOCK_CYCLIC_2D, CSRC_, CTXT_, DLEN_, DTYPE_,
+ $ LLD_, MB_, M_, NB_, N_, RSRC_
+ PARAMETER ( BLOCK_CYCLIC_2D = 1, DLEN_ = 9, DTYPE_ = 1,
+ $ CTXT_ = 2, M_ = 3, N_ = 4, MB_ = 5, NB_ = 6,
+ $ RSRC_ = 7, CSRC_ = 8, LLD_ = 9 )
+* ..
+* .. Local Scalars ..
+ LOGICAL UPPER, LOWER, FULL
+ INTEGER ICTXT, NPROW, NPCOL, MYROW, MYCOL, MYPROC,
+ $ NPROCS, AROWS, ACOLS, K, SPROC, SRSRC, SCSRC,
+ $ RPROC, RRSRC, RCSRC, COUNT, J, I, IIA, JJA,
+ $ IIB, JJB, BRSRC, BCSRC, RAROWS, RACOLS,
+ $ INDEX, IDUM, NUMREC, NUMSND
+* ..
+* .. External Subroutines ..
+ EXTERNAL SLAMOV, INFOG2L
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ INTEGER ICEIL, NUMROC, INDXL2G
+ EXTERNAL ICEIL, LSAME, NUMROC, INDXL2G
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MIN, MOD
+* ..
+* .. Executable Statements ..
+*
+* Find underlying mesh properties.
+*
+ ICTXT = DESCA( CTXT_ )
+ CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL )
+*
+* Decode input parameters.
+*
+ UPPER = LSAME( UPLO, 'U' )
+ IF( .NOT. UPPER ) LOWER = LSAME( UPLO, 'L' )
+ FULL = (.NOT. UPPER) .AND. (.NOT. LOWER)
+*
+* Assign indiviual numbers based on column major ordering.
+*
+ NPROCS = NPROW*NPCOL
+*
+* Do redistribution operation.
+*
+ IF( NPROCS.EQ.1 ) THEN
+ CALL SLAMOV( UPLO, M, N, A((JA-1)*DESCA(LLD_)+IA),
+ $ DESCA(LLD_), B((JB-1)*DESCB(LLD_)+IB),
+ $ DESCB(LLD_) )
+ ELSEIF( FULL ) THEN
+ CALL PSGEMR2D( M, N, A, IA, JA, DESCA, B, IB, JB, DESCB,
+ $ ICTXT )
+ ELSE
+ CALL PSGEMR2D( M, N, A, IA, JA, DESCA, DWORK, IB, JB, DESCB,
+ $ ICTXT )
+ CALL PSLACPY( UPLO, M, N, DWORK, IB, JB, DESCB, B, IB, JB,
+ $ DESCB )
+ END IF
+*
+ RETURN
+*
+* End of PSLAMVE
+*
+ END
diff --git a/SRC/pslaqr0.f b/SRC/pslaqr0.f
new file mode 100644
index 0000000..663cccb
--- /dev/null
+++ b/SRC/pslaqr0.f
@@ -0,0 +1,929 @@
+ RECURSIVE SUBROUTINE PSLAQR0( WANTT, WANTZ, N, ILO, IHI, H,
+ $ DESCH, WR, WI, ILOZ, IHIZ, Z, DESCZ, WORK, LWORK,
+ $ IWORK, LIWORK, INFO, RECLEVEL )
+*
+* Contribution from the Department of Computing Science and HPC2N,
+* Umea University, Sweden
+*
+* -- ScaLAPACK auxiliary routine (version 2.0.1) --
+* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
+* Univ. of Colorado Denver and University of California, Berkeley.
+* January, 2012
+*
+ IMPLICIT NONE
+*
+* .. Scalar Arguments ..
+ INTEGER IHI, IHIZ, ILO, ILOZ, INFO, LIWORK, LWORK, N,
+ $ RECLEVEL
+ LOGICAL WANTT, WANTZ
+* ..
+* .. Array Arguments ..
+ INTEGER DESCH( * ), DESCZ( * ), IWORK( * )
+ REAL H( * ), WI( N ), WORK( * ), WR( N ),
+ $ Z( * )
+* ..
+*
+* Purpose
+* =======
+*
+* PSLAQR0 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.
+*
+* Notes
+* =====
+*
+* Each global data object is described by an associated description
+* vector. This vector stores the information required to establish
+* the mapping between an object element and its corresponding process
+* and memory location.
+*
+* Let A be a generic term for any 2D block cyclicly distributed array.
+* Such a global array has an associated description vector DESCA.
+* In the following comments, the character _ should be read as
+* "of the global array".
+*
+* NOTATION STORED IN EXPLANATION
+* --------------- -------------- --------------------------------------
+* DTYPE_A(global) DESCA( DTYPE_ )The descriptor type. In this case,
+* DTYPE_A = 1.
+* CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating
+* the BLACS process grid A is distribu-
+* ted over. The context itself is glo-
+* bal, but the handle (the integer
+* value) may vary.
+* M_A (global) DESCA( M_ ) The number of rows in the global
+* array A.
+* N_A (global) DESCA( N_ ) The number of columns in the global
+* array A.
+* MB_A (global) DESCA( MB_ ) The blocking factor used to distribute
+* the rows of the array.
+* NB_A (global) DESCA( NB_ ) The blocking factor used to distribute
+* the columns of the array.
+* RSRC_A (global) DESCA( RSRC_ ) The process row over which the first
+* row of the array A is distributed.
+* CSRC_A (global) DESCA( CSRC_ ) The process column over which the
+* first column of the array A is
+* distributed.
+* LLD_A (local) DESCA( LLD_ ) The leading dimension of the local
+* array. LLD_A >= MAX(1,LOCr(M_A)).
+*
+* Let K be the number of rows or columns of a distributed matrix,
+* and assume that its process grid has dimension p x q.
+* LOCr( K ) denotes the number of elements of K that a process
+* would receive if K were distributed over the p processes of its
+* process column.
+* Similarly, LOCc( K ) denotes the number of elements of K that a
+* process would receive if K were distributed over the q processes of
+* its process row.
+* The values of LOCr() and LOCc() may be determined via a call to the
+* ScaLAPACK tool function, NUMROC:
+* LOCr( M ) = NUMROC( M, MB_A, MYROW, RSRC_A, NPROW ),
+* LOCc( N ) = NUMROC( N, NB_A, MYCOL, CSRC_A, NPCOL ).
+* An upper bound for these quantities may be computed by:
+* LOCr( M ) <= ceil( ceil(M/MB_A)/NPROW )*MB_A
+* LOCc( N ) <= ceil( ceil(N/NB_A)/NPCOL )*NB_A
+*
+* Arguments
+* =========
+*
+* WANTT (global input) LOGICAL
+* = .TRUE. : the full Schur form T is required;
+* = .FALSE.: only eigenvalues are required.
+*
+* WANTZ (global input) LOGICAL
+* = .TRUE. : the matrix of Schur vectors Z is required;
+* = .FALSE.: Schur vectors are not required.
+*
+* N (global input) INTEGER
+* The order of the Hessenberg matrix H (and Z if WANTZ).
+* N >= 0.
+*
+* ILO (global input) INTEGER
+* IHI (global input) INTEGER
+* It is assumed that H is already upper triangular in rows
+* and columns 1:ILO-1 and IHI+1:N. ILO and IHI are normally
+* set by a previous call to PSGEBAL, and then passed to PSGEHRD
+* when the matrix output by PSGEBAL is reduced to Hessenberg
+* form. Otherwise ILO and IHI should be set to 1 and N
+* respectively. If N.GT.0, then 1.LE.ILO.LE.IHI.LE.N.
+* If N = 0, then ILO = 1 and IHI = 0.
+*
+* H (global input/output) REAL array, dimension
+* (DESCH(LLD_),*)
+* On entry, the upper Hessenberg matrix H.
+* On exit, if JOB = 'S', H is upper quasi-triangular in
+* rows and columns ILO:IHI, with 1-by-1 and 2-by-2 blocks on
+* the main diagonal. The 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.
+*
+* DESCH (global and local input) INTEGER array of dimension DLEN_.
+* The array descriptor for the distributed matrix H.
+*
+* WR (global output) REAL array, dimension (N)
+* WI (global output) REAL array, dimension (N)
+* The real and imaginary parts, respectively, of the computed
+* eigenvalues ILO to IHI are stored in the corresponding
+* elements of WR and WI. If two eigenvalues are computed as a
+* complex conjugate pair, they are stored in consecutive
+* elements of WR and WI, say the i-th and (i+1)th, with
+* WI(i) > 0 and WI(i+1) < 0. If JOB = 'S', the
+* eigenvalues are stored in the same order as on the diagonal
+* of the Schur form returned in H.
+*
+* Z (global input/output) REAL array.
+* If COMPZ = 'V', on entry Z must contain the current
+* matrix Z of accumulated transformations from, e.g., PSGEHRD,
+* and on exit Z has been updated; transformations are applied
+* only to the submatrix Z(ILO:IHI,ILO:IHI).
+* 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.
+*
+* DESCZ (global and local input) INTEGER array of dimension DLEN_.
+* The array descriptor for the distributed matrix Z.
+*
+* WORK (local workspace) REAL array, dimension(DWORK)
+*
+* LWORK (local input) INTEGER
+* The length of the workspace array WORK.
+*
+* IWORK (local workspace) INTEGER array, dimension (LIWORK)
+*
+* LIWORK (local input) INTEGER
+* The length of the workspace array IWORK.
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* .LT. 0: if INFO = -i, the i-th argument had an illegal
+* value
+* .GT. 0: if INFO = i, PSLAQR0 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.
+*
+* ================================================================
+* Based on contributions by
+* Robert Granat, Department of Computing Science and HPC2N,
+* Umea University, Sweden.
+* ================================================================
+*
+* Restrictions: The block size in H and Z must be square and larger
+* than or equal to six (6) due to restrictions in PSLAQR1, PSLAQR5
+* and SLAQR6. Moreover, H and Z need to be distributed identically
+* with the same context.
+*
+* ================================================================
+* References:
+* K. Braman, R. Byers, and R. Mathias,
+* The Multi-Shift QR Algorithm Part I: Maintaining Well Focused
+* Shifts, and Level 3 Performance.
+* SIAM J. Matrix Anal. Appl., 23(4):929--947, 2002.
+*
+* K. Braman, R. Byers, and R. Mathias,
+* The Multi-Shift QR Algorithm Part II: Aggressive Early
+* Deflation.
+* SIAM J. Matrix Anal. Appl., 23(4):948--973, 2002.
+*
+* R. Granat, B. Kagstrom, and D. Kressner,
+* A Novel Parallel QR Algorithm for Hybrid Distributed Momory HPC
+* Systems.
+* SIAM J. Sci. Comput., 32(4):2345--2378, 2010.
+*
+* ================================================================
+*
+* .. Parameters ..
+*
+* ==== Exceptional deflation windows: try to cure rare
+* . slow convergence by increasing the size of the
+* . deflation window after KEXNW iterations. =====
+*
+* ==== Exceptional shifts: try to cure rare slow convergence
+* . with ad-hoc exceptional shifts every KEXSH iterations.
+* . The constants WILK1 and WILK2 are used to form the
+* . exceptional shifts. ====
+*
+ INTEGER BLOCK_CYCLIC_2D, CSRC_, CTXT_, DLEN_, DTYPE_,
+ $ LLD_, MB_, M_, NB_, N_, RSRC_
+ INTEGER RECMAX
+ PARAMETER ( BLOCK_CYCLIC_2D = 1, DLEN_ = 9, DTYPE_ = 1,
+ $ CTXT_ = 2, M_ = 3, N_ = 4, MB_ = 5, NB_ = 6,
+ $ RSRC_ = 7, CSRC_ = 8, LLD_ = 9, RECMAX = 3 )
+ INTEGER NTINY
+ PARAMETER ( NTINY = 11 )
+ INTEGER KEXNW, KEXSH
+ PARAMETER ( KEXNW = 5, KEXSH = 6 )
+ REAL WILK1, WILK2
+ PARAMETER ( WILK1 = 0.75E0, WILK2 = -0.4375E0 )
+ REAL ZERO, ONE
+ PARAMETER ( ZERO = 0.0e0, ONE = 1.0e0 )
+* ..
+* .. Local Scalars ..
+ REAL AA, BB, CC, CS, DD, SN, SS, SWAP, ELEM, T0,
+ $ ELEM1, ELEM2, ELEM3, ALPHA, SDSUM, STAMP
+ INTEGER I, J, INF, IT, ITMAX, K, KACC22, KBOT, KDU, KS,
+ $ KT, KTOP, KU, KV, KWH, KWTOP, KWV, LD, LS,
+ $ LWKOPT, NDFL, NH, NHO, NIBBLE, NMIN, NS, NSMAX,
+ $ NSR, NVE, NW, NWMAX, NWR, LLDH, LLDZ, II, JJ,
+ $ ICTXT, NPROW, NPCOL, MYROW, MYCOL, IPV, IPT,
+ $ IPW, IPWRK, VROWS, VCOLS, TROWS, TCOLS, WROWS,
+ $ WCOLS, HRSRC, HCSRC, NB, IS, IE, NPROCS, KK,
+ $ IROFFH, ICOFFH, HRSRC3, HCSRC3, NWIN, TOTIT,
+ $ SWEEP, JW, TOTNS, LIWKOPT, NPMIN, ICTXT_NEW,
+ $ MYROW_NEW, MYCOL_NEW
+ LOGICAL NWINC, SORTED, LQUERY, RECURSION
+ CHARACTER JBCMPZ*2
+* ..
+* .. External Functions ..
+ INTEGER PILAENVX, NUMROC, INDXG2P, ICEIL, BLACS_PNUM
+ EXTERNAL PILAENVX, NUMROC, INDXG2P, ICEIL, BLACS_PNUM
+* ..
+* .. Local Arrays ..
+ INTEGER DESCV( DLEN_ ), DESCT( DLEN_ ), DESCW( DLEN_ ),
+ $ PMAP( 64*64 )
+ REAL ZDUM( 1, 1 )
+* ..
+* .. External Subroutines ..
+ EXTERNAL PSLACPY, PSLAQR1, SLANV2, PSLAQR3, PSLAQR5,
+ $ PSELGET, SLAQR0, SLASET, PSGEMR2D
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, FLOAT, INT, MAX, MIN, MOD
+* ..
+* .. Executable Statements ..
+ INFO = 0
+ ICTXT = DESCH( CTXT_ )
+ CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL )
+ NPROCS = NPROW*NPCOL
+ RECURSION = RECLEVEL .LT. RECMAX
+*
+* Quick return for N = 0: nothing to do.
+*
+ IF( N.EQ.0 ) THEN
+ WORK( 1 ) = ONE
+ IWORK( 1 ) = 1
+ RETURN
+ END IF
+*
+* Set up job flags for PILAENV.
+*
+ 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
+*
+* Check if workspace query
+*
+ LQUERY = LWORK.EQ.-1 .OR. LIWORK.EQ.-1
+*
+* Extract local leading dimensions and block factors of matrices
+* H and Z
+*
+ LLDH = DESCH( LLD_ )
+ LLDZ = DESCZ( LLD_ )
+ NB = DESCH( MB_ )
+*
+* Tiny (sub-) matrices must use PSLAQR1. (Stops recursion)
+*
+ IF( N.LE.NTINY ) THEN
+*
+* Estimate optimal workspace.
+*
+ CALL PSLAQR1( WANTT, WANTZ, N, ILO, IHI, H, DESCH, WR, WI,
+ $ ILOZ, IHIZ, Z, DESCZ, WORK, LWORK, IWORK, LIWORK, INFO )
+ LWKOPT = INT( WORK(1) )
+ LIWKOPT = IWORK(1)
+*
+* Completely local matrices uses LAPACK. (Stops recursion)
+*
+ ELSEIF( N.LE.NB ) THEN
+ IF( MYROW.EQ.DESCH(RSRC_) .AND. MYCOL.EQ.DESCH(CSRC_) ) THEN
+ CALL SLAQR0( WANTT, WANTZ, N, ILO, IHI, H, DESCH(LLD_),
+ $ WR, WI, ILOZ, IHIZ, Z, DESCZ(LLD_), WORK, LWORK, INFO )
+ IF( N.GT.2 )
+ $ CALL SLASET( 'L', N-2, N-2, ZERO, ZERO, H(3),
+ $ DESCH(LLD_) )
+ LWKOPT = INT( WORK(1) )
+ LIWKOPT = 1
+ ELSE
+ LWKOPT = 1
+ LIWKOPT = 1
+ END IF
+*
+* Do one more step of recursion
+*
+ ELSE
+*
+* Zero out iteration and sweep counters for debugging purposes
+*
+ TOTIT = 0
+ SWEEP = 0
+ TOTNS = 0
+*
+* Use small bulge multi-shift QR with aggressive early
+* deflation on larger-than-tiny matrices.
+*
+* Hope for the best.
+*
+ INFO = 0
+*
+* NWR = recommended deflation window size. At this
+* point, N .GT. NTINY = 11, so there is enough
+* subdiagonal workspace for NWR.GE.2 as required.
+* (In fact, there is enough subdiagonal space for
+* NWR.GE.3.)
+*
+ NWR = PILAENVX( ICTXT, 13, 'PSLAQR0', JBCMPZ, N, ILO, IHI,
+ $ LWORK )
+ NWR = MAX( 2, NWR )
+ NWR = MIN( IHI-ILO+1, NWR )
+ NW = NWR
+*
+* NSR = recommended number of simultaneous shifts.
+* At this point N .GT. NTINY = 11, so there is at
+* enough subdiagonal workspace for NSR to be even
+* and greater than or equal to two as required.
+*
+ NWIN = PILAENVX( ICTXT, 19, 'PSLAQR0', JBCMPZ, N, NB, NB, NB )
+ NSR = PILAENVX( ICTXT, 15, 'PSLAQR0', JBCMPZ, N, ILO, IHI,
+ $ MAX(NWIN,NB) )
+ NSR = MIN( NSR, IHI-ILO )
+ NSR = MAX( 2, NSR-MOD( NSR, 2 ) )
+*
+* Estimate optimal workspace
+*
+ LWKOPT = 3*ICEIL(NWR,NPROW)*ICEIL(NWR,NPCOL)
+*
+* Workspace query call to PSLAQR3
+*
+ CALL PSLAQR3( WANTT, WANTZ, N, ILO, IHI, NWR+1, H,
+ $ DESCH, ILOZ, IHIZ, Z, DESCZ, LS, LD, WR, WI, H,
+ $ DESCH, N, H, DESCH, N, H, DESCH, WORK, -1, IWORK,
+ $ LIWORK, RECLEVEL )
+ LWKOPT = LWKOPT + INT( WORK( 1 ) )
+ LIWKOPT = IWORK( 1 )
+*
+* Workspace query call to PSLAQR5
+*
+ CALL PSLAQR5( WANTT, WANTZ, 2, N, 1, N, N, WR, WI, H,
+ $ DESCH, ILOZ, IHIZ, Z, DESCZ, WORK, -1, IWORK,
+ $ LIWORK )
+*
+* Optimal workspace = MAX(PSLAQR3, PSLAQR5)
+*
+ LWKOPT = MAX( LWKOPT, INT( WORK( 1 ) ) )
+ LIWKOPT = MAX( LIWKOPT, IWORK( 1 ) )
+*
+* Quick return in case of workspace query.
+*
+ IF( LQUERY ) THEN
+ WORK( 1 ) = FLOAT( LWKOPT )
+ IWORK( 1 ) = LIWKOPT
+ RETURN
+ END IF
+*
+* PSLAQR1/PSLAQR0 crossover point.
+*
+ NMIN = PILAENVX( ICTXT, 12, 'PSLAQR0', JBCMPZ, N, ILO, IHI,
+ $ LWORK )
+ NMIN = MAX( NTINY, NMIN )
+*
+* Nibble crossover point.
+*
+ NIBBLE = PILAENVX( ICTXT, 14, 'PSLAQR0', JBCMPZ, N, ILO, IHI,
+ $ LWORK )
+ NIBBLE = MAX( 0, NIBBLE )
+*
+* Accumulate reflections during ttswp? Use block
+* 2-by-2 structure during matrix-matrix multiply?
+*
+ KACC22 = PILAENVX( ICTXT, 16, 'PSLAQR0', JBCMPZ, N, ILO, IHI,
+ $ LWORK )
+ KACC22 = MAX( 1, KACC22 )
+ KACC22 = MIN( 2, KACC22 )
+*
+* NWMAX = the largest possible deflation window for
+* which there is sufficient workspace.
+*
+ NWMAX = MIN( ( N-1 ) / 3, LWORK / 2 )
+*
+* NSMAX = the Largest number of simultaneous shifts
+* for which there is sufficient workspace.
+*
+ NSMAX = MIN( ( N+6 ) / 9, LWORK - 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 110 IT = 1, ITMAX
+ TOTIT = TOTIT + 1
+*
+* Done when KBOT falls below ILO.
+*
+ IF( KBOT.LT.ILO )
+ $ GO TO 120
+*
+* Locate active block.
+*
+ DO 10 K = KBOT, ILO + 1, -1
+ CALL INFOG2L( K, K-1, DESCH, NPROW, NPCOL, MYROW, MYCOL,
+ $ II, JJ, HRSRC, HCSRC )
+ IF( MYROW.EQ.HRSRC .AND. MYCOL.EQ.HCSRC ) THEN
+ IF( H( II + (JJ-1)*LLDH ).EQ.ZERO )
+ $ GO TO 20
+ END IF
+ 10 CONTINUE
+ K = ILO
+ 20 CONTINUE
+ KTOP = K
+ IF( NPROCS.GT.1 )
+ $ CALL IGAMX2D( ICTXT, 'All', '1-Tree', 1, 1, KTOP, 1,
+ $ -1, -1, -1, -1, -1 )
+*
+* Select deflation window size.
+*
+ NH = KBOT - KTOP + 1
+ IF( NH.LE.NTINY ) THEN
+ NW = NH
+ ELSEIF( NDFL.LT.KEXNW .OR. NH.LT.NW ) THEN
+*
+* Typical deflation window. If possible and
+* advisable, nibble the entire active block.
+* If not, use size NWR or NWR+1 depending upon
+* which has the smaller corresponding subdiagonal
+* entry (a heuristic).
+*
+ NWINC = .TRUE.
+ IF( NH.LE.MIN( NMIN, NWMAX ) ) THEN
+ NW = NH
+ ELSE
+ NW = MIN( NWR, NH, NWMAX )
+ IF( NW.LT.NWMAX ) THEN
+ IF( NW.GE.NH-1 ) THEN
+ NW = NH
+ ELSE
+ KWTOP = KBOT - NW + 1
+ CALL PSELGET( 'All', '1-Tree', ELEM1, H, KWTOP,
+ $ KWTOP-1, DESCH )
+ CALL PSELGET( 'All', '1-Tree', ELEM2, H,
+ $ KWTOP-1, KWTOP-2, DESCH )
+ IF( ABS( ELEM1 ).GT.ABS( ELEM2 ) ) NW = NW + 1
+ END IF
+ END IF
+ END IF
+ ELSE
+*
+* Exceptional deflation window. If there have
+* been no deflations in KEXNW or more iterations,
+* then vary the deflation window size. At first,
+* because, larger windows are, in general, more
+* powerful than smaller ones, rapidly increase the
+* window up to the maximum reasonable and possible.
+* Then maybe try a slightly smaller window.
+*
+ IF( NWINC .AND. NW.LT.MIN( NWMAX, NH ) ) THEN
+ NW = MIN( NWMAX, NH, 2*NW )
+ ELSE
+ NWINC = .FALSE.
+ IF( NW.EQ.NH .AND. NH.GT.2 )
+ $ NW = NH - 1
+ END IF
+ END IF
+*
+* Aggressive early deflation:
+* split workspace into
+* - an NW-by-NW work array V for orthogonal matrix
+* - an NW-by-at-least-NW-but-more-is-better
+* (NW-by-NHO) horizontal work array for Schur factor
+* - an at-least-NW-but-more-is-better (NVE-by-NW)
+* vertical work array for matrix multiplications
+* - align T, V and W with the deflation window
+*
+ KV = N - NW + 1
+ KT = NW + 1
+ NHO = ( N-NW-1 ) - KT + 1
+ KWV = NW + 2
+ NVE = ( N-NW ) - KWV + 1
+*
+ JW = MIN( NW, KBOT-KTOP+1 )
+ KWTOP = KBOT - JW + 1
+ IROFFH = MOD( KWTOP - 1, NB )
+ ICOFFH = IROFFH
+ HRSRC = INDXG2P( KWTOP, NB, MYROW, DESCH(RSRC_), NPROW )
+ HCSRC = INDXG2P( KWTOP, NB, MYCOL, DESCH(CSRC_), NPCOL )
+ VROWS = NUMROC( JW+IROFFH, NB, MYROW, HRSRC, NPROW )
+ VCOLS = NUMROC( JW+ICOFFH, NB, MYCOL, HCSRC, NPCOL )
+ CALL DESCINIT( DESCV, JW+IROFFH, JW+ICOFFH, NB, NB,
+ $ HRSRC, HCSRC, ICTXT, MAX(1, VROWS), INFO )
+*
+ TROWS = NUMROC( JW+IROFFH, NB, MYROW, HRSRC, NPROW )
+ TCOLS = NUMROC( JW+ICOFFH, NB, MYCOL, HCSRC, NPCOL )
+ CALL DESCINIT( DESCT, JW+IROFFH, JW+ICOFFH, NB, NB,
+ $ HRSRC, HCSRC, ICTXT, MAX(1, TROWS), INFO )
+ WROWS = NUMROC( JW+IROFFH, NB, MYROW, HRSRC, NPROW )
+ WCOLS = NUMROC( JW+ICOFFH, NB, MYCOL, HCSRC, NPCOL )
+ CALL DESCINIT( DESCW, JW+IROFFH, JW+ICOFFH, NB, NB,
+ $ HRSRC, HCSRC, ICTXT, MAX(1, WROWS), INFO )
+*
+ IPV = 1
+ IPT = IPV + DESCV( LLD_ ) * VCOLS
+ IPW = IPT + DESCT( LLD_ ) * TCOLS
+ IPWRK = IPW + DESCW( LLD_ ) * WCOLS
+*
+* Aggressive early deflation
+*
+ IWORK(1) = IT
+ CALL PSLAQR3( WANTT, WANTZ, N, KTOP, KBOT, NW, H,
+ $ DESCH, ILOZ, IHIZ, Z, DESCZ, LS, LD, WR, WI,
+ $ WORK(IPV), DESCV, NHO, WORK(IPT), DESCT, NVE,
+ $ WORK(IPW), DESCW, WORK(IPWRK), LWORK-IPWRK+1,
+ $ IWORK, LIWORK, RECLEVEL )
+*
+* 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 PSLAQR3
+* 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
+* PSLAQR3 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
+ CALL PSELGET( 'All', '1-Tree', ELEM1, H, I, I-1,
+ $ DESCH )
+ CALL PSELGET( 'All', '1-Tree', ELEM2, H, I-1, I-2,
+ $ DESCH )
+ CALL PSELGET( 'All', '1-Tree', ELEM3, H, I, I,
+ $ DESCH )
+ SS = ABS( ELEM1 ) + ABS( ELEM2 )
+ AA = WILK1*SS + ELEM3
+ BB = SS
+ CC = WILK2*SS
+ DD = AA
+ CALL SLANV2( AA, BB, CC, DD, WR( I-1 ), WI( I-1 ),
+ $ WR( I ), WI( I ), CS, SN )
+ 30 CONTINUE
+ IF( KS.EQ.KTOP ) THEN
+ CALL PSELGET( 'All', '1-Tree', ELEM1, H, KS+1,
+ $ KS+1, DESCH )
+ WR( KS+1 ) = ELEM1
+ WI( KS+1 ) = ZERO
+ WR( KS ) = WR( KS+1 )
+ WI( KS ) = WI( KS+1 )
+ END IF
+ ELSE
+*
+* Got NS/2 or fewer shifts? Use PSLAQR0 or
+* PSLAQR1 on a trailing principal submatrix to
+* get more.
+*
+ IF( KBOT-KS+1.LE.NS / 2 ) THEN
+ KS = KBOT - NS + 1
+ KT = N - NS + 1
+ NPMIN = PILAENVX( ICTXT, 23, 'PSLAQR0', 'EN', NS,
+ $ NB, NPROW, NPCOL )
+c
+c Temporarily force NPMIN <= 8 since only PSLAQR1 is used.
+c
+ NPMIN = MIN(NPMIN, 8)
+ IF( MIN(NPROW, NPCOL).LE.NPMIN+1 .OR.
+ $ RECLEVEL.GE.1 ) THEN
+*
+* The window is large enough. Compute the Schur
+* decomposition with all processors.
+*
+ IROFFH = MOD( KS - 1, NB )
+ ICOFFH = IROFFH
+ IF( NS.GT.NMIN ) THEN
+ HRSRC = INDXG2P( KS, NB, MYROW, DESCH(RSRC_),
+ $ NPROW )
+ HCSRC = INDXG2P( KS, NB, MYROW, DESCH(CSRC_),
+ $ NPCOL )
+ ELSE
+ HRSRC = 0
+ HCSRC = 0
+ END IF
+ TROWS = NUMROC( NS+IROFFH, NB, MYROW, HRSRC,
+ $ NPROW )
+ TCOLS = NUMROC( NS+ICOFFH, NB, MYCOL, HCSRC,
+ $ NPCOL )
+ CALL DESCINIT( DESCT, NS+IROFFH, NS+ICOFFH, NB,
+ $ NB, HRSRC, HCSRC, ICTXT, MAX(1, TROWS),
+ $ INFO )
+ IPT = 1
+ IPWRK = IPT + DESCT(LLD_) * TCOLS
+*
+ IF( NS.GT.NMIN .AND. RECURSION ) THEN
+ CALL PSLACPY( 'All', NS, NS, H, KS, KS,
+ $ DESCH, WORK(IPT), 1+IROFFH, 1+ICOFFH,
+ $ DESCT )
+ CALL PSLAQR0( .FALSE., .FALSE., IROFFH+NS,
+ $ 1+IROFFH, IROFFH+NS, WORK(IPT),
+ $ DESCT, WR( KS-IROFFH ),
+ $ WI( KS-IROFFH ), 1, 1, ZDUM,
+ $ DESCZ, WORK( IPWRK ),
+ $ LWORK-IPWRK+1, IWORK, LIWORK,
+ $ INF, RECLEVEL+1 )
+ ELSE
+ CALL PSLAMVE( 'All', NS, NS, H, KS, KS,
+ $ DESCH, WORK(IPT), 1+IROFFH, 1+ICOFFH,
+ $ DESCT, WORK(IPWRK) )
+ CALL PSLAQR1( .FALSE., .FALSE., IROFFH+NS,
+ $ 1+IROFFH, IROFFH+NS, WORK(IPT),
+ $ DESCT, WR( KS-IROFFH ),
+ $ WI( KS-IROFFH ), 1+IROFFH, IROFFH+NS,
+ $ ZDUM, DESCZ, WORK( IPWRK ),
+ $ LWORK-IPWRK+1, IWORK, LIWORK, INF )
+ END IF
+ ELSE
+*
+* The window is too small. Redistribute the AED
+* window to a subgrid and do the computation on
+* the subgrid.
+*
+ ICTXT_NEW = ICTXT
+ DO 50 I = 0, NPMIN-1
+ DO 40 J = 0, NPMIN-1
+ PMAP( J+1+I*NPMIN ) =
+ $ BLACS_PNUM( ICTXT, I, J )
+ 40 CONTINUE
+ 50 CONTINUE
+ CALL BLACS_GRIDMAP( ICTXT_NEW, PMAP, NPMIN,
+ $ NPMIN, NPMIN )
+ CALL BLACS_GRIDINFO( ICTXT_NEW, NPMIN, NPMIN,
+ $ MYROW_NEW, MYCOL_NEW )
+ IF( MYROW.GE.NPMIN .OR. MYCOL.GE.NPMIN )
+ $ ICTXT_NEW = -1
+*
+ IF( ICTXT_NEW.GE.0 ) THEN
+ TROWS = NUMROC( NS, NB, MYROW_NEW, 0, NPMIN )
+ TCOLS = NUMROC( NS, NB, MYCOL_NEW, 0, NPMIN )
+ CALL DESCINIT( DESCT, NS, NS, NB, NB, 0, 0,
+ $ ICTXT_NEW, MAX(1,TROWS), INFO )
+ IPT = 1
+ IPWRK = IPT + DESCT(LLD_) * TCOLS
+ ELSE
+ IPT = 1
+ IPWRK = 2
+ DESCT( CTXT_ ) = -1
+ INF = 0
+ END IF
+ CALL PSGEMR2D( NS, NS, H, KS, KS, DESCH,
+ $ WORK(IPT), 1, 1, DESCT, ICTXT )
+*
+c
+c This part is still not perfect.
+c Either PSLAQR0 or PSLAQR1 can work, but not both.
+c
+c NMIN = PILAENVX( ICTXT_NEW, 12, 'PSLAQR0',
+c $ 'EN', NS, 1, NS, LWORK )
+ IF( ICTXT_NEW.GE.0 ) THEN
+c IF( NS.GT.NMIN .AND. RECLEVEL.LT.1 ) THEN
+c CALL PSLAQR0( .FALSE., .FALSE., NS, 1,
+c $ NS, WORK(IPT), DESCT, WR( KS ),
+c $ WI( KS ), 1, 1, ZDUM, DESCT,
+c $ WORK( IPWRK ), LWORK-IPWRK+1, IWORK,
+c $ LIWORK, INF, RECLEVEL+1 )
+c ELSE
+ CALL PSLAQR1( .FALSE., .FALSE., NS, 1,
+ $ NS, WORK(IPT), DESCT, WR( KS ),
+ $ WI( KS ), 1, NS, ZDUM, DESCT,
+ $ WORK( IPWRK ), LWORK-IPWRK+1, IWORK,
+ $ LIWORK, INF )
+c END IF
+ CALL BLACS_GRIDEXIT( ICTXT_NEW )
+ END IF
+ IF( MYROW+MYCOL.GT.0 ) THEN
+ DO 60 J = 0, NS-1
+ WR( KS+J ) = ZERO
+ WI( KS+J ) = ZERO
+ 60 CONTINUE
+ END IF
+ CALL IGAMN2D( ICTXT, 'All', '1-Tree', 1, 1, INF,
+ $ 1, -1, -1, -1, -1, -1 )
+ CALL SGSUM2D( ICTXT, 'All', ' ', NS, 1, WR(KS),
+ $ NS, -1, -1 )
+ CALL SGSUM2D( ICTXT, 'All', ' ', NS, 1, WI(KS),
+ $ NS, -1, -1 )
+ 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
+ CALL PSELGET( 'All', '1-Tree', AA, H, KBOT-1,
+ $ KBOT-1, DESCH )
+ CALL PSELGET( 'All', '1-Tree', CC, H, KBOT,
+ $ KBOT-1, DESCH )
+ CALL PSELGET( 'All', '1-Tree', BB, H, KBOT-1,
+ $ KBOT, DESCH )
+ CALL PSELGET( 'All', '1-Tree', DD, H, KBOT,
+ $ KBOT, DESCH )
+ CALL SLANV2( 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 80 K = KBOT, KS + 1, -1
+ IF( SORTED )
+ $ GO TO 90
+ SORTED = .TRUE.
+ DO 70 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
+ 70 CONTINUE
+ 80 CONTINUE
+ 90 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 100 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
+ 100 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
+ CALL PSELGET( 'All', '1-Tree', ELEM, H, KBOT,
+ $ KBOT, DESCH )
+ IF( ABS( WR( KBOT )-ELEM ).LT.
+ $ ABS( WR( KBOT-1 )-ELEM ) ) 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.
+*
+ TOTNS = TOTNS + NS
+ SWEEP = SWEEP + 1
+ CALL PSLAQR5( WANTT, WANTZ, KACC22, N, KTOP, KBOT,
+ $ NS, WR( KS ), WI( KS ), H, DESCH, ILOZ, IHIZ, Z,
+ $ DESCZ, WORK, LWORK, IWORK, LIWORK )
+ 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.
+ 110 CONTINUE
+*
+* Iteration limit exceeded. Set INFO to show where
+* the problem occurred and exit.
+*
+ INFO = KBOT
+ 120 CONTINUE
+ END IF
+*
+* Return the optimal value of LWORK.
+*
+ WORK( 1 ) = FLOAT( LWKOPT )
+ IWORK( 1 ) = LIWKOPT
+ IF( .NOT. LQUERY ) THEN
+ IWORK( 1 ) = TOTIT
+ IWORK( 2 ) = SWEEP
+ IWORK( 3 ) = TOTNS
+ END IF
+ RETURN
+*
+* End of PSLAQR0
+*
+ END
diff --git a/SRC/pslahqr.f b/SRC/pslaqr1.f
similarity index 83%
copy from SRC/pslahqr.f
copy to SRC/pslaqr1.f
index c3c9f1b..6632e44 100644
--- a/SRC/pslahqr.f
+++ b/SRC/pslaqr1.f
@@ -1,14 +1,17 @@
- SUBROUTINE PSLAHQR( WANTT, WANTZ, N, ILO, IHI, A, DESCA, WR, WI,
- $ ILOZ, IHIZ, Z, DESCZ, WORK, LWORK, IWORK,
- $ ILWORK, INFO )
+ RECURSIVE SUBROUTINE PSLAQR1( WANTT, WANTZ, N, ILO, IHI, A,
+ $ DESCA, WR, WI, ILOZ, IHIZ, Z,
+ $ DESCZ, WORK, LWORK, IWORK,
+ $ ILWORK, INFO )
*
-* -- ScaLAPACK routine (version 1.7.3) --
+* Contribution from the Department of Computing Science and HPC2N,
+* Umea University, Sweden
+*
+* -- ScaLAPACK auxiliary routine (version 2.0.1) --
* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
-* and University of California, Berkeley.
-* 1.7.3: March 22, 2006
-* modification suggested by Mark Fahey and Greg Henry
-* 1.7.1: January 30, 2006
-* 1.7.0: December 31, 1998
+* Univ. of Colorado Denver and University of California, Berkeley.
+* January, 2012
+*
+ IMPLICIT NONE
*
* .. Scalar Arguments ..
LOGICAL WANTT, WANTZ
@@ -22,10 +25,23 @@
* Purpose
* =======
*
-* PSLAHQR is an auxiliary routine used to find the Schur decomposition
+* PSLAQR1 is an auxiliary routine used to find the Schur decomposition
* and or eigenvalues of a matrix already in Hessenberg form from
* cols ILO to IHI.
*
+* This is a modified version of PSLAHQR from ScaLAPACK version 1.7.3.
+* The following modifications were made:
+* o Recently removed workspace query functionality was added.
+* o Aggressive early deflation is implemented.
+* o Aggressive deflation (looking for two consecutive small
+* subdiagonal elements by PSLACONSB) is abandoned.
+* o The returned Schur form is now in canonical form, i.e., the
+* returned 2-by-2 blocks really correspond to complex conjugate
+* pairs of eigenvalues.
+* o For some reason, the original version of PSLAHQR sometimes did
+* not read out the converged eigenvalues correclty. This is now
+* fixed.
+*
* Notes
* =====
*
@@ -99,7 +115,7 @@
* IHI (global input) INTEGER
* It is assumed that A is already upper quasi-triangular in
* rows and columns IHI+1:N, and that A(ILO,ILO-1) = 0 (unless
-* ILO = 1). PSLAHQR works primarily with the Hessenberg
+* ILO = 1). PSLAQR1 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.
@@ -137,7 +153,7 @@
*
* Z (global input/output) REAL array.
* If WANTZ is .TRUE., on entry Z must contain the current
-* matrix Z of transformations accumulated by PDHSEQR, and on
+* matrix Z of transformations accumulated by PSHSEQR, 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.
@@ -149,7 +165,7 @@
*
* LWORK (local input) INTEGER
* WORK(LWORK) is a local array and LWORK is assumed big enough
-* so that LWORK >= 3*N +
+* so that LWORK >= 6*N + 6*385*385 +
* MAX( 2*MAX(DESCZ(LLD_),DESCA(LLD_)) + 2*LOCc(N),
* 7*Ceil(N/HBL)/LCM(NPROW,NPCOL)) )
*
@@ -162,7 +178,7 @@
* INFO (global output) INTEGER
* < 0: parameter number -INFO incorrect or inconsistent
* = 0: successful exit
-* > 0: PSLAHQR failed to compute all the eigenvalues ILO to IHI
+* > 0: PSLAQR1 failed to compute all the eigenvalues ILO to IHI
* in a total of 30*(IHI-ILO+1) iterations; if INFO = i,
* elements i+1:ihi of WR and WI contain those eigenvalues
* which have been successfully computed.
@@ -188,14 +204,12 @@
*
* Subroutines:
* This routine calls:
-* PSLACONSB -> To determine where to start each iteration
* PSLAWIL -> Given the shift, get the transformation
-* SLASORTE -> Pair up eigenvalues so that reals are paired.
+* SLASORTE -> Pair up eigenvalues so that reals are paired.
* PSLACP3 -> Parallel array to local replicated array copy &
* back.
-* SLAREF -> Row/column reflector applier. Core routine
-* here.
-* PSLASMSUB -> Finds negligible subdiagonal elements.
+* SLAREF -> Row/column reflector applier. Core routine here.
+* PSLASMSUB -> Finds negligible subdiagonal elements.
*
* Current Notes and/or Restrictions:
* 1.) This code requires the distributed block size to be square
@@ -230,6 +244,9 @@
*
* Implemented by: G. Henry, November 17, 1996
*
+* Modified by Robert Granat and Meiyue Shao, Department of Computing
+* Science and HPC2N, Umea University, Sweden
+*
* =====================================================================
*
* .. Parameters ..
@@ -239,56 +256,56 @@
$ CTXT_ = 2, M_ = 3, N_ = 4, MB_ = 5, NB_ = 6,
$ RSRC_ = 7, CSRC_ = 8, LLD_ = 9 )
REAL ZERO, ONE, HALF
- PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0, HALF = 0.5E+0 )
+ PARAMETER ( ZERO = 0.0, ONE = 1.0, HALF = 0.5 )
REAL CONST
- PARAMETER ( CONST = 1.50E+0 )
- INTEGER IBLK
- PARAMETER ( IBLK = 32 )
+ PARAMETER ( CONST = 1.50 )
+ INTEGER IBLK, LDS
+ PARAMETER ( IBLK = 32, LDS = 12*IBLK+1 )
* ..
* .. Local Scalars ..
INTEGER CONTXT, DOWN, HBL, I, I1, I2, IAFIRST, IBULGE,
- $ ICBUF, ICOL, ICOL1, ICOL2, IDIA, IERR, II,
+ $ ICBUF, ICOL, ICOL1, ICOL2, IERR, II,
$ IRBUF, IROW, IROW1, IROW2, ISPEC, ISTART,
- $ ISTARTCOL, ISTARTROW, ISTOP, ISUB, ISUP,
+ $ ISTARTCOL, ISTARTROW, ISTOP, ISUB,
$ ITERMAX, ITMP1, ITMP2, ITN, ITS, J, JAFIRST,
$ JBLK, JJ, K, KI, L, LCMRC, LDA, LDZ, LEFT,
$ LIHIH, LIHIZ, LILOH, LILOZ, LOCALI1, LOCALI2,
$ LOCALK, LOCALM, M, MODKM1, MYCOL, MYROW,
$ NBULGE, NH, NODE, NPCOL, NPROW, NR, NUM, NZ,
- $ RIGHT, ROTN, UP, VECSIDX
+ $ RIGHT, ROTN, UP, VECSIDX, TOTIT, TOTNS, TOTSW,
+ $ DBLK, NIBBLE, ND, NS, LTOP, LWKOPT, S1, S2, S3
REAL AVE, DISC, H00, H10, H11, H12, H21, H22, H33,
$ H43H34, H44, OVFL, S, SMLNUM, SUM, T1, T1COPY,
$ T2, T3, ULP, UNFL, V1SAVE, V2, V2SAVE, V3,
- $ V3SAVE
+ $ V3SAVE, SN, CS, SWAP
+ LOGICAL AED
* ..
* .. Local Arrays ..
INTEGER ICURCOL( IBLK ), ICURROW( IBLK ), K1( IBLK ),
$ K2( IBLK ), KCOL( IBLK ), KP2COL( IBLK ),
$ KP2ROW( IBLK ), KROW( IBLK ), LOCALK2( IBLK )
- REAL S1( 2*IBLK, 2*IBLK ), SMALLA( 6, 6, IBLK ),
- $ VCOPY( 3 )
+ REAL SMALLA( 6, 6, IBLK ), VCOPY( 3 )
* ..
* .. External Functions ..
- INTEGER ILCM, NUMROC
+ INTEGER ILCM, NUMROC, ILAENV
REAL PSLAMCH
- EXTERNAL ILCM, NUMROC, PSLAMCH
+ EXTERNAL ILCM, NUMROC, ILAENV, PSLAMCH
* ..
* .. External Subroutines ..
- EXTERNAL BLACS_GRIDINFO, IGAMN2D, INFOG1L, INFOG2L,
- $ PSLABAD, PSLACONSB, PSLACP3, PSLASMSUB,
- $ PSLAWIL, PXERBLA, SCOPY, SGEBR2D, SGEBS2D,
+ EXTERNAL BLACS_GRIDINFO, SCOPY, SGEBR2D, SGEBS2D,
$ SGERV2D, SGESD2D, SGSUM2D, SLAHQR, SLAREF,
- $ SLARFG, SLASORTE
+ $ SLARFG, SLASORTE, IGAMN2D, INFOG1L, INFOG2L,
+ $ PSLABAD, PSLACP3, PSLASMSUB,
+ $ PSLAWIL, PXERBLA, SLANV2, PSLAQR2, PSLAQR4
* ..
* .. Intrinsic Functions ..
- INTRINSIC ABS, MAX, MIN, MOD, SIGN, SQRT
+ INTRINSIC ABS, FLOAT, MAX, MIN, MOD, SIGN, SQRT
* ..
* .. Executable Statements ..
*
INFO = 0
*
ITERMAX = 30*( IHI-ILO+1 )
-* ITERMAX = 0
IF( N.EQ.0 )
$ RETURN
*
@@ -308,6 +325,9 @@
UP = MOD( MYROW+NPROW-1, NPROW )
DOWN = MOD( MYROW+1, NPROW )
LCMRC = ILCM( NPROW, NPCOL )
+ TOTIT = 0
+ TOTNS = 0
+ TOTSW = 0
*
* Determine the number of columns we have so we can check workspace
*
@@ -316,7 +336,12 @@
IF( JJ*HBL.LT.N )
$ JJ = JJ + 1
JJ = 7*JJ / LCMRC
- IF( LWORK.LT.3*N+MAX( 2*MAX( LDA, LDZ )+2*LOCALK, JJ ) ) THEN
+ LWKOPT = INT( 6*N+MAX( 3*MAX( LDA, LDZ )+2*LOCALK, JJ )
+ $ +6*LDS*LDS )
+ IF( LWORK.EQ.-1 .OR. ILWORK.EQ.-1 ) THEN
+ WORK( 1 ) = FLOAT( LWKOPT )
+ RETURN
+ ELSEIF( LWORK.LT.LWKOPT ) THEN
INFO = -15
END IF
IF( DESCZ( CTXT_ ).NE.DESCA( CTXT_ ) ) THEN
@@ -331,12 +356,6 @@
IF( DESCA( MB_ ).NE.DESCZ( MB_ ) ) THEN
INFO = -( 1300+MB_ )
END IF
- IF( ( DESCA( RSRC_ ).NE.0 ) .OR. ( DESCA( CSRC_ ).NE.0 ) ) THEN
- INFO = -( 700+RSRC_ )
- END IF
- IF( ( DESCZ( RSRC_ ).NE.0 ) .OR. ( DESCZ( CSRC_ ).NE.0 ) ) THEN
- INFO = -( 1300+RSRC_ )
- END IF
IF( ( ILO.GT.N ) .OR. ( ILO.LT.1 ) ) THEN
INFO = -4
END IF
@@ -349,18 +368,20 @@
CALL IGAMN2D( CONTXT, 'ALL', ' ', 1, 1, INFO, 1, ITMP1, ITMP2, -1,
$ -1, -1 )
IF( INFO.LT.0 ) THEN
- CALL PXERBLA( CONTXT, 'PSLAHQR', -INFO )
+ CALL PXERBLA( CONTXT, 'PSLAQR1', -INFO )
+ WORK( 1 ) = FLOAT( LWKOPT )
RETURN
END IF
*
* Set work array indices
*
- VECSIDX = 0
- IDIA = 3*N
- ISUB = 3*N
- ISUP = 3*N
- IRBUF = 3*N
- ICBUF = 3*N
+ S1 = 0
+ S2 = S1+LDS*LDS
+ S3 = S2+LDS*LDS
+ VECSIDX = S3+4*LDS*LDS
+ ISUB = VECSIDX+3*N
+ IRBUF = ISUB+N
+ ICBUF = IRBUF+N
*
* Find a value for ROTN
*
@@ -377,14 +398,27 @@
WR( ILO ) = ZERO
END IF
WI( ILO ) = ZERO
+ WORK( 1 ) = FLOAT( LWKOPT )
RETURN
END IF
*
NH = IHI - ILO + 1
NZ = IHIZ - ILOZ + 1
*
- CALL INFOG1L( ILOZ, HBL, NPROW, MYROW, 0, LILOZ, LIHIZ )
- LIHIZ = NUMROC( IHIZ, HBL, MYROW, 0, NPROW )
+* If the diagonal block is small enough, copy it to local memory and
+* call SLAHQR directly.
+*
+ IF( NH .LE. LDS ) THEN
+ CALL PSLAQR4( WANTT, WANTZ, N, ILO, IHI, A, DESCA, WR, WI,
+ $ ILOZ, IHIZ, Z, DESCZ, WORK( S1+1 ), NH,
+ $ WORK( S2+1 ), NH, WORK( S3+1 ), 4*LDS*LDS,
+ $ INFO )
+ WORK( 1 ) = FLOAT( LWKOPT )
+ RETURN
+ END IF
+*
+ CALL INFOG1L( ILOZ, HBL, NPROW, MYROW, DESCZ(RSRC_), LILOZ, LIHIZ)
+ LIHIZ = NUMROC( IHIZ, HBL, MYROW, DESCZ(RSRC_), NPROW )
*
* Set machine-dependent constants for the stopping criterion.
* If NORM(H) <= SQRT(OVFL), overflow should not occur.
@@ -426,6 +460,7 @@
* subdiagonal element has become negligible.
*
DO 420 ITS = 0, ITN
+ TOTIT = TOTIT + 1
*
* Look for a single small subdiagonal element.
*
@@ -445,12 +480,10 @@
WORK( ISUB+L-1 ) = ZERO
END IF
*
-* Exit from loop if a submatrix of order 1 or 2 has split off.
+* Exit from loop if a small submatrix has split off.
*
M = L - 10
-* IF ( L .GE. I - (2*IBLK-1) )
-* IF ( L .GE. I - MAX(2*IBLK-1,HBL) )
- IF( L.GE.I-1 )
+ IF ( L .GT. I - LDS )
$ GO TO 430
*
* Now the active submatrix is in rows and columns L to I. If
@@ -465,7 +498,9 @@
* Copy submatrix of size 2*JBLK and prepare to do generalized
* Wilkinson shift or an exceptional shift
*
- JBLK = MIN( IBLK, ( ( I-L+1 ) / 2 )-1 )
+ NH = I-L+1
+ AED = .TRUE.
+ JBLK = MIN( IBLK, ( NH / 2 )-1 )
IF( JBLK.GT.LCMRC ) THEN
*
* Make sure it's divisible by LCM (we want even workloads!)
@@ -475,31 +510,109 @@
JBLK = MIN( JBLK, 2*LCMRC )
JBLK = MAX( JBLK, 1 )
*
- CALL PSLACP3( 2*JBLK, I-2*JBLK+1, A, DESCA, S1, 2*IBLK, -1, -1,
- $ 0 )
IF( ITS.EQ.20 .OR. ITS.EQ.40 ) THEN
*
* Exceptional shift.
*
+ CALL PSLACP3( 2*JBLK, I-2*JBLK+1, A, DESCA, WORK( S1+1 ),
+ $ LDS, -1, -1, 0 )
DO 20 II = 2*JBLK, 2, -1
- S1( II, II ) = CONST*( ABS( S1( II, II ) )+
- $ ABS( S1( II, II-1 ) ) )
- S1( II, II-1 ) = ZERO
- S1( II-1, II ) = ZERO
+ WORK( S1+II+(II-1)*LDS ) = CONST*(
+ $ ABS( WORK( S1+II+(II-1)*LDS ) )+
+ $ ABS( WORK( S1+II+(II-2)*LDS ) ) )
+ WORK( S1+II+(II-2)*LDS ) = ZERO
+ WORK( S1+II-1+(II-1)*LDS ) = ZERO
20 CONTINUE
- S1( 1, 1 ) = CONST*ABS( S1( 1, 1 ) )
+ WORK( S1+1 ) = CONST*ABS( WORK( S1+1 ) )
ELSE
- CALL SLAHQR( .FALSE., .FALSE., 2*JBLK, 1, 2*JBLK, S1,
- $ 2*IBLK, WORK( IRBUF+1 ), WORK( ICBUF+1 ), 1,
- $ 2*JBLK, Z, LDZ, IERR )
+*
+* Aggressive early deflation.
+*
+ IF( AED ) THEN
+ DBLK = ILAENV( 13, 'DLAQR0', 'SV', N, L, I, 4*LDS*LDS )
+ DBLK = MAX( 2*JBLK, DBLK ) + 1
+ DBLK = MIN( NH, LDS, DBLK )
+ CALL PSLAQR2( WANTT, WANTZ, N, L, I, DBLK, A, DESCA,
+ $ ILOZ, IHIZ, Z, DESCZ, NS, ND, WR, WI,
+ $ WORK( S1+1 ), LDS, WORK( S2+1 ), DBLK,
+ $ WORK( IRBUF+1 ), WORK( ICBUF+1 ),
+ $ WORK( S3+1 ), 4*LDS*LDS )
+*
+* Skip a QR sweep if enough eigenvalues are deflated.
+*
+ NIBBLE = ILAENV( 14, 'DLAQR0', 'SV', N, L, I, 4*LDS*LDS )
+ NIBBLE = MAX( 0, NIBBLE )
+ I = I - ND
+ DBLK = DBLK - ND
+ IF( 100*ND .GT. NIBBLE*NH .OR. DBLK .LT. 2*JBLK ) GOTO 10
+*
+* Use unconverged eigenvalues as shifts for the QR sweep.
+* (This option is turned off because of the quality of
+* these shifts are not so good.)
+*
+* IF( ND.GE.0 .AND. ND+DBLK.GE.64 ) THEN
+ IF( .FALSE. ) THEN
+ CALL SLASET( 'L', DBLK-1, DBLK-1, ZERO, ZERO,
+ $ WORK( S1+2 ), LDS )
+ WORK( IRBUF+1 ) = WORK( S1+1 )
+ WORK( ICBUF+1 ) = ZERO
+*
+* Shuffle shifts into pairs of real shifts and pairs of
+* complex conjugate shifts assuming complex conjugate
+* shifts are already adjacent to one another.
+*
+ DO 21 II = DBLK, 3, -2
+ IF( WORK( ICBUF+II ).NE.-WORK( ICBUF+II-1 ) ) THEN
+ SWAP = WORK( IRBUF+II )
+ WORK( IRBUF+II ) = WORK( IRBUF+II-1 )
+ WORK( IRBUF+II-1 ) = WORK( IRBUF+II-2 )
+ WORK( IRBUF+II-2 ) = SWAP
+ SWAP = WORK( ICBUF+II )
+ WORK( ICBUF+II ) = WORK( ICBUF+II-1 )
+ WORK( ICBUF+II-1 ) = WORK( ICBUF+II-2 )
+ WORK( ICBUF+II-2 ) = SWAP
+ END IF
+ 21 CONTINUE
+*
+* Copy undeflatable eigenvalues to the diagonal of S1.
+*
+ II = 2
+ 22 CONTINUE
+ IF( WORK( ICBUF+II ) .EQ. ZERO ) THEN
+ WORK( S1+II+(II-1)*LDS ) = WORK( IRBUF+II )
+ WORK( S1+II+(II-2)*LDS ) = ZERO
+ II = II + 1
+ ELSE
+ WORK( S1+II+(II-1)*LDS ) = WORK( IRBUF+II )
+ WORK( S1+II+1+II*LDS ) = WORK( IRBUF+II )
+ WORK( S1+II+1+(II-1)*LDS ) = WORK( ICBUF+II )
+ WORK( S1+II+II*LDS ) = -WORK( ICBUF+II )
+ II = II + 2
+ END IF
+ IF( II .LE. DBLK ) GOTO 22
+ ELSE
+ CALL SLAHQR( .FALSE., .FALSE., DBLK, 1, DBLK,
+ $ WORK( S1+1 ), LDS, WORK( IRBUF+1 ),
+ $ WORK( ICBUF+1 ), 1, DBLK, Z, LDZ, IERR )
+ END IF
+ ELSE
+ DBLK = 2*JBLK
+ CALL PSLACP3( DBLK, I-DBLK+1, A, DESCA, WORK( S1+1 ),
+ $ LDS, -1, -1, 0 )
+ CALL SLAHQR( .FALSE., .FALSE., DBLK, 1, DBLK,
+ $ WORK( S1+1 ), LDS, WORK( IRBUF+1 ),
+ $ WORK( ICBUF+1 ), 1, DBLK, Z, LDZ, IERR )
+ END IF
+ TOTSW = TOTSW + 1
*
* Prepare to use Wilkinson's double shift
*
- H44 = S1( 2*JBLK, 2*JBLK )
- H33 = S1( 2*JBLK-1, 2*JBLK-1 )
- H43H34 = S1( 2*JBLK-1, 2*JBLK )*S1( 2*JBLK, 2*JBLK-1 )
+ H44 = WORK( S1+DBLK+(DBLK-1)*LDS )
+ H33 = WORK( S1+DBLK-1+(DBLK-2)*LDS )
+ H43H34 = WORK( S1+DBLK-1+(DBLK-1)*LDS )*
+ $ WORK( S1+DBLK+(DBLK-2)*LDS )
IF( ( JBLK.GT.1 ) .AND. ( ITS.GT.30 ) ) THEN
- S = S1( 2*JBLK-1, 2*JBLK-2 )
+ S = WORK( S1+DBLK-1+(DBLK-3)*LDS )
DISC = ( H33-H44 )*HALF
DISC = DISC*DISC + H43H34
IF( DISC.GT.ZERO ) THEN
@@ -523,14 +636,25 @@
* Look for two consecutive small subdiagonal elements:
* PSLACONSB is the routine that does this.
*
- CALL PSLACONSB( A, DESCA, I, L, M, H44, H33, H43H34,
- $ WORK( IRBUF+1 ), LWORK-IRBUF )
+* CALL PSLACONSB( A, DESCA, I, L, M, H44, H33, H43H34,
+* $ WORK( IRBUF+1 ), LWORK-IRBUF )
*
* Skip small submatrices
*
* IF ( M .GE. I - 5 )
* $ GO TO 80
*
+* In principle PSLACONSB needs to check all shifts to decide
+* whether two consecutive small subdiagonal entries are suitable
+* as the starting position of the bulge chasing phase. It can be
+* dangerous to check the first pair of shifts only. Moreover it
+* is quite rare to obtain an M which is much larger than L. This
+* process is a bit expensive compared with the benefit.
+* Therefore it is sensible to abandon this routine. Total amount
+* of communications is saved in average.
+*
+ M = L
+*
* Double-shift QR step
*
* NBULGE is the number of bulges that will be attempted
@@ -552,15 +676,19 @@
END IF
NBULGE = MAX( NBULGE, 1 )
*
+ TOTNS = TOTNS + NBULGE*2
+*
IF( ( ITS.NE.20 ) .AND. ( ITS.NE.40 ) .AND. ( NBULGE.GT.1 ) )
$ THEN
*
* sort the eigenpairs so that they are in twos for double
* shifts. only call if several need sorting
*
- CALL SLASORTE( S1( 2*( JBLK-NBULGE )+1,
- $ 2*( JBLK-NBULGE )+1 ), 2*IBLK, 2*NBULGE,
- $ WORK( IRBUF+1 ), IERR )
+* CALL SLASORTE( S1( 2*( JBLK-NBULGE )+1,
+* $ 2*( JBLK-NBULGE )+1 ), 3*IBLK, 2*NBULGE,
+* $ WORK( IRBUF+1 ), IERR )
+ CALL SLASORTE( WORK(S1+DBLK-2*NBULGE+1+(DBLK-2*NBULGE)*LDS),
+ $ LDS, 2*NBULGE, WORK( IRBUF+1 ), IERR )
END IF
*
* IBULGE is the number of bulges going so far
@@ -569,31 +697,31 @@
*
* "A" row defs : main row transforms from LOCALK to LOCALI2
*
- CALL INFOG1L( M, HBL, NPCOL, MYCOL, 0, ITMP1, LOCALK )
- LOCALK = NUMROC( N, HBL, MYCOL, 0, NPCOL )
- CALL INFOG1L( 1, HBL, NPCOL, MYCOL, 0, ICOL1, LOCALI2 )
- LOCALI2 = NUMROC( I2, HBL, MYCOL, 0, NPCOL )
+ CALL INFOG1L( M, HBL, NPCOL, MYCOL, DESCA(CSRC_),ITMP1,LOCALK )
+ LOCALK = NUMROC( N, HBL, MYCOL, DESCA(CSRC_), NPCOL )
+ CALL INFOG1L( 1, HBL, NPCOL, MYCOL,DESCA(CSRC_),ICOL1,LOCALI2 )
+ LOCALI2 = NUMROC( I2, HBL, MYCOL, DESCA(CSRC_), NPCOL )
*
* "A" col defs : main col transforms from LOCALI1 to LOCALM
*
- CALL INFOG1L( I1, HBL, NPROW, MYROW, 0, LOCALI1, ICOL1 )
- ICOL1 = NUMROC( N, HBL, MYROW, 0, NPROW )
- CALL INFOG1L( 1, HBL, NPROW, MYROW, 0, LOCALM, ICOL1 )
- ICOL1 = NUMROC( MIN( M+3, I ), HBL, MYROW, 0, NPROW )
+ CALL INFOG1L( I1, HBL, NPROW,MYROW,DESCA(RSRC_),LOCALI1,ICOL1 )
+ ICOL1 = NUMROC( N, HBL, MYROW, DESCA(RSRC_), NPROW )
+ CALL INFOG1L( 1, HBL, NPROW, MYROW, DESCA(RSRC_),LOCALM,ICOL1 )
+ ICOL1 = NUMROC( MIN( M+3, I ), HBL, MYROW, DESCA(RSRC_),NPROW )
*
* Which row & column will start the bulges
*
- ISTARTROW = MOD( ( M+1 ) / HBL, NPROW ) + IAFIRST
- ISTARTCOL = MOD( ( M+1 ) / HBL, NPCOL ) + JAFIRST
+ ISTARTROW = MOD( ( M+1 ) / HBL + IAFIRST, NPROW )
+ ISTARTCOL = MOD( ( M+1 ) / HBL + JAFIRST, NPCOL )
*
- CALL INFOG1L( M, HBL, NPROW, MYROW, 0, II, ITMP2 )
- ITMP2 = NUMROC( N, HBL, MYROW, 0, NPROW )
- CALL INFOG1L( M, HBL, NPCOL, MYCOL, 0, JJ, ITMP2 )
- ITMP2 = NUMROC( N, HBL, MYCOL, 0, NPCOL )
- CALL INFOG1L( 1, HBL, NPROW, MYROW, 0, ISTOP, KP2ROW( 1 ) )
- KP2ROW( 1 ) = NUMROC( M+2, HBL, MYROW, 0, NPROW )
- CALL INFOG1L( 1, HBL, NPCOL, MYCOL, 0, ISTOP, KP2COL( 1 ) )
- KP2COL( 1 ) = NUMROC( M+2, HBL, MYCOL, 0, NPCOL )
+ CALL INFOG1L( M, HBL, NPROW, MYROW, DESCA(RSRC_), II, ITMP2 )
+ ITMP2 = NUMROC( N, HBL, MYROW, DESCA(RSRC_), NPROW )
+ CALL INFOG1L( M, HBL, NPCOL, MYCOL, DESCA(CSRC_), JJ, ITMP2 )
+ ITMP2 = NUMROC( N, HBL, MYCOL, DESCA(CSRC_), NPCOL )
+ CALL INFOG1L(1,HBL,NPROW,MYROW,DESCA(RSRC_),ISTOP,KP2ROW( 1 ) )
+ KP2ROW( 1 ) = NUMROC( M+2, HBL, MYROW, DESCA(RSRC_), NPROW )
+ CALL INFOG1L(1,HBL,NPCOL,MYCOL,DESCA(CSRC_),ISTOP,KP2COL( 1 ) )
+ KP2COL( 1 ) = NUMROC( M+2, HBL, MYCOL, DESCA(CSRC_), NPCOL )
*
* Set all values for bulges. All bulges are stored in
* intermediate steps as loops over KI. Their current "task"
@@ -647,10 +775,11 @@
$ THEN
IF( ( MOD( K2( IBULGE )+2, HBL ).EQ.MOD( K2( IBULGE+1 )+
$ 2, HBL ) ) .AND. ( K1( 1 ).LE.I-1 ) ) THEN
- H44 = S1( 2*JBLK-2*IBULGE, 2*JBLK-2*IBULGE )
- H33 = S1( 2*JBLK-2*IBULGE-1, 2*JBLK-2*IBULGE-1 )
- H43H34 = S1( 2*JBLK-2*IBULGE-1, 2*JBLK-2*IBULGE )*
- $ S1( 2*JBLK-2*IBULGE, 2*JBLK-2*IBULGE-1 )
+ H44 = WORK( S1+DBLK-2*IBULGE+(DBLK-2*IBULGE-1)*LDS )
+ H33 = WORK( S1+DBLK-2*IBULGE-1+(DBLK-2*IBULGE-2)*LDS )
+ H43H34 = WORK( S1+DBLK-2*IBULGE-1+
+ $ (DBLK-2*IBULGE-1)*LDS )
+ $ *WORK(S1+DBLK-2*IBULGE+(DBLK-2*IBULGE-2)*LDS)
ITMP1 = ISTARTROW
ITMP2 = ISTARTCOL
CALL PSLAWIL( ITMP1, ITMP2, M, A, DESCA, H44, H33,
@@ -784,7 +913,7 @@
* IF ( ABS(H10) .LE. MAX(ULP*(ABS(H11)+ABS(H22)),
* $ SMLNUM) ) THEN
* SMALLA(2,1,KI) = ZERO
-* WORK(ISUB+K-2) = ZERO
+* WORK(ISUB+K-2) = ZERO
* END IF
ELSE IF( M.GT.L ) THEN
SMALLA( 3, 2, KI ) = -SMALLA( 3, 2, KI )
@@ -1161,7 +1290,7 @@
IF( ( MODKM1.GE.HBL-2 ) .AND. ( K.LE.I-1 ) ) THEN
IF( ( MODKM1.EQ.HBL-2 ) .AND. ( K.LT.I-1 ) ) THEN
*
-* Copy 6 elements from global A(K-1:K+4,K-1:K+4)
+* Copy 6 elements to global A(K-1:K+4,K-1:K+4)
*
CALL INFOG2L( K+2, K+2, DESCA, NPROW, NPCOL, MYROW,
$ MYCOL, IROW1, ICOL1, ITMP1, ITMP2 )
@@ -1172,7 +1301,7 @@
END IF
IF( MODKM1.EQ.HBL-1 ) THEN
*
-* Copy 6 elements from global A(K-2:K+3,K-2:K+3)
+* Copy 6 elements to global A(K-2:K+3,K-2:K+3)
*
CALL INFOG2L( K+1, K+1, DESCA, NPROW, NPCOL, MYROW,
$ MYCOL, IROW1, ICOL1, ITMP1, ITMP2 )
@@ -1196,9 +1325,9 @@
$ ( MOD( ISTART-1, HBL ).LT.HBL-2 ) .AND.
$ ( ICURROW( KI ).EQ.MYROW ) ) THEN
IROW1 = MIN( K2( KI )+1, I-1 ) + 1
- CALL INFOG1L( IROW1, HBL, NPCOL, MYCOL, 0, ITMP1,
- $ ITMP2 )
- ITMP2 = NUMROC( I2, HBL, MYCOL, 0, NPCOL )
+ CALL INFOG1L( IROW1, HBL, NPCOL, MYCOL, DESCA(CSRC_),
+ $ ITMP1, ITMP2 )
+ ITMP2 = NUMROC( I2, HBL, MYCOL, DESCA(CSRC_), NPCOL )
II = KROW( KI )
CALL SLAREF( 'Row', A, LDA, WANTZ, Z, LDZ, .TRUE., II,
$ II, ISTART, ISTOP, ITMP1, ITMP2, LILOZ,
@@ -1243,9 +1372,9 @@
*
IROW1 = KROW( KI )
IROW2 = KP2ROW( KI )
- CALL INFOG1L( ITMP1, HBL, NPCOL, MYCOL, 0,
- $ ICOL1, ICOL2 )
- ICOL2 = NUMROC( I2, HBL, MYCOL, 0, NPCOL )
+ CALL INFOG1L( ITMP1, HBL, NPCOL, MYCOL,
+ $ DESCA(CSRC_), ICOL1, ICOL2 )
+ ICOL2 = NUMROC(I2,HBL,MYCOL,DESCA(CSRC_),NPCOL )
IF( ( MOD( K-1, HBL ).LT.HBL-2 ) .OR.
$ ( NPROW.EQ.1 ) ) THEN
T2 = T1*V2
@@ -1311,9 +1440,9 @@
*
IROW1 = KROW( KI ) + K - ISTART
IROW2 = KP2ROW( KI ) + K - ISTART
- CALL INFOG1L( ITMP1, HBL, NPCOL, MYCOL, 0,
- $ ICOL1, ICOL2 )
- ICOL2 = NUMROC( I2, HBL, MYCOL, 0, NPCOL )
+ CALL INFOG1L( ITMP1, HBL, NPCOL, MYCOL,
+ $ DESCA(CSRC_),ICOL1, ICOL2 )
+ ICOL2 = NUMROC(I2,HBL,MYCOL,DESCA(CSRC_),NPCOL )
IF( ( MOD( K-1, HBL ).EQ.HBL-2 ) .AND.
$ ( NPROW.GT.1 ) ) THEN
IF( IROW1.NE.IROW2 ) THEN
@@ -1401,9 +1530,9 @@
*
IROW1 = KROW( KI ) + K - ISTART
IROW2 = KP2ROW( KI ) + K - ISTART
- CALL INFOG1L( ITMP1, HBL, NPCOL, MYCOL, 0,
- $ ICOL1, ICOL2 )
- ICOL2 = NUMROC( I2, HBL, MYCOL, 0, NPCOL )
+ CALL INFOG1L( ITMP1, HBL, NPCOL, MYCOL,
+ $ DESCA(CSRC_), ICOL1, ICOL2 )
+ ICOL2 = NUMROC(I2,HBL,MYCOL,DESCA(CSRC_),NPCOL )
IF( ( MOD( K-1, HBL ).EQ.HBL-2 ) .AND.
$ ( NPROW.GT.1 ) ) THEN
IF( IROW1.EQ.IROW2 ) THEN
@@ -1454,8 +1583,9 @@
END IF
*
ICOL1 = KCOL( KI )
- CALL INFOG1L( I1, HBL, NPROW, MYROW, 0, IROW1, IROW2 )
- IROW2 = NUMROC( ITMP1, HBL, MYROW, 0, NPROW )
+ CALL INFOG1L( I1, HBL, NPROW, MYROW, DESCA(RSRC_),
+ $ IROW1, IROW2 )
+ IROW2 = NUMROC( ITMP1, HBL, MYROW,DESCA(RSRC_),NPROW )
IF( IROW1.LE.IROW2 ) THEN
ITMP2 = IROW2
ELSE
@@ -1483,10 +1613,10 @@
IROW2 = IROW1 - 1
END IF
ELSE
- CALL INFOG1L( ITMP1+1, HBL, NPROW, MYROW, 0,
- $ IROW1, IROW2 )
- IROW2 = NUMROC( MIN( K+3, I ), HBL, MYROW, 0,
- $ NPROW )
+ CALL INFOG1L( ITMP1+1, HBL, NPROW, MYROW,
+ $ DESCA(RSRC_),IROW1, IROW2 )
+ IROW2 = NUMROC( MIN( K+3, I ), HBL, MYROW,
+ $ DESCA(RSRC_), NPROW )
END IF
V2 = WORK( VECSIDX+( K-1 )*3+1 )
V3 = WORK( VECSIDX+( K-1 )*3+2 )
@@ -1547,9 +1677,10 @@
END IF
ICOL1 = KCOL( KI ) + K - ISTART
ICOL2 = KP2COL( KI ) + K - ISTART
- CALL INFOG1L( I1, HBL, NPROW, MYROW, 0, IROW1,
- $ IROW2 )
- IROW2 = NUMROC( ITMP1, HBL, MYROW, 0, NPROW )
+ CALL INFOG1L( I1, HBL, NPROW, MYROW, DESCA(RSRC_),
+ $ IROW1, IROW2 )
+ IROW2 = NUMROC( ITMP1, HBL, MYROW, DESCA(RSRC_),
+ $ NPROW )
IF( ( MOD( K-1, HBL ).EQ.HBL-2 ) .AND.
$ ( NPCOL.GT.1 ) ) THEN
IF( ICOL1.EQ.ICOL2 ) THEN
@@ -1745,12 +1876,12 @@
* Apply G from the left to transform the rows of the matrix
* in columns K to I2.
*
- CALL INFOG1L( K, HBL, NPCOL, MYCOL, 0, LILOH,
- $ LIHIH )
- LIHIH = NUMROC( I2, HBL, MYCOL, 0, NPCOL )
- CALL INFOG1L( 1, HBL, NPROW, MYROW, 0, ITMP2,
- $ ITMP1 )
- ITMP1 = NUMROC( K+1, HBL, MYROW, 0, NPROW )
+ CALL INFOG1L( K, HBL, NPCOL, MYCOL, DESCA(CSRC_),
+ $ LILOH,LIHIH )
+ LIHIH = NUMROC( I2, HBL, MYCOL, DESCA(CSRC_),NPCOL)
+ CALL INFOG1L( 1, HBL, NPROW, MYROW, DESCA(RSRC_),
+ $ ITMP2,ITMP1 )
+ ITMP1 = NUMROC( K+1,HBL, MYROW,DESCA(RSRC_),NPROW )
IF( ICURROW( KI ).EQ.MYROW ) THEN
IF( ( ISPEC.EQ.0 ) .OR. ( NPROW.EQ.1 ) .OR.
$ ( MOD( K-1, HBL ).EQ.HBL-2 ) ) THEN
@@ -1794,17 +1925,18 @@
* Apply G from the right to transform the columns of the
* matrix in rows I1 to MIN(K+3,I).
*
- CALL INFOG1L( I1, HBL, NPROW, MYROW, 0, LILOH,
- $ LIHIH )
- LIHIH = NUMROC( I, HBL, MYROW, 0, NPROW )
+ CALL INFOG1L( I1, HBL, NPROW, MYROW, DESCA(RSRC_),
+ $ LILOH, LIHIH )
+ LIHIH = NUMROC( I, HBL, MYROW, DESCA(RSRC_),NPROW )
*
IF( ICURCOL( KI ).EQ.MYCOL ) THEN
* LOCAL A(LILOZ:LIHIZ,LOCALK2:LOCALK2+2)
IF( ( ISPEC.EQ.0 ) .OR. ( NPCOL.EQ.1 ) .OR.
$ ( MOD( K-1, HBL ).EQ.HBL-2 ) ) THEN
- CALL INFOG1L( K, HBL, NPCOL, MYCOL, 0, ITMP1,
- $ ITMP2 )
- ITMP2 = NUMROC( K+1, HBL, MYCOL, 0, NPCOL )
+ CALL INFOG1L( K, HBL, NPCOL, MYCOL,
+ $ DESCA(CSRC_), ITMP1,ITMP2 )
+ ITMP2 = NUMROC(K+1,HBL,MYCOL,DESCA(CSRC_),
+ $ NPCOL )
DO 360 J = LILOH, LIHIH
SUM = A( ( ITMP1-1 )*LDA+J ) +
$ V2*A( ITMP1*LDA+J )
@@ -1839,9 +1971,10 @@
CALL SGESD2D( CONTXT, LIHIH-LILOH+1, 1,
$ A( ( ITMP1-1 )*LDA+LILOH ),
$ LDA, MYROW, RIGHT )
- CALL INFOG1L( K, HBL, NPCOL, MYCOL, 0, ITMP1,
- $ ITMP2 )
- ITMP2 = NUMROC( K+1, HBL, MYCOL, 0, NPCOL )
+ CALL INFOG1L( K, HBL, NPCOL, MYCOL,
+ $ DESCA(CSRC_), ITMP1, ITMP2 )
+ ITMP2 = NUMROC( K+1, HBL, MYCOL,
+ $ DESCA(CSRC_), NPCOL )
CALL SGERV2D( CONTXT, LIHIH-LILOH+1, 1,
$ A( ( ITMP1-1 )*LDA+LILOH ),
$ LDA, MYROW, RIGHT )
@@ -1927,17 +2060,17 @@
IF( ( MOD( K1( KI )-1, HBL ).GE.HBL-2 ) .AND.
$ ( ( MYROW.EQ.ICURROW( KI ) ) .OR. ( DOWN.EQ.
$ ICURROW( KI ) ) ) .AND. ( NPROW.GT.1 ) ) THEN
- CALL INFOG1L( K2( KI )+1, HBL, NPROW, MYROW, 0,
- $ KROW( KI ), ITMP2 )
- ITMP2 = NUMROC( N, HBL, MYROW, 0, NPROW )
+ CALL INFOG1L( K2( KI )+1, HBL, NPROW, MYROW,
+ $ DESCA(RSRC_), KROW( KI ), ITMP2 )
+ ITMP2 = NUMROC( N, HBL, MYROW, DESCA(RSRC_), NPROW )
END IF
IF( ( MOD( K2( KI ), HBL ).GE.HBL-2 ) .AND.
$ ( ( MYROW.EQ.ICURROW( KI ) ) .OR. ( UP.EQ.
$ ICURROW( KI ) ) ) .AND. ( NPROW.GT.1 ) ) THEN
- CALL INFOG1L( 1, HBL, NPROW, MYROW, 0, ITMP2,
- $ KP2ROW( KI ) )
- KP2ROW( KI ) = NUMROC( K2( KI )+3, HBL, MYROW, 0,
- $ NPROW )
+ CALL INFOG1L( 1, HBL, NPROW, MYROW, DESCA(RSRC_),
+ $ ITMP2,KP2ROW( KI ) )
+ KP2ROW( KI ) = NUMROC( K2( KI )+3, HBL, MYROW,
+ $ DESCA(RSRC_), NPROW )
END IF
IF( NPCOL.EQ.1 ) THEN
KCOL( KI ) = KCOL( KI ) + K2( KI ) - K1( KI ) + 1
@@ -1956,17 +2089,17 @@
IF( ( MOD( K1( KI )-1, HBL ).GE.HBL-2 ) .AND.
$ ( ( MYCOL.EQ.ICURCOL( KI ) ) .OR. ( RIGHT.EQ.
$ ICURCOL( KI ) ) ) .AND. ( NPCOL.GT.1 ) ) THEN
- CALL INFOG1L( K2( KI )+1, HBL, NPCOL, MYCOL, 0,
- $ KCOL( KI ), ITMP2 )
- ITMP2 = NUMROC( N, HBL, MYCOL, 0, NPCOL )
+ CALL INFOG1L( K2( KI )+1, HBL, NPCOL, MYCOL,
+ $ DESCA(CSRC_), KCOL( KI ), ITMP2 )
+ ITMP2 = NUMROC( N, HBL, MYCOL, DESCA(CSRC_), NPCOL )
END IF
IF( ( MOD( K2( KI ), HBL ).GE.HBL-2 ) .AND.
$ ( ( MYCOL.EQ.ICURCOL( KI ) ) .OR. ( LEFT.EQ.
$ ICURCOL( KI ) ) ) .AND. ( NPCOL.GT.1 ) ) THEN
- CALL INFOG1L( 1, HBL, NPCOL, MYCOL, 0, ITMP2,
+ CALL INFOG1L( 1, HBL, NPCOL, MYCOL,DESCA(CSRC_),ITMP2,
$ KP2COL( KI ) )
- KP2COL( KI ) = NUMROC( K2( KI )+3, HBL, MYCOL, 0,
- $ NPCOL )
+ KP2COL( KI ) = NUMROC( K2( KI )+3, HBL, MYCOL,
+ $ DESCA(CSRC_), NPCOL )
END IF
K1( KI ) = K2( KI ) + 1
ISTOP = MIN( K1( KI )+ROTN-MOD( K1( KI ), ROTN ), I-2 )
@@ -1996,6 +2129,7 @@
* Failure to converge in remaining number of iterations
*
INFO = I
+ WORK( 1 ) = FLOAT( LWKOPT )
RETURN
*
430 CONTINUE
@@ -2016,88 +2150,57 @@
*
* H(I-1,I-2) is negligible: a pair of eigenvalues have converged.
*
- WR( I-1 ) = ZERO
- WR( I ) = ZERO
- WI( I-1 ) = ZERO
- WI( I ) = ZERO
- MODKM1 = MOD( I-1+HBL, HBL )
- CALL INFOG2L( I-1, I-1, DESCA, NPROW, NPCOL, MYROW, MYCOL,
- $ IROW1, ICOL1, II, JJ )
- IF( ( MYROW.EQ.II ) .AND. ( MYCOL.EQ.JJ ) ) THEN
- H11 = A( ( ICOL1-1 )*LDA+IROW1 )
- IF( MODKM1.NE.0 ) THEN
- H21 = A( ( ICOL1-1 )*LDA+IROW1+1 )
- H12 = A( ICOL1*LDA+IROW1 )
- H22 = A( ICOL1*LDA+IROW1+1 )
- ELSE
- IF( NPROW.GT.1 ) THEN
- CALL SGERV2D( CONTXT, 1, 1, H21, 1, DOWN, MYCOL )
- ELSE
- H21 = A( ( ICOL1-1 )*LDA+IROW1+1 )
- END IF
- IF( NPCOL.GT.1 ) THEN
- CALL SGERV2D( CONTXT, 1, 1, H12, 1, MYROW, RIGHT )
- ELSE
- H12 = A( ICOL1*LDA+IROW1 )
- END IF
- IF( NUM.GT.1 ) THEN
- CALL SGERV2D( CONTXT, 1, 1, H22, 1, DOWN, RIGHT )
- ELSE
- H22 = A( ICOL1*LDA+IROW1+1 )
- END IF
- END IF
- H00 = HALF*( H11+H22 )
- H10 = H11*H22 - H12*H21
+ CALL PSELGET( 'All', ' ', H11, A, L, L, DESCA )
+ CALL PSELGET( 'All', ' ', H21, A, I, L, DESCA )
+ CALL PSELGET( 'All', ' ', H12, A, L, I, DESCA )
+ CALL PSELGET( 'All', ' ', H22, A, I, I, DESCA )
+ CALL SLANV2( H11, H12, H21, H22, WR( L ), WI( L ), WR( I ),
+ $ WI( I ), CS, SN )
+ CALL PSELSET( A, L, L, DESCA, H11 )
+ CALL PSELSET( A, I, L, DESCA, H21 )
+ CALL PSELSET( A, L, I, DESCA, H12 )
+ CALL PSELSET( A, I, I, DESCA, H22 )
+*
+* Transform H to the standard Schur form
+*
+ IF( WANTT ) THEN
+ IF(I .LT. N) CALL PSROT( N-I, A, L, I+1, DESCA, DESCA( M_ ),
+ $ A, I, I+1, DESCA, DESCA( M_ ), CS,
+ $ SN, WORK( VECSIDX+1 ),
+ $ LWORK-VECSIDX, IERR )
+ LTOP = 1
ELSE
- IF( MODKM1.EQ.0 ) THEN
- IF( ( NPROW.GT.1 ) .AND. ( MYCOL.EQ.JJ ) .AND.
- $ ( UP.EQ.II ) ) THEN
- CALL INFOG2L( I, I-1, DESCA, NPROW, NPCOL, MYROW,
- $ MYCOL, IROW1, ICOL1, ITMP1, ITMP2 )
- CALL SGESD2D( CONTXT, 1, 1,
- $ A( ( ICOL1-1 )*LDA+IROW1 ), 1, II, JJ )
- END IF
- IF( ( NPCOL.GT.1 ) .AND. ( LEFT.EQ.JJ ) .AND.
- $ ( MYROW.EQ.II ) ) THEN
- CALL INFOG2L( I-1, I, DESCA, NPROW, NPCOL, MYROW,
- $ MYCOL, IROW1, ICOL1, ITMP1, ITMP2 )
- CALL SGESD2D( CONTXT, 1, 1,
- $ A( ( ICOL1-1 )*LDA+IROW1 ), 1, II, JJ )
- END IF
- IF( ( NUM.GT.1 ) .AND. ( LEFT.EQ.JJ ) .AND.
- $ ( UP.EQ.II ) ) THEN
- CALL INFOG2L( I, I, DESCA, NPROW, NPCOL, MYROW, MYCOL,
- $ IROW1, ICOL1, ITMP1, ITMP2 )
- CALL SGESD2D( CONTXT, 1, 1,
- $ A( ( ICOL1-1 )*LDA+IROW1 ), 1, II, JJ )
- END IF
- END IF
- H00 = ZERO
- H10 = ZERO
+ LTOP = I1
END IF
- H21 = H00*H00 - H10
- IF( H21.GE.ZERO ) THEN
- H21 = SQRT( H21 )
- WR( I-1 ) = H00 + H21
- WI( I-1 ) = ZERO
- WR( I ) = H00 - H21
- WI( I ) = ZERO
- ELSE
- H21 = SQRT( ABS( H21 ) )
- WR( I-1 ) = H00
- WI( I-1 ) = H21
- WR( I ) = H00
- WI( I ) = -H21
+ IF (L .GT. LTOP) CALL PSROT( L-LTOP, A, LTOP, L, DESCA, 1, A,
+ $ LTOP, I, DESCA, 1, CS, SN,
+ $ WORK( VECSIDX+1 ), LWORK-VECSIDX,
+ $ IERR )
+ IF( WANTZ ) THEN
+ CALL PSROT( IHIZ-ILOZ+1, Z, ILOZ, L, DESCZ, 1, Z, ILOZ, I,
+ $ DESCZ, 1, CS, SN, WORK( VECSIDX+1 ),
+ $ LWORK-VECSIDX, IERR )
END IF
+ IF( NODE .NE. 0 ) THEN
+ WR( L ) = ZERO
+ WR( I ) = ZERO
+ WI( L ) = ZERO
+ WI( I ) = ZERO
+ ENDIF
ELSE
*
* Find the eigenvalues in H(L:I,L:I), L < I-1
*
- JBLK = I - L + 1
- IF( JBLK.LE.2*IBLK ) THEN
- CALL PSLACP3( I-L+1, L, A, DESCA, S1, 2*IBLK, 0, 0, 0 )
- CALL SLAHQR( .FALSE., .FALSE., JBLK, 1, JBLK, S1, 2*IBLK,
- $ WR( L ), WI( L ), 1, JBLK, Z, LDZ, IERR )
+ NH = I - L + 1
+ IF( NH .LE. LDS ) THEN
+ CALL PSLAQR4( WANTT, WANTZ, N, L, I, A, DESCA, WR, WI,
+ $ ILOZ, IHIZ, Z, DESCZ, WORK( S1+1 ), NH,
+ $ WORK( S2+1 ), NH, WORK( S3+1 ), 4*LDS*LDS,
+ $ INFO )
+ IF( INFO.NE.0 ) THEN
+ WORK( 1 ) = FLOAT( LWKOPT )
+ RETURN
+ END IF
IF( NODE.NE.0 ) THEN
*
* Erase the eigenvalues
@@ -2123,10 +2226,20 @@
GO TO 10
*
450 CONTINUE
- CALL SGSUM2D( CONTXT, 'All', ' ', N, 1, WR, N, -1, -1 )
- CALL SGSUM2D( CONTXT, 'All', ' ', N, 1, WI, N, -1, -1 )
+*
+ IF( NUM.GT.1 ) THEN
+ CALL SGSUM2D( CONTXT, 'All', ' ', IHI-ILO+1, 1, WR(ILO), N,
+ $ -1, -1 )
+ CALL SGSUM2D( CONTXT, 'All', ' ', IHI-ILO+1, 1, WI(ILO), N,
+ $ -1, -1 )
+ END IF
+*
+ WORK( 1 ) = FLOAT( LWKOPT )
+ IWORK( 1 ) = TOTIT
+ IWORK( 2 ) = TOTSW
+ IWORK( 3 ) = TOTNS
RETURN
*
-* END OF PSLAHQR
+* END OF PSLAQR1
*
END
diff --git a/SRC/pslaqr2.f b/SRC/pslaqr2.f
new file mode 100644
index 0000000..20a2afc
--- /dev/null
+++ b/SRC/pslaqr2.f
@@ -0,0 +1,671 @@
+ SUBROUTINE PSLAQR2( WANTT, WANTZ, N, KTOP, KBOT, NW, A, DESCA,
+ $ ILOZ, IHIZ, Z, DESCZ, NS, ND, SR, SI, T, LDT,
+ $ V, LDV, WR, WI, WORK, LWORK )
+*
+* Contribution from the Department of Computing Science and HPC2N,
+* Umea University, Sweden
+*
+* -- ScaLAPACK routine (version 2.0.2) --
+* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver
+* May 1 2012
+*
+ IMPLICIT NONE
+*
+* .. Scalar Arguments ..
+ INTEGER IHIZ, ILOZ, KBOT, KTOP, LDT, LDV, LWORK, N, ND,
+ $ NS, NW
+ LOGICAL WANTT, WANTZ
+* ..
+* .. Array Arguments ..
+ INTEGER DESCA( * ), DESCZ( * )
+ REAL A( * ), SI( KBOT ), SR( KBOT ), T( LDT, * ),
+ $ V( LDV, * ), WORK( * ), WI( * ), WR( * ),
+ $ Z( * )
+* ..
+*
+* Purpose
+* =======
+*
+* Aggressive early deflation:
+*
+* PSLAQR2 accepts as input an upper Hessenberg matrix A and performs an
+* orthogonal similarity transformation designed to detect and deflate
+* fully converged eigenvalues from a trailing principal submatrix. On
+* output A has been overwritten by a new Hessenberg matrix that is a
+* perturbation of an orthogonal similarity transformation of A. It is
+* to be hoped that the final version of H has many zero subdiagonal
+* entries.
+*
+* This routine handles small deflation windows which is affordable by
+* one processor. Normally, it is called by PSLAQR1. All the inputs are
+* assumed to be valid without checking.
+*
+* Notes
+* =====
+*
+* Each global data object is described by an associated description
+* vector. This vector stores the information required to establish
+* the mapping between an object element and its corresponding process
+* and memory location.
+*
+* Let A be a generic term for any 2D block cyclicly distributed array.
+* Such a global array has an associated description vector DESCA.
+* In the following comments, the character _ should be read as
+* "of the global array".
+*
+* NOTATION STORED IN EXPLANATION
+* --------------- -------------- --------------------------------------
+* DTYPE_A(global) DESCA( DTYPE_ )The descriptor type. In this case,
+* DTYPE_A = 1.
+* CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating
+* the BLACS process grid A is distribu-
+* ted over. The context itself is glo-
+* bal, but the handle (the integer
+* value) may vary.
+* M_A (global) DESCA( M_ ) The number of rows in the global
+* array A.
+* N_A (global) DESCA( N_ ) The number of columns in the global
+* array A.
+* MB_A (global) DESCA( MB_ ) The blocking factor used to distribute
+* the rows of the array.
+* NB_A (global) DESCA( NB_ ) The blocking factor used to distribute
+* the columns of the array.
+* RSRC_A (global) DESCA( RSRC_ ) The process row over which the first
+* row of the array A is distributed.
+* CSRC_A (global) DESCA( CSRC_ ) The process column over which the
+* first column of the array A is
+* distributed.
+* LLD_A (local) DESCA( LLD_ ) The leading dimension of the local
+* array. LLD_A >= MAX(1,LOCr(M_A)).
+*
+* Let K be the number of rows or columns of a distributed matrix,
+* and assume that its process grid has dimension p x q.
+* LOCr( K ) denotes the number of elements of K that a process
+* would receive if K were distributed over the p processes of its
+* process column.
+* Similarly, LOCc( K ) denotes the number of elements of K that a
+* process would receive if K were distributed over the q processes of
+* its process row.
+* The values of LOCr() and LOCc() may be determined via a call to the
+* ScaLAPACK tool function, NUMROC:
+* LOCr( M ) = NUMROC( M, MB_A, MYROW, RSRC_A, NPROW ),
+* LOCc( N ) = NUMROC( N, NB_A, MYCOL, CSRC_A, NPCOL ).
+* An upper bound for these quantities may be computed by:
+* LOCr( M ) <= ceil( ceil(M/MB_A)/NPROW )*MB_A
+* LOCc( N ) <= ceil( ceil(N/NB_A)/NPCOL )*NB_A
+*
+* Arguments
+* =========
+*
+* WANTT (global input) LOGICAL
+* If .TRUE., then the Hessenberg matrix H is fully updated
+* so that the quasi-triangular Schur factor may be
+* computed (in cooperation with the calling subroutine).
+* If .FALSE., then only enough of H is updated to preserve
+* the eigenvalues.
+*
+* WANTZ (global input) LOGICAL
+* If .TRUE., then the orthogonal matrix Z is updated so
+* so that the orthogonal Schur factor may be computed
+* (in cooperation with the calling subroutine).
+* If .FALSE., then Z is not referenced.
+*
+* N (global input) INTEGER
+* The order of the matrix H and (if WANTZ is .TRUE.) the
+* order of the orthogonal matrix Z.
+*
+* KTOP (global input) INTEGER
+* KBOT (global input) INTEGER
+* It is assumed without a check that either
+* KBOT = N or H(KBOT+1,KBOT)=0. KBOT and KTOP together
+* determine an isolated block along the diagonal of the
+* Hessenberg matrix. However, H(KTOP,KTOP-1)=0 is not
+* essentially necessary if WANTT is .TRUE. .
+*
+* NW (global input) INTEGER
+* Deflation window size. 1 .LE. NW .LE. (KBOT-KTOP+1).
+* Normally NW .GE. 3 if PSLAQR2 is called by PSLAQR1.
+*
+* A (local input/output) REAL array, dimension
+* (DESCH(LLD_),*)
+* On input the initial N-by-N section of A stores the
+* Hessenberg matrix undergoing aggressive early deflation.
+* On output A 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.
+*
+* DESCA (global and local input) INTEGER array of dimension DLEN_.
+* The array descriptor for the distributed matrix A.
+*
+* ILOZ (global input) INTEGER
+* IHIZ (global input) INTEGER
+* Specify the rows of Z to which transformations must be
+* applied if WANTZ is .TRUE.. 1 .LE. ILOZ .LE. IHIZ .LE. N.
+*
+* Z (input/output) REAL array, dimension
+* (DESCH(LLD_),*)
+* IF WANTZ is .TRUE., then on output, the orthogonal
+* similarity transformation mentioned above has been
+* accumulated into Z(ILOZ:IHIZ,ILO:IHI) from the right.
+* If WANTZ is .FALSE., then Z is unreferenced.
+*
+* DESCZ (global and local input) INTEGER array of dimension DLEN_.
+* The array descriptor for the distributed matrix Z.
+*
+* NS (global output) INTEGER
+* The number of unconverged (ie approximate) eigenvalues
+* returned in SR and SI that may be used as shifts by the
+* calling subroutine.
+*
+* ND (global output) INTEGER
+* The number of converged eigenvalues uncovered by this
+* subroutine.
+*
+* SR (global output) REAL array, dimension KBOT
+* SI (global output) REAL array, dimension KBOT
+* On output, the real and imaginary parts of approximate
+* eigenvalues that may be used for shifts are stored in
+* SR(KBOT-ND-NS+1) through SR(KBOT-ND) and
+* SI(KBOT-ND-NS+1) through SI(KBOT-ND), respectively.
+* On proc #0, 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. On other
+* processors, these entries are set to zero.
+*
+* T (local workspace) REAL array, dimension LDT*NW.
+*
+* LDT (local input) INTEGER
+* The leading dimension of the array T.
+* LDT >= NW.
+*
+* V (local workspace) REAL array, dimension LDV*NW.
+*
+* LDV (local input) INTEGER
+* The leading dimension of the array V.
+* LDV >= NW.
+*
+* WR (local workspace) REAL array, dimension KBOT.
+* WI (local workspace) REAL array, dimension KBOT.
+*
+* WORK (local workspace) REAL array, dimension LWORK.
+*
+* LWORK (local input) INTEGER
+* WORK(LWORK) is a local array and LWORK is assumed big enough
+* so that LWORK >= NW*NW.
+*
+* ================================================================
+* Implemented by
+* Meiyue Shao, Department of Computing Science and HPC2N,
+* Umea University, Sweden
+*
+* ================================================================
+* References:
+* B. Kagstrom, D. Kressner, and M. Shao,
+* On Aggressive Early Deflation in Parallel Variants of the QR
+* Algorithm.
+* Para 2010, to appear.
+*
+* ================================================================
+* .. Parameters ..
+ INTEGER BLOCK_CYCLIC_2D, CSRC_, CTXT_, DLEN_, DTYPE_,
+ $ LLD_, MB_, M_, NB_, N_, RSRC_
+ PARAMETER ( BLOCK_CYCLIC_2D = 1, DLEN_ = 9, DTYPE_ = 1,
+ $ CTXT_ = 2, M_ = 3, N_ = 4, MB_ = 5, NB_ = 6,
+ $ RSRC_ = 7, CSRC_ = 8, LLD_ = 9 )
+ REAL ZERO, ONE
+ PARAMETER ( ZERO = 0.0, ONE = 1.0 )
+* ..
+* .. Local Scalars ..
+ INTEGER CONTXT, HBL, I, I1, I2, IAFIRST, ICOL, ICOL1,
+ $ ICOL2, INFO, II, IROW, IROW1, IROW2, ITMP1,
+ $ ITMP2, J, JAFIRST, JJ, K, L, LDA, LDZ, LLDTMP,
+ $ MYCOL, MYROW, NODE, NPCOL, NPROW, DBLK,
+ $ HSTEP, VSTEP, KKROW, KKCOL, KLN, LTOP, LEFT,
+ $ RIGHT, UP, DOWN, D1, D2
+* ..
+* .. Local Arrays ..
+ INTEGER DESCT( 9 ), DESCV( 9 ), DESCWH( 9 ),
+ $ DESCWV( 9 )
+* ..
+* .. External Functions ..
+ INTEGER NUMROC
+ EXTERNAL NUMROC
+* ..
+* .. External Subroutines ..
+ EXTERNAL BLACS_GRIDINFO, INFOG2L, SLASET,
+ $ SLAQR3, DESCINIT, PSGEMM, PSGEMR2D, SGEMM,
+ $ SLAMOV, SGESD2D, SGERV2D, SGEBS2D, SGEBR2D,
+ $ IGEBS2D, IGEBR2D
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, MIN, MOD
+* ..
+* .. Executable Statements ..
+*
+ INFO = 0
+*
+ IF( N.EQ.0 )
+ $ RETURN
+*
+* NODE (IAFIRST,JAFIRST) OWNS A(1,1)
+*
+ HBL = DESCA( MB_ )
+ CONTXT = DESCA( CTXT_ )
+ LDA = DESCA( LLD_ )
+ IAFIRST = DESCA( RSRC_ )
+ JAFIRST = DESCA( CSRC_ )
+ LDZ = DESCZ( LLD_ )
+ CALL BLACS_GRIDINFO( CONTXT, NPROW, NPCOL, MYROW, MYCOL )
+ NODE = MYROW*NPCOL + MYCOL
+ LEFT = MOD( MYCOL+NPCOL-1, NPCOL )
+ RIGHT = MOD( MYCOL+1, NPCOL )
+ UP = MOD( MYROW+NPROW-1, NPROW )
+ DOWN = MOD( MYROW+1, NPROW )
+*
+* I1 and I2 are the indices of the first row and last column of A
+* to which transformations must be applied.
+*
+ I = KBOT
+ L = KTOP
+ IF( WANTT ) THEN
+ I1 = 1
+ I2 = N
+ LTOP = 1
+ ELSE
+ I1 = L
+ I2 = I
+ LTOP = L
+ END IF
+*
+* Begin Aggressive Early Deflation.
+*
+ DBLK = NW
+ CALL INFOG2L( I-DBLK+1, I-DBLK+1, DESCA, NPROW, NPCOL, MYROW,
+ $ MYCOL, IROW, ICOL, II, JJ )
+ IF ( MYROW .EQ. II ) THEN
+ CALL DESCINIT( DESCT, DBLK, DBLK, DBLK, DBLK, II, JJ, CONTXT,
+ $ LDT, INFO )
+ CALL DESCINIT( DESCV, DBLK, DBLK, DBLK, DBLK, II, JJ, CONTXT,
+ $ LDV, INFO )
+ ELSE
+ CALL DESCINIT( DESCT, DBLK, DBLK, DBLK, DBLK, II, JJ, CONTXT,
+ $ 1, INFO )
+ CALL DESCINIT( DESCV, DBLK, DBLK, DBLK, DBLK, II, JJ, CONTXT,
+ $ 1, INFO )
+ END IF
+ CALL PSGEMR2D( DBLK, DBLK, A, I-DBLK+1, I-DBLK+1, DESCA, T, 1, 1,
+ $ DESCT, CONTXT )
+ IF ( MYROW .EQ. II .AND. MYCOL .EQ. JJ ) THEN
+ CALL SLASET( 'All', DBLK, DBLK, ZERO, ONE, V, LDV )
+ CALL SLAQR3( .TRUE., .TRUE., DBLK, 1, DBLK, DBLK-1, T, LDT, 1,
+ $ DBLK, V, LDV, NS, ND, WR, WI, WORK, DBLK, DBLK,
+ $ WORK( DBLK*DBLK+1 ), DBLK, DBLK, WORK( 2*DBLK*DBLK+1 ),
+ $ DBLK, WORK( 3*DBLK*DBLK+1 ), LWORK-3*DBLK*DBLK )
+ CALL SGEBS2D( CONTXT, 'All', ' ', DBLK, DBLK, V, LDV )
+ CALL IGEBS2D( CONTXT, 'All', ' ', 1, 1, ND, 1 )
+ ELSE
+ CALL SGEBR2D( CONTXT, 'All', ' ', DBLK, DBLK, V, LDV, II, JJ )
+ CALL IGEBR2D( CONTXT, 'All', ' ', 1, 1, ND, 1, II, JJ )
+ END IF
+*
+ IF( ND .GT. 0 ) THEN
+*
+* Copy the local matrix back to the diagonal block.
+*
+ CALL PSGEMR2D( DBLK, DBLK, T, 1, 1, DESCT, A, I-DBLK+1,
+ $ I-DBLK+1, DESCA, CONTXT )
+*
+* Update T and Z.
+*
+ IF( MOD( I-DBLK, HBL )+DBLK .LE. HBL ) THEN
+*
+* Simplest case: the deflation window is located on one
+* processor.
+* Call SGEMM directly to perform the update.
+*
+ HSTEP = LWORK / DBLK
+ VSTEP = HSTEP
+*
+* Update horizontal slab in A.
+*
+ IF( WANTT ) THEN
+ CALL INFOG2L( I-DBLK+1, I+1, DESCA, NPROW, NPCOL, MYROW,
+ $ MYCOL, IROW, ICOL, II, JJ )
+ IF( MYROW .EQ. II ) THEN
+ ICOL1 = NUMROC( N, HBL, MYCOL, JAFIRST, NPCOL )
+ DO 10 KKCOL = ICOL, ICOL1, HSTEP
+ KLN = MIN( HSTEP, ICOL1-KKCOL+1 )
+ CALL SGEMM( 'T', 'N', DBLK, KLN, DBLK, ONE, V,
+ $ LDV, A( IROW+(KKCOL-1)*LDA ), LDA, ZERO, WORK,
+ $ DBLK )
+ CALL SLAMOV( 'A', DBLK, KLN, WORK, DBLK,
+ $ A( IROW+(KKCOL-1)*LDA ), LDA )
+ 10 CONTINUE
+ END IF
+ END IF
+*
+* Update vertical slab in A.
+*
+ CALL INFOG2L( LTOP, I-DBLK+1, DESCA, NPROW, NPCOL, MYROW,
+ $ MYCOL, IROW, ICOL, II, JJ )
+ IF( MYCOL .EQ. JJ ) THEN
+ CALL INFOG2L( I-DBLK, I-DBLK+1, DESCA, NPROW, NPCOL,
+ $ MYROW, MYCOL, IROW1, ICOL1, ITMP1, ITMP2 )
+ IF( MYROW .NE. ITMP1 ) IROW1 = IROW1-1
+ DO 20 KKROW = IROW, IROW1, VSTEP
+ KLN = MIN( VSTEP, IROW1-KKROW+1 )
+ CALL SGEMM( 'N', 'N', KLN, DBLK, DBLK, ONE,
+ $ A( KKROW+(ICOL-1)*LDA ), LDA, V, LDV, ZERO, WORK,
+ $ KLN )
+ CALL SLAMOV( 'A', KLN, DBLK, WORK, KLN,
+ $ A( KKROW+(ICOL-1)*LDA ), LDA )
+ 20 CONTINUE
+ END IF
+*
+* Update vertical slab in Z.
+*
+ IF( WANTZ ) THEN
+ CALL INFOG2L( ILOZ, I-DBLK+1, DESCZ, NPROW, NPCOL, MYROW,
+ $ MYCOL, IROW, ICOL, II, JJ )
+ IF( MYCOL .EQ. JJ ) THEN
+ CALL INFOG2L( IHIZ, I-DBLK+1, DESCZ, NPROW, NPCOL,
+ $ MYROW, MYCOL, IROW1, ICOL1, ITMP1, ITMP2 )
+ IF( MYROW .NE. ITMP1 ) IROW1 = IROW1-1
+ DO 30 KKROW = IROW, IROW1, VSTEP
+ KLN = MIN( VSTEP, IROW1-KKROW+1 )
+ CALL SGEMM( 'N', 'N', KLN, DBLK, DBLK, ONE,
+ $ Z( KKROW+(ICOL-1)*LDZ ), LDZ, V, LDV, ZERO,
+ $ WORK, KLN )
+ CALL SLAMOV( 'A', KLN, DBLK, WORK, KLN,
+ $ Z( KKROW+(ICOL-1)*LDZ ), LDZ )
+ 30 CONTINUE
+ END IF
+ END IF
+*
+ ELSE IF( MOD( I-DBLK, HBL )+DBLK .LE. 2*HBL ) THEN
+*
+* More complicated case: the deflation window lay on a 2x2
+* processor mesh.
+* Call SGEMM locally and communicate by pair.
+*
+ D1 = HBL - MOD( I-DBLK, HBL )
+ D2 = DBLK - D1
+ HSTEP = LWORK / DBLK
+ VSTEP = HSTEP
+*
+* Update horizontal slab in A.
+*
+ IF( WANTT ) THEN
+ CALL INFOG2L( I-DBLK+1, I+1, DESCA, NPROW, NPCOL, MYROW,
+ $ MYCOL, IROW, ICOL, II, JJ )
+ IF( MYROW .EQ. UP ) THEN
+ IF( MYROW .EQ. II ) THEN
+ ICOL1 = NUMROC( N, HBL, MYCOL, JAFIRST, NPCOL )
+ DO 40 KKCOL = ICOL, ICOL1, HSTEP
+ KLN = MIN( HSTEP, ICOL1-KKCOL+1 )
+ CALL SGEMM( 'T', 'N', DBLK, KLN, DBLK, ONE, V,
+ $ DBLK, A( IROW+(KKCOL-1)*LDA ), LDA, ZERO,
+ $ WORK, DBLK )
+ CALL SLAMOV( 'A', DBLK, KLN, WORK, DBLK,
+ $ A( IROW+(KKCOL-1)*LDA ), LDA )
+ 40 CONTINUE
+ END IF
+ ELSE
+ IF( MYROW .EQ. II ) THEN
+ ICOL1 = NUMROC( N, HBL, MYCOL, JAFIRST, NPCOL )
+ DO 50 KKCOL = ICOL, ICOL1, HSTEP
+ KLN = MIN( HSTEP, ICOL1-KKCOL+1 )
+ CALL SGEMM( 'T', 'N', D2, KLN, D1, ONE,
+ $ V( 1, D1+1 ), LDV, A( IROW+(KKCOL-1)*LDA ),
+ $ LDA, ZERO, WORK( D1+1 ), DBLK )
+ CALL SGESD2D( CONTXT, D2, KLN, WORK( D1+1 ),
+ $ DBLK, DOWN, MYCOL )
+ CALL SGERV2D( CONTXT, D1, KLN, WORK, DBLK, DOWN,
+ $ MYCOL )
+ CALL SGEMM( 'T', 'N', D1, KLN, D1, ONE,
+ $ V, LDV, A( IROW+(KKCOL-1)*LDA ), LDA, ONE,
+ $ WORK, DBLK )
+ CALL SLAMOV( 'A', D1, KLN, WORK, DBLK,
+ $ A( IROW+(KKCOL-1)*LDA ), LDA )
+ 50 CONTINUE
+ ELSE IF( UP .EQ. II ) THEN
+ ICOL1 = NUMROC( N, HBL, MYCOL, JAFIRST, NPCOL )
+ DO 60 KKCOL = ICOL, ICOL1, HSTEP
+ KLN = MIN( HSTEP, ICOL1-KKCOL+1 )
+ CALL SGEMM( 'T', 'N', D1, KLN, D2, ONE,
+ $ V( D1+1, 1 ), LDV, A( IROW+(KKCOL-1)*LDA ),
+ $ LDA, ZERO, WORK, DBLK )
+ CALL SGESD2D( CONTXT, D1, KLN, WORK, DBLK, UP,
+ $ MYCOL )
+ CALL SGERV2D( CONTXT, D2, KLN, WORK( D1+1 ),
+ $ DBLK, UP, MYCOL )
+ CALL SGEMM( 'T', 'N', D2, KLN, D2, ONE,
+ $ V( D1+1, D1+1 ), LDV,
+ $ A( IROW+(KKCOL-1)*LDA ), LDA, ONE,
+ $ WORK( D1+1 ), DBLK )
+ CALL SLAMOV( 'A', D2, KLN, WORK( D1+1 ), DBLK,
+ $ A( IROW+(KKCOL-1)*LDA ), LDA )
+ 60 CONTINUE
+ END IF
+ END IF
+ END IF
+*
+* Update vertical slab in A.
+*
+ CALL INFOG2L( LTOP, I-DBLK+1, DESCA, NPROW, NPCOL, MYROW,
+ $ MYCOL, IROW, ICOL, II, JJ )
+ IF( MYCOL .EQ. LEFT ) THEN
+ IF( MYCOL .EQ. JJ ) THEN
+ CALL INFOG2L( I-DBLK, I-DBLK+1, DESCA, NPROW, NPCOL,
+ $ MYROW, MYCOL, IROW1, ICOL1, ITMP1, ITMP2 )
+ IF( MYROW .NE. ITMP1 ) IROW1 = IROW1-1
+ DO 70 KKROW = IROW, IROW1, VSTEP
+ KLN = MIN( VSTEP, IROW1-KKROW+1 )
+ CALL SGEMM( 'N', 'N', KLN, DBLK, DBLK, ONE,
+ $ A( KKROW+(ICOL-1)*LDA ), LDA, V, LDV, ZERO,
+ $ WORK, KLN )
+ CALL SLAMOV( 'A', KLN, DBLK, WORK, KLN,
+ $ A( KKROW+(ICOL-1)*LDA ), LDA )
+ 70 CONTINUE
+ END IF
+ ELSE
+ IF( MYCOL .EQ. JJ ) THEN
+ CALL INFOG2L( I-DBLK, I-DBLK+1, DESCA, NPROW, NPCOL,
+ $ MYROW, MYCOL, IROW1, ICOL1, ITMP1, ITMP2 )
+ IF( MYROW .NE. ITMP1 ) IROW1 = IROW1-1
+ DO 80 KKROW = IROW, IROW1, VSTEP
+ KLN = MIN( VSTEP, IROW1-KKROW+1 )
+ CALL SGEMM( 'N', 'N', KLN, D2, D1, ONE,
+ $ A( KKROW+(ICOL-1)*LDA ), LDA,
+ $ V( 1, D1+1 ), LDV, ZERO, WORK( 1+D1*KLN ),
+ $ KLN )
+ CALL SGESD2D( CONTXT, KLN, D2, WORK( 1+D1*KLN ),
+ $ KLN, MYROW, RIGHT )
+ CALL SGERV2D( CONTXT, KLN, D1, WORK, KLN, MYROW,
+ $ RIGHT )
+ CALL SGEMM( 'N', 'N', KLN, D1, D1, ONE,
+ $ A( KKROW+(ICOL-1)*LDA ), LDA, V, LDV, ONE,
+ $ WORK, KLN )
+ CALL SLAMOV( 'A', KLN, D1, WORK, KLN,
+ $ A( KKROW+(ICOL-1)*LDA ), LDA )
+ 80 CONTINUE
+ ELSE IF ( LEFT .EQ. JJ ) THEN
+ CALL INFOG2L( I-DBLK, I-DBLK+1, DESCA, NPROW, NPCOL,
+ $ MYROW, MYCOL, IROW1, ICOL1, ITMP1, ITMP2 )
+ IF( MYROW .NE. ITMP1 ) IROW1 = IROW1-1
+ DO 90 KKROW = IROW, IROW1, VSTEP
+ KLN = MIN( VSTEP, IROW1-KKROW+1 )
+ CALL SGEMM( 'N', 'N', KLN, D1, D2, ONE,
+ $ A( KKROW+(ICOL-1)*LDA ), LDA, V( D1+1, 1 ),
+ $ LDV, ZERO, WORK, KLN )
+ CALL SGESD2D( CONTXT, KLN, D1, WORK, KLN, MYROW,
+ $ LEFT )
+ CALL SGERV2D( CONTXT, KLN, D2, WORK( 1+D1*KLN ),
+ $ KLN, MYROW, LEFT )
+ CALL SGEMM( 'N', 'N', KLN, D2, D2, ONE,
+ $ A( KKROW+(ICOL-1)*LDA ), LDA, V( D1+1, D1+1 ),
+ $ LDV, ONE, WORK( 1+D1*KLN ), KLN )
+ CALL SLAMOV( 'A', KLN, D2, WORK( 1+D1*KLN ), KLN,
+ $ A( KKROW+(ICOL-1)*LDA ), LDA )
+ 90 CONTINUE
+ END IF
+ END IF
+*
+* Update vertical slab in Z.
+*
+ IF( WANTZ ) THEN
+ CALL INFOG2L( ILOZ, I-DBLK+1, DESCZ, NPROW, NPCOL, MYROW,
+ $ MYCOL, IROW, ICOL, II, JJ )
+ IF( MYCOL .EQ. LEFT ) THEN
+ IF( MYCOL .EQ. JJ ) THEN
+ CALL INFOG2L( IHIZ, I-DBLK+1, DESCZ, NPROW, NPCOL,
+ $ MYROW, MYCOL, IROW1, ICOL1, ITMP1, ITMP2 )
+ IF( MYROW .NE. ITMP1 ) IROW1 = IROW1-1
+ DO 100 KKROW = IROW, IROW1, VSTEP
+ KLN = MIN( VSTEP, IROW1-KKROW+1 )
+ CALL SGEMM( 'N', 'N', KLN, DBLK, DBLK, ONE,
+ $ Z( KKROW+(ICOL-1)*LDZ ), LDZ, V, LDV, ZERO,
+ $ WORK, KLN )
+ CALL SLAMOV( 'A', KLN, DBLK, WORK, KLN,
+ $ Z( KKROW+(ICOL-1)*LDZ ), LDZ )
+ 100 CONTINUE
+ END IF
+ ELSE
+ IF( MYCOL .EQ. JJ ) THEN
+ CALL INFOG2L( IHIZ, I-DBLK+1, DESCZ, NPROW, NPCOL,
+ $ MYROW, MYCOL, IROW1, ICOL1, ITMP1, ITMP2 )
+ IF( MYROW .NE. ITMP1 ) IROW1 = IROW1-1
+ DO 110 KKROW = IROW, IROW1, VSTEP
+ KLN = MIN( VSTEP, IROW1-KKROW+1 )
+ CALL SGEMM( 'N', 'N', KLN, D2, D1, ONE,
+ $ Z( KKROW+(ICOL-1)*LDZ ), LDZ,
+ $ V( 1, D1+1 ), LDV, ZERO, WORK( 1+D1*KLN ),
+ $ KLN )
+ CALL SGESD2D( CONTXT, KLN, D2, WORK( 1+D1*KLN ),
+ $ KLN, MYROW, RIGHT )
+ CALL SGERV2D( CONTXT, KLN, D1, WORK, KLN, MYROW,
+ $ RIGHT )
+ CALL SGEMM( 'N', 'N', KLN, D1, D1, ONE,
+ $ Z( KKROW+(ICOL-1)*LDZ ), LDZ, V, LDV, ONE,
+ $ WORK, KLN )
+ CALL SLAMOV( 'A', KLN, D1, WORK, KLN,
+ $ Z( KKROW+(ICOL-1)*LDZ ), LDZ )
+ 110 CONTINUE
+ ELSE IF( LEFT .EQ. JJ ) THEN
+ CALL INFOG2L( IHIZ, I-DBLK+1, DESCZ, NPROW, NPCOL,
+ $ MYROW, MYCOL, IROW1, ICOL1, ITMP1, ITMP2 )
+ IF( MYROW .NE. ITMP1 ) IROW1 = IROW1-1
+ DO 120 KKROW = IROW, IROW1, VSTEP
+ KLN = MIN( VSTEP, IROW1-KKROW+1 )
+ CALL SGEMM( 'N', 'N', KLN, D1, D2, ONE,
+ $ Z( KKROW+(ICOL-1)*LDZ ), LDZ,
+ $ V( D1+1, 1 ), LDV, ZERO, WORK, KLN )
+ CALL SGESD2D( CONTXT, KLN, D1, WORK, KLN, MYROW,
+ $ LEFT )
+ CALL SGERV2D( CONTXT, KLN, D2, WORK( 1+D1*KLN ),
+ $ KLN, MYROW, LEFT )
+ CALL SGEMM( 'N', 'N', KLN, D2, D2, ONE,
+ $ Z( KKROW+(ICOL-1)*LDZ ), LDZ,
+ $ V( D1+1, D1+1 ), LDV, ONE,
+ $ WORK( 1+D1*KLN ), KLN )
+ CALL SLAMOV( 'A', KLN, D2, WORK( 1+D1*KLN ),
+ $ KLN, Z( KKROW+(ICOL-1)*LDZ ), LDZ )
+ 120 CONTINUE
+ END IF
+ END IF
+ END IF
+*
+ ELSE
+*
+* Most complicated case: the deflation window lay across the
+* border of the processor mesh.
+* Treat V as a distributed matrix and call PSGEMM.
+*
+ HSTEP = LWORK / DBLK * NPCOL
+ VSTEP = LWORK / DBLK * NPROW
+ LLDTMP = NUMROC( DBLK, DBLK, MYROW, 0, NPROW )
+ LLDTMP = MAX( 1, LLDTMP )
+ CALL DESCINIT( DESCV, DBLK, DBLK, DBLK, DBLK, 0, 0, CONTXT,
+ $ LLDTMP, INFO )
+ CALL DESCINIT( DESCWH, DBLK, HSTEP, DBLK, LWORK / DBLK, 0,
+ $ 0, CONTXT, LLDTMP, INFO )
+*
+* Update horizontal slab in A.
+*
+ IF( WANTT ) THEN
+ DO 130 KKCOL = I+1, N, HSTEP
+ KLN = MIN( HSTEP, N-KKCOL+1 )
+ CALL PSGEMM( 'T', 'N', DBLK, KLN, DBLK, ONE, V, 1, 1,
+ $ DESCV, A, I-DBLK+1, KKCOL, DESCA, ZERO, WORK, 1,
+ $ 1, DESCWH )
+ CALL PSGEMR2D( DBLK, KLN, WORK, 1, 1, DESCWH, A,
+ $ I-DBLK+1, KKCOL, DESCA, CONTXT )
+ 130 CONTINUE
+ END IF
+*
+* Update vertical slab in A.
+*
+ DO 140 KKROW = LTOP, I-DBLK, VSTEP
+ KLN = MIN( VSTEP, I-DBLK-KKROW+1 )
+ LLDTMP = NUMROC( KLN, LWORK / DBLK, MYROW, 0, NPROW )
+ LLDTMP = MAX( 1, LLDTMP )
+ CALL DESCINIT( DESCWV, KLN, DBLK, LWORK / DBLK, DBLK, 0,
+ $ 0, CONTXT, LLDTMP, INFO )
+ CALL PSGEMM( 'N', 'N', KLN, DBLK, DBLK, ONE, A, KKROW,
+ $ I-DBLK+1, DESCA, V, 1, 1, DESCV, ZERO, WORK, 1, 1,
+ $ DESCWV )
+ CALL PSGEMR2D( KLN, DBLK, WORK, 1, 1, DESCWV, A, KKROW,
+ $ I-DBLK+1, DESCA, CONTXT )
+ 140 CONTINUE
+*
+* Update vertical slab in Z.
+*
+ IF( WANTZ ) THEN
+ DO 150 KKROW = ILOZ, IHIZ, VSTEP
+ KLN = MIN( VSTEP, IHIZ-KKROW+1 )
+ LLDTMP = NUMROC( KLN, LWORK / DBLK, MYROW, 0, NPROW )
+ LLDTMP = MAX( 1, LLDTMP )
+ CALL DESCINIT( DESCWV, KLN, DBLK, LWORK / DBLK, DBLK,
+ $ 0, 0, CONTXT, LLDTMP, INFO )
+ CALL PSGEMM( 'N', 'N', KLN, DBLK, DBLK, ONE, Z, KKROW,
+ $ I-DBLK+1, DESCZ, V, 1, 1, DESCV, ZERO, WORK, 1,
+ $ 1, DESCWV )
+ CALL PSGEMR2D( KLN, DBLK, WORK, 1, 1, DESCWV, Z,
+ $ KKROW, I-DBLK+1, DESCZ, CONTXT )
+ 150 CONTINUE
+ END IF
+ END IF
+*
+* Extract converged eigenvalues.
+*
+ II = 0
+ 160 CONTINUE
+ IF( II .EQ. ND-1 .OR. WI( DBLK-II ) .EQ. ZERO ) THEN
+ IF( NODE .EQ. 0 ) THEN
+ SR( I-II ) = WR( DBLK-II )
+ ELSE
+ SR( I-II ) = ZERO
+ END IF
+ SI( I-II ) = ZERO
+ II = II + 1
+ ELSE
+ IF( NODE .EQ. 0 ) THEN
+ SR( I-II-1 ) = WR( DBLK-II-1 )
+ SR( I-II ) = WR( DBLK-II )
+ SI( I-II-1 ) = WI( DBLK-II-1 )
+ SI( I-II ) = WI( DBLK-II )
+ ELSE
+ SR( I-II-1 ) = ZERO
+ SR( I-II ) = ZERO
+ SI( I-II-1 ) = ZERO
+ SI( I-II ) = ZERO
+ END IF
+ II = II + 2
+ END IF
+ IF( II .LT. ND ) GOTO 160
+ END IF
+*
+* END OF PSLAQR2
+*
+ END
diff --git a/SRC/pslaqr3.f b/SRC/pslaqr3.f
new file mode 100644
index 0000000..5b87527
--- /dev/null
+++ b/SRC/pslaqr3.f
@@ -0,0 +1,1156 @@
+ RECURSIVE SUBROUTINE PSLAQR3( WANTT, WANTZ, N, KTOP, KBOT, NW, H,
+ $ DESCH, ILOZ, IHIZ, Z, DESCZ, NS, ND,
+ $ SR, SI, V, DESCV, NH, T, DESCT, NV,
+ $ WV, DESCW, WORK, LWORK, IWORK,
+ $ LIWORK, RECLEVEL )
+*
+* Contribution from the Department of Computing Science and HPC2N,
+* Umea University, Sweden
+*
+* -- ScaLAPACK auxiliary routine (version 2.0.1) --
+* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
+* Univ. of Colorado Denver and University of California, Berkeley.
+* January, 2012
+*
+ IMPLICIT NONE
+*
+* .. Scalar Arguments ..
+ INTEGER IHIZ, ILOZ, KBOT, KTOP, LWORK, N, ND, NH, NS,
+ $ NV, NW, LIWORK, RECLEVEL
+ LOGICAL WANTT, WANTZ
+* ..
+* .. Array Arguments ..
+ INTEGER DESCH( * ), DESCZ( * ), DESCT( * ), DESCV( * ),
+ $ DESCW( * ), IWORK( * )
+ REAL H( * ), SI( KBOT ), SR( KBOT ), T( * ),
+ $ V( * ), WORK( * ), WV( * ),
+ $ Z( * )
+* ..
+*
+* Purpose
+* =======
+*
+* 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 overwritten 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.
+*
+* Notes
+* =====
+*
+* Each global data object is described by an associated description
+* vector. This vector stores the information required to establish
+* the mapping between an object element and its corresponding process
+* and memory location.
+*
+* Let A be a generic term for any 2D block cyclicly distributed array.
+* Such a global array has an associated description vector DESCA.
+* In the following comments, the character _ should be read as
+* "of the global array".
+*
+* NOTATION STORED IN EXPLANATION
+* --------------- -------------- --------------------------------------
+* DTYPE_A(global) DESCA( DTYPE_ )The descriptor type. In this case,
+* DTYPE_A = 1.
+* CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating
+* the BLACS process grid A is distribu-
+* ted over. The context itself is glo-
+* bal, but the handle (the integer
+* value) may vary.
+* M_A (global) DESCA( M_ ) The number of rows in the global
+* array A.
+* N_A (global) DESCA( N_ ) The number of columns in the global
+* array A.
+* MB_A (global) DESCA( MB_ ) The blocking factor used to distribute
+* the rows of the array.
+* NB_A (global) DESCA( NB_ ) The blocking factor used to distribute
+* the columns of the array.
+* RSRC_A (global) DESCA( RSRC_ ) The process row over which the first
+* row of the array A is distributed.
+* CSRC_A (global) DESCA( CSRC_ ) The process column over which the
+* first column of the array A is
+* distributed.
+* LLD_A (local) DESCA( LLD_ ) The leading dimension of the local
+* array. LLD_A >= MAX(1,LOCr(M_A)).
+*
+* Let K be the number of rows or columns of a distributed matrix,
+* and assume that its process grid has dimension p x q.
+* LOCr( K ) denotes the number of elements of K that a process
+* would receive if K were distributed over the p processes of its
+* process column.
+* Similarly, LOCc( K ) denotes the number of elements of K that a
+* process would receive if K were distributed over the q processes of
+* its process row.
+* The values of LOCr() and LOCc() may be determined via a call to the
+* ScaLAPACK tool function, NUMROC:
+* LOCr( M ) = NUMROC( M, MB_A, MYROW, RSRC_A, NPROW ),
+* LOCc( N ) = NUMROC( N, NB_A, MYCOL, CSRC_A, NPCOL ).
+* An upper bound for these quantities may be computed by:
+* LOCr( M ) <= ceil( ceil(M/MB_A)/NPROW )*MB_A
+* LOCc( N ) <= ceil( ceil(N/NB_A)/NPCOL )*NB_A
+*
+* Arguments
+* =========
+*
+* WANTT (global input) LOGICAL
+* If .TRUE., then the Hessenberg matrix H is fully updated
+* so that the quasi-triangular Schur factor may be
+* computed (in cooperation with the calling subroutine).
+* If .FALSE., then only enough of H is updated to preserve
+* the eigenvalues.
+*
+* WANTZ (global input) LOGICAL
+* If .TRUE., then the orthogonal matrix Z is updated so
+* so that the orthogonal Schur factor may be computed
+* (in cooperation with the calling subroutine).
+* If .FALSE., then Z is not referenced.
+*
+* N (global input) INTEGER
+* The order of the matrix H and (if WANTZ is .TRUE.) the
+* order of the orthogonal matrix Z.
+*
+* KTOP (global input) INTEGER
+* It is assumed that either KTOP = 1 or H(KTOP,KTOP-1)=0.
+* KBOT and KTOP together determine an isolated block
+* along the diagonal of the Hessenberg matrix.
+*
+* KBOT (global input) INTEGER
+* It is assumed without a check that either
+* KBOT = N or H(KBOT+1,KBOT)=0. KBOT and KTOP together
+* determine an isolated block along the diagonal of the
+* Hessenberg matrix.
+*
+* NW (global input) INTEGER
+* Deflation window size. 1 .LE. NW .LE. (KBOT-KTOP+1).
+*
+* H (local input/output) REAL array, dimension
+* (DESCH(LLD_),*)
+* 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.
+*
+* DESCH (global and local input) INTEGER array of dimension DLEN_.
+* The array descriptor for the distributed matrix H.
+*
+* ILOZ (global input) INTEGER
+* IHIZ (global input) INTEGER
+* Specify the rows of Z to which transformations must be
+* applied if WANTZ is .TRUE.. 1 .LE. ILOZ .LE. IHIZ .LE. N.
+*
+* Z (input/output) REAL array, dimension
+* (DESCH(LLD_),*)
+* IF WANTZ is .TRUE., then on output, the orthogonal
+* similarity transformation mentioned above has been
+* accumulated into Z(ILOZ:IHIZ,ILO:IHI) from the right.
+* If WANTZ is .FALSE., then Z is unreferenced.
+*
+* DESCZ (global and local input) INTEGER array of dimension DLEN_.
+* The array descriptor for the distributed matrix Z.
+*
+* NS (global output) INTEGER
+* The number of unconverged (ie approximate) eigenvalues
+* returned in SR and SI that may be used as shifts by the
+* calling subroutine.
+*
+* ND (global output) INTEGER
+* The number of converged eigenvalues uncovered by this
+* subroutine.
+*
+* SR (global output) REAL array, dimension KBOT
+* SI (global output) REAL array, dimension KBOT
+* On output, the real and imaginary parts of approximate
+* eigenvalues that may be used for shifts are stored in
+* SR(KBOT-ND-NS+1) through SR(KBOT-ND) and
+* SI(KBOT-ND-NS+1) through SI(KBOT-ND), respectively.
+* The real and imaginary parts of converged eigenvalues
+* are stored in SR(KBOT-ND+1) through SR(KBOT) and
+* SI(KBOT-ND+1) through SI(KBOT), respectively.
+*
+* V (global workspace) REAL array, dimension
+* (DESCV(LLD_),*)
+* An NW-by-NW distributed work array.
+*
+* DESCV (global and local input) INTEGER array of dimension DLEN_.
+* The array descriptor for the distributed matrix V.
+*
+* NH (input) INTEGER scalar
+* The number of columns of T. NH.GE.NW.
+*
+* T (global workspace) REAL array, dimension
+* (DESCV(LLD_),*)
+*
+* DESCT (global and local input) INTEGER array of dimension DLEN_.
+* The array descriptor for the distributed matrix T.
+*
+* NV (global input) INTEGER
+* The number of rows of work array WV available for
+* workspace. NV.GE.NW.
+*
+* WV (global workspace) REAL array, dimension
+* (DESCW(LLD_),*)
+*
+* DESCW (global and local input) INTEGER array of dimension DLEN_.
+* The array descriptor for the distributed matrix WV.
+*
+* WORK (local workspace) REAL array, dimension LWORK.
+* On exit, WORK(1) is set to an estimate of the optimal value
+* of LWORK for the given values of N, NW, KTOP and KBOT.
+*
+* LWORK (local input) INTEGER
+* The dimension of the work array WORK. LWORK = 2*NW
+* suffices, but greater efficiency may result from larger
+* values of LWORK.
+*
+* If LWORK = -1, then a workspace query is assumed; PSLAQR3
+* 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.
+*
+* IWORK (local workspace) INTEGER array, dimension (LIWORK)
+*
+* LIWORK (local input) INTEGER
+* The length of the workspace array IWORK
+*
+* ================================================================
+* Based on contributions by
+* Robert Granat and Meiyue Shao,
+* Department of Computing Science and HPC2N,
+* Umea University, Sweden
+*
+* ================================================================
+* .. Parameters ..
+ INTEGER BLOCK_CYCLIC_2D, CSRC_, CTXT_, DLEN_, DTYPE_,
+ $ LLD_, MB_, M_, NB_, N_, RSRC_
+ INTEGER RECMAX
+ LOGICAL SORTGRAD
+ PARAMETER ( BLOCK_CYCLIC_2D = 1, DLEN_ = 9, DTYPE_ = 1,
+ $ CTXT_ = 2, M_ = 3, N_ = 4, MB_ = 5, NB_ = 6,
+ $ RSRC_ = 7, CSRC_ = 8, LLD_ = 9, RECMAX = 3,
+ $ SORTGRAD = .FALSE. )
+ REAL ZERO, ONE
+ PARAMETER ( ZERO = 0.0, ONE = 1.0 )
+* ..
+* .. Local Scalars ..
+ REAL AA, BB, BETA, CC, CS, DD, EVI, EVK, FOO, S,
+ $ SAFMAX, SAFMIN, SMLNUM, SN, TAU, ULP,
+ $ ELEM, ELEM1, ELEM2, ELEM3, R1, ANORM, RNORM,
+ $ RESAED
+ INTEGER I, IFST, ILST, INFO, INFQR, J, JW, K, KCOL,
+ $ KEND, KLN, KROW, KWTOP, LTOP, LWK1, LWK2, LWK3,
+ $ LWKOPT, NMIN, LLDH, LLDZ, LLDT, LLDV, LLDWV,
+ $ ICTXT, NPROW, NMAX, NPCOL, MYROW, MYCOL, NB,
+ $ IROFFH, M, RCOLS, TAUROWS, RROWS, TAUCOLS,
+ $ ITAU, IR, IPW, NPROCS, MLOC, IROFFHH,
+ $ ICOFFHH, HHRSRC, HHCSRC, HHROWS, HHCOLS,
+ $ IROFFZZ, ICOFFZZ, ZZRSRC, ZZCSRC, ZZROWS,
+ $ ZZCOLS, IERR, TZROWS0, TZCOLS0, IERR0, IPT0,
+ $ IPZ0, IPW0, NB2, ROUND, LILST, KK, LILST0,
+ $ IWRK1, RSRC, CSRC, LWK4, LWK5, IWRK2, LWK6,
+ $ LWK7, LWK8, ILWKOPT, TZROWS, TZCOLS, NSEL,
+ $ NPMIN, ICTXT_NEW, MYROW_NEW, MYCOL_NEW
+ LOGICAL BULGE, SORTED, LQUERY
+* ..
+* .. Local Arrays ..
+ INTEGER PAR( 6 ), DESCR( DLEN_ ),
+ $ DESCTAU( DLEN_ ), DESCHH( DLEN_ ),
+ $ DESCZZ( DLEN_ ), DESCTZ0( DLEN_ ),
+ $ PMAP( 64*64 )
+ REAL DDUM( 1 )
+* ..
+* .. External Functions ..
+ REAL SLAMCH, PSLANGE
+ INTEGER PILAENVX, NUMROC, INDXG2P, ICEIL, BLACS_PNUM
+ EXTERNAL SLAMCH, PILAENVX, NUMROC, INDXG2P, PSLANGE,
+ $ ICEIL, BLACS_PNUM
+* ..
+* .. External Subroutines ..
+ EXTERNAL PSCOPY, PSGEHRD, PSGEMM, SLABAD, PSLACPY,
+ $ PSLAQR1, SLANV2, PSLAQR0, PSLARF, PSLARFG,
+ $ PSLASET, PSTRORD, PSELGET, PSELSET,
+ $ PSLAMVE, BLACS_GRIDINFO, BLACS_GRIDMAP,
+ $ BLACS_GRIDEXIT, PSGEMR2D
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, FLOAT, INT, MAX, MIN, SQRT
+* ..
+* .. Executable Statements ..
+ ICTXT = DESCH( CTXT_ )
+ CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL )
+ NPROCS = NPROW*NPCOL
+*
+* Extract local leading dimensions, blockfactors, offset for
+* keeping the alignment requirements and size of deflation window.
+*
+ LLDH = DESCH( LLD_ )
+ LLDZ = DESCZ( LLD_ )
+ LLDT = DESCT( LLD_ )
+ LLDV = DESCV( LLD_ )
+ LLDWV = DESCW( LLD_ )
+ NB = DESCH( MB_ )
+ IROFFH = MOD( KTOP - 1, NB )
+ JW = MIN( NW, KBOT-KTOP+1 )
+ NSEL = NB+JW
+*
+* Extract environment variables for parallel eigenvalue reordering.
+*
+ PAR(1) = PILAENVX(ICTXT, 17, 'PSLAQR3', 'SV', JW, NB, -1, -1)
+ PAR(2) = PILAENVX(ICTXT, 18, 'PSLAQR3', 'SV', JW, NB, -1, -1)
+ PAR(3) = PILAENVX(ICTXT, 19, 'PSLAQR3', 'SV', JW, NB, -1, -1)
+ PAR(4) = PILAENVX(ICTXT, 20, 'PSLAQR3', 'SV', JW, NB, -1, -1)
+ PAR(5) = PILAENVX(ICTXT, 21, 'PSLAQR3', 'SV', JW, NB, -1, -1)
+ PAR(6) = PILAENVX(ICTXT, 22, 'PSLAQR3', 'SV', JW, NB, -1, -1)
+*
+* Check if workspace query.
+*
+ LQUERY = LWORK.EQ.-1 .OR. LIWORK.EQ.-1
+*
+* Estimate optimal workspace.
+*
+ IF( JW.LE.2 ) THEN
+ LWKOPT = 1
+ ELSE
+*
+* Workspace query calls to PSGEHRD and PSORMHR.
+*
+ TAUROWS = NUMROC( 1, 1, MYCOL, DESCV(RSRC_), NPROW )
+ TAUCOLS = NUMROC( JW+IROFFH, NB, MYCOL, DESCV(CSRC_),
+ $ NPCOL )
+ CALL PSGEHRD( JW, 1, JW, T, 1, 1, DESCT, WORK, WORK, -1,
+ $ INFO )
+ LWK1 = INT( WORK( 1 ) ) + TAUROWS*TAUCOLS
+*
+* Workspace query call to PSORMHR.
+*
+ CALL PSORMHR( 'Right', 'No', JW, JW, 1, JW, T, 1, 1, DESCT,
+ $ WORK, V, 1, 1, DESCV, WORK, -1, INFO )
+ LWK2 = INT( WORK( 1 ) )
+*
+* Workspace query call to PSLAQR0.
+*
+ NMIN = PILAENVX( ICTXT, 12, 'PSLAQR3', 'SV', JW, 1, JW, LWORK )
+ NMAX = ( N-1 ) / 3
+ IF( JW+IROFFH.GT.NMIN .AND. JW+IROFFH.LE.NMAX
+ $ .AND. RECLEVEL.LT.RECMAX ) THEN
+ CALL PSLAQR0( .TRUE., .TRUE., JW+IROFFH, 1+IROFFH,
+ $ JW+IROFFH, T, DESCT, SR, SI, 1, JW, V, DESCV,
+ $ WORK, -1, IWORK, LIWORK-NSEL, INFQR,
+ $ RECLEVEL+1 )
+ LWK3 = INT( WORK( 1 ) )
+ IWRK1 = IWORK( 1 )
+ ELSE
+ RSRC = DESCT( RSRC_ )
+ CSRC = DESCT( CSRC_ )
+ DESCT( RSRC_ ) = 0
+ DESCT( CSRC_ ) = 0
+ CALL PSLAQR1( .TRUE., .TRUE., JW+IROFFH, 1, JW+IROFFH, T,
+ $ DESCT, SR, SI, 1, JW+IROFFH, V, DESCV, WORK, -1,
+ $ IWORK, LIWORK-NSEL, INFQR )
+ DESCT( RSRC_ ) = RSRC
+ DESCT( CSRC_ ) = CSRC
+ LWK3 = INT( WORK( 1 ) )
+ IWRK1 = IWORK( 1 )
+ END IF
+*
+* Workspace in case of alignment problems.
+*
+ TZROWS0 = NUMROC( JW+IROFFH, NB, MYROW, 0, NPROW )
+ TZCOLS0 = NUMROC( JW+IROFFH, NB, MYCOL, 0, NPCOL )
+ LWK4 = 2 * TZROWS0*TZCOLS0
+*
+* Workspace check for reordering.
+*
+ CALL PSTRORD( 'Vectors', IWORK, PAR, JW+IROFFH, T, 1, 1,
+ $ DESCT, V, 1, 1, DESCV, DDUM, DDUM, MLOC, WORK, -1,
+ $ IWORK, LIWORK-NSEL, INFO )
+ LWK5 = INT( WORK( 1 ) )
+ IWRK2 = IWORK( 1 )
+*
+* Extra workspace for reflecting back spike
+* (workspace for PSLARF approximated for simplicity).
+*
+ RROWS = NUMROC( N+IROFFH, NB, MYROW, DESCV(RSRC_), NPROW )
+ RCOLS = NUMROC( 1, 1, MYCOL, DESCV(CSRC_), NPCOL )
+ LWK6 = RROWS*RCOLS + TAUROWS*TAUCOLS +
+ $ 2*ICEIL(ICEIL(JW+IROFFH,NB),NPROW)*NB
+ $ *ICEIL(ICEIL(JW+IROFFH,NB),NPCOL)*NB
+*
+* Extra workspace needed by PBLAS update calls
+* (also estimated for simplicity).
+*
+ LWK7 = MAX( ICEIL(ICEIL(JW,NB),NPROW)*NB *
+ $ ICEIL(ICEIL(N-KBOT,NB),NPCOL)*NB,
+ $ ICEIL(ICEIL(IHIZ-ILOZ+1,NB),NPROW)*NB *
+ $ ICEIL(ICEIL(JW,NB),NPCOL)*NB,
+ $ ICEIL(ICEIL(KBOT-JW,NB),NPROW)*NB *
+ $ ICEIL(ICEIL(JW,NB),NPCOL)*NB )
+*
+* Residual check workspace.
+*
+ TZROWS = NUMROC( JW+IROFFH, NB, MYROW, DESCT(RSRC_), NPROW )
+ TZCOLS = NUMROC( JW+IROFFH, NB, MYCOL, DESCT(CSRC_), NPCOL )
+ LWK8 = 2*TZROWS*TZCOLS
+*
+* Optimal workspace.
+*
+ LWKOPT = MAX( LWK1, LWK2, LWK3+LWK4, LWK5, LWK6, LWK7, LWK8 )
+ ILWKOPT = MAX( IWRK1, IWRK2 )
+ END IF
+*
+* Quick return in case of workspace query.
+*
+ WORK( 1 ) = FLOAT( LWKOPT )
+*
+* IWORK(1:NSEL) is used as the array SELECT for PSTRORD.
+*
+ IWORK( 1 ) = ILWKOPT + NSEL
+ IF( LQUERY )
+ $ RETURN
+*
+* Nothing to do for an empty active block ...
+ NS = 0
+ ND = 0
+ IF( KTOP.GT.KBOT )
+ $ RETURN
+* ... nor for an empty deflation window.
+*
+ IF( NW.LT.1 )
+ $ RETURN
+*
+* Machine constants.
+*
+ SAFMIN = SLAMCH( 'SAFE MINIMUM' )
+ SAFMAX = ONE / SAFMIN
+ CALL SLABAD( SAFMIN, SAFMAX )
+ ULP = SLAMCH( 'PRECISION' )
+ SMLNUM = SAFMIN*( FLOAT( N ) / ULP )
+*
+* Setup deflation window.
+*
+ JW = MIN( NW, KBOT-KTOP+1 )
+ KWTOP = KBOT - JW + 1
+ IF( KWTOP.EQ.KTOP ) THEN
+ S = ZERO
+ ELSE
+ CALL PSELGET( 'All', '1-Tree', S, H, KWTOP, KWTOP-1, DESCH )
+ END IF
+*
+ IF( KBOT.EQ.KWTOP ) THEN
+*
+* 1-by-1 deflation window: not much to do.
+*
+ CALL PSELGET( 'All', '1-Tree', SR( KWTOP ), H, KWTOP, KWTOP,
+ $ DESCH )
+ SI( KWTOP ) = ZERO
+ NS = 1
+ ND = 0
+ IF( ABS( S ).LE.MAX( SMLNUM, ULP*ABS( SR( KWTOP ) ) ) )
+ $ THEN
+ NS = 0
+ ND = 1
+ IF( KWTOP.GT.KTOP )
+ $ CALL PSELSET( H, KWTOP, KWTOP-1 , DESCH, ZERO )
+ END IF
+ RETURN
+ END IF
+*
+ IF( KWTOP.EQ.KTOP .AND. KBOT-KWTOP.EQ.1 ) THEN
+*
+* 2-by-2 deflation window: a little more to do.
+*
+ CALL PSELGET( 'All', '1-Tree', AA, H, KWTOP, KWTOP, DESCH )
+ CALL PSELGET( 'All', '1-Tree', BB, H, KWTOP, KWTOP+1, DESCH )
+ CALL PSELGET( 'All', '1-Tree', CC, H, KWTOP+1, KWTOP, DESCH )
+ CALL PSELGET( 'All', '1-Tree', DD, H, KWTOP+1, KWTOP+1, DESCH )
+ CALL SLANV2( AA, BB, CC, DD, SR(KWTOP), SI(KWTOP),
+ $ SR(KWTOP+1), SI(KWTOP+1), CS, SN )
+ NS = 0
+ ND = 2
+ IF( CC.EQ.ZERO ) THEN
+ I = KWTOP
+ IF( I+2.LE.N .AND. WANTT )
+ $ CALL PSROT( N-I-1, H, I, I+2, DESCH, DESCH(M_), H, I+1,
+ $ I+2, DESCH, DESCH(M_), CS, SN, WORK, LWORK, INFO )
+ IF( I.GT.1 )
+ $ CALL PSROT( I-1, H, 1, I, DESCH, 1, H, 1, I+1, DESCH, 1,
+ $ CS, SN, WORK, LWORK, INFO )
+ IF( WANTZ )
+ $ CALL PSROT( IHIZ-ILOZ+1, Z, ILOZ, I, DESCZ, 1, Z, ILOZ,
+ $ I+1, DESCZ, 1, CS, SN, WORK, LWORK, INFO )
+ CALL PSELSET( H, I, I, DESCH, AA )
+ CALL PSELSET( H, I, I+1, DESCH, BB )
+ CALL PSELSET( H, I+1, I, DESCH, CC )
+ CALL PSELSET( H, I+1, I+1, DESCH, DD )
+ END IF
+ WORK( 1 ) = FLOAT( LWKOPT )
+ RETURN
+ END IF
+*
+* Calculate new value for IROFFH in case deflation window
+* was adjusted.
+*
+ IROFFH = MOD( KWTOP - 1, NB )
+*
+* Adjust number of rows and columns of T matrix descriptor
+* to prepare for call to PDBTRORD.
+*
+ DESCT( M_ ) = JW+IROFFH
+ DESCT( N_ ) = JW+IROFFH
+*
+* 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.)
+*
+* Copy the trailing submatrix to the working space.
+*
+ CALL PSLASET( 'All', IROFFH, JW+IROFFH, ZERO, ONE, T, 1, 1,
+ $ DESCT )
+ CALL PSLASET( 'All', JW, IROFFH, ZERO, ZERO, T, 1+IROFFH, 1,
+ $ DESCT )
+ CALL PSLACPY( 'All', 1, JW, H, KWTOP, KWTOP, DESCH, T, 1+IROFFH,
+ $ 1+IROFFH, DESCT )
+ CALL PSLACPY( 'Upper', JW-1, JW-1, H, KWTOP+1, KWTOP, DESCH, T,
+ $ 1+IROFFH+1, 1+IROFFH, DESCT )
+ IF( JW.GT.2 )
+ $ CALL PSLASET( 'Lower', JW-2, JW-2, ZERO, ZERO, T, 1+IROFFH+2,
+ $ 1+IROFFH, DESCT )
+ CALL PSLACPY( 'All', JW-1, 1, H, KWTOP+1, KWTOP+JW-1, DESCH, T,
+ $ 1+IROFFH+1, 1+IROFFH+JW-1, DESCT )
+*
+* Initialize the working orthogonal matrix.
+*
+ CALL PSLASET( 'All', JW+IROFFH, JW+IROFFH, ZERO, ONE, V, 1, 1,
+ $ DESCV )
+*
+* Compute the Schur form of T.
+*
+ NPMIN = PILAENVX( ICTXT, 23, 'PSLAQR3', 'SV', JW, NB, NPROW,
+ $ NPCOL )
+ NMIN = PILAENVX( ICTXT, 12, 'PSLAQR3', 'SV', JW, 1, JW, LWORK )
+ NMAX = ( N-1 ) / 3
+ IF( MIN(NPROW, NPCOL).LE.NPMIN+1 .OR. RECLEVEL.GE.1 ) THEN
+*
+* The AED window is large enough.
+* Compute the Schur decomposition with all processors.
+*
+ IF( JW+IROFFH.GT.NMIN .AND. JW+IROFFH.LE.NMAX
+ $ .AND. RECLEVEL.LT.RECMAX ) THEN
+ CALL PSLAQR0( .TRUE., .TRUE., JW+IROFFH, 1+IROFFH,
+ $ JW+IROFFH, T, DESCT, SR( KWTOP-IROFFH ),
+ $ SI( KWTOP-IROFFH ), 1+IROFFH, JW+IROFFH, V, DESCV,
+ $ WORK, LWORK, IWORK(NSEL+1), LIWORK-NSEL, INFQR,
+ $ RECLEVEL+1 )
+ ELSE
+ IF( DESCT(RSRC_).EQ.0 .AND. DESCT(CSRC_).EQ.0 ) THEN
+ IF( JW+IROFFH.GT.DESCT( MB_ ) ) THEN
+ CALL PSLAQR1( .TRUE., .TRUE., JW+IROFFH, 1,
+ $ JW+IROFFH, T, DESCT, SR( KWTOP-IROFFH ),
+ $ SI( KWTOP-IROFFH ), 1, JW+IROFFH, V,
+ $ DESCV, WORK, LWORK, IWORK(NSEL+1), LIWORK-NSEL,
+ $ INFQR )
+ ELSE
+ IF( MYROW.EQ.0 .AND. MYCOL.EQ.0 ) THEN
+ CALL SLAHQR( .TRUE., .TRUE., JW+IROFFH, 1+IROFFH,
+ $ JW+IROFFH, T, DESCT(LLD_),
+ $ SR( KWTOP-IROFFH ), SI( KWTOP-IROFFH ),
+ $ 1+IROFFH, JW+IROFFH, V, DESCV(LLD_), INFQR )
+ ELSE
+ INFQR = 0
+ END IF
+ IF( NPROCS.GT.1 )
+ $ CALL IGAMN2D( ICTXT, 'All', '1-Tree', 1, 1, INFQR,
+ $ 1, -1, -1, -1, -1, -1 )
+ END IF
+ ELSEIF( JW+IROFFH.LE.DESCT( MB_ ) ) THEN
+ IF( MYROW.EQ.DESCT(RSRC_) .AND. MYCOL.EQ.DESCT(CSRC_) )
+ $ THEN
+ CALL SLAHQR( .TRUE., .TRUE., JW+IROFFH, 1+IROFFH,
+ $ JW+IROFFH, T, DESCT(LLD_),
+ $ SR( KWTOP-IROFFH ), SI( KWTOP-IROFFH ),
+ $ 1+IROFFH, JW+IROFFH, V, DESCV(LLD_), INFQR )
+ ELSE
+ INFQR = 0
+ END IF
+ IF( NPROCS.GT.1 )
+ $ CALL IGAMN2D( ICTXT, 'All', '1-Tree', 1, 1, INFQR,
+ $ 1, -1, -1, -1, -1, -1 )
+ ELSE
+ TZROWS0 = NUMROC( JW+IROFFH, NB, MYROW, 0, NPROW )
+ TZCOLS0 = NUMROC( JW+IROFFH, NB, MYCOL, 0, NPCOL )
+ CALL DESCINIT( DESCTZ0, JW+IROFFH, JW+IROFFH, NB, NB, 0,
+ $ 0, ICTXT, MAX(1,TZROWS0), IERR0 )
+ IPT0 = 1
+ IPZ0 = IPT0 + MAX(1,TZROWS0)*TZCOLS0
+ IPW0 = IPZ0 + MAX(1,TZROWS0)*TZCOLS0
+ CALL PSLAMVE( 'All', JW+IROFFH, JW+IROFFH, T, 1, 1,
+ $ DESCT, WORK(IPT0), 1, 1, DESCTZ0, WORK(IPW0) )
+ CALL PSLASET( 'All', JW+IROFFH, JW+IROFFH, ZERO, ONE,
+ $ WORK(IPZ0), 1, 1, DESCTZ0 )
+ CALL PSLAQR1( .TRUE., .TRUE., JW+IROFFH, 1,
+ $ JW+IROFFH, WORK(IPT0), DESCTZ0,
+ $ SR( KWTOP-IROFFH ), SI( KWTOP-IROFFH ),
+ $ 1, JW+IROFFH, WORK(IPZ0),
+ $ DESCTZ0, WORK(IPW0), LWORK-IPW0+1, IWORK(NSEL+1),
+ $ LIWORK-NSEL, INFQR )
+ CALL PSLAMVE( 'All', JW+IROFFH, JW+IROFFH, WORK(IPT0), 1,
+ $ 1, DESCTZ0, T, 1, 1, DESCT, WORK(IPW0) )
+ CALL PSLAMVE( 'All', JW+IROFFH, JW+IROFFH, WORK(IPZ0), 1,
+ $ 1, DESCTZ0, V, 1, 1, DESCV, WORK(IPW0) )
+ END IF
+ END IF
+ ELSE
+*
+* The AED window is too small.
+* Redistribute the AED window to a subgrid
+* and do the computation on the subgrid.
+*
+ ICTXT_NEW = ICTXT
+ DO 20 I = 0, NPMIN-1
+ DO 10 J = 0, NPMIN-1
+ PMAP( J+1+I*NPMIN ) = BLACS_PNUM( ICTXT, I, J )
+ 10 CONTINUE
+ 20 CONTINUE
+ CALL BLACS_GRIDMAP( ICTXT_NEW, PMAP, NPMIN, NPMIN, NPMIN )
+ CALL BLACS_GRIDINFO( ICTXT_NEW, NPMIN, NPMIN, MYROW_NEW,
+ $ MYCOL_NEW )
+ IF( MYROW.GE.NPMIN .OR. MYCOL.GE.NPMIN ) ICTXT_NEW = -1
+ IF( ICTXT_NEW.GE.0 ) THEN
+ TZROWS0 = NUMROC( JW, NB, MYROW_NEW, 0, NPMIN )
+ TZCOLS0 = NUMROC( JW, NB, MYCOL_NEW, 0, NPMIN )
+ CALL DESCINIT( DESCTZ0, JW, JW, NB, NB, 0,
+ $ 0, ICTXT_NEW, MAX(1,TZROWS0), IERR0 )
+ IPT0 = 1
+ IPZ0 = IPT0 + MAX(1,TZROWS0)*MAX(1,TZCOLS0)
+ IPW0 = IPZ0 + MAX(1,TZROWS0)*MAX(1,TZCOLS0)
+ ELSE
+ IPT0 = 1
+ IPZ0 = 2
+ IPW0 = 3
+ DESCTZ0( CTXT_ ) = -1
+ INFQR = 0
+ END IF
+ CALL PSGEMR2D( JW, JW, T, 1+IROFFH, 1+IROFFH, DESCT,
+ $ WORK(IPT0), 1, 1, DESCTZ0, ICTXT )
+ IF( ICTXT_NEW.GE.0 ) THEN
+ CALL PSLASET( 'All', JW, JW, ZERO, ONE, WORK(IPZ0), 1, 1,
+ $ DESCTZ0 )
+ NMIN = PILAENVX( ICTXT_NEW, 12, 'PSLAQR3', 'SV', JW, 1, JW,
+ $ LWORK )
+ IF( JW.GT.NMIN .AND. JW.LE.NMAX .AND. RECLEVEL.LT.1 ) THEN
+ CALL PSLAQR0( .TRUE., .TRUE., JW, 1, JW, WORK(IPT0),
+ $ DESCTZ0, SR( KWTOP ), SI( KWTOP ), 1, JW,
+ $ WORK(IPZ0), DESCTZ0, WORK(IPW0), LWORK-IPW0+1,
+ $ IWORK(NSEL+1), LIWORK-NSEL, INFQR,
+ $ RECLEVEL+1 )
+ ELSE
+ CALL PSLAQR1( .TRUE., .TRUE., JW, 1, JW, WORK(IPT0),
+ $ DESCTZ0, SR( KWTOP ), SI( KWTOP ), 1, JW,
+ $ WORK(IPZ0), DESCTZ0, WORK(IPW0), LWORK-IPW0+1,
+ $ IWORK(NSEL+1), LIWORK-NSEL, INFQR )
+ END IF
+ END IF
+ CALL PSGEMR2D( JW, JW, WORK(IPT0), 1, 1, DESCTZ0, T, 1+IROFFH,
+ $ 1+IROFFH, DESCT, ICTXT )
+ CALL PSGEMR2D( JW, JW, WORK(IPZ0), 1, 1, DESCTZ0, V, 1+IROFFH,
+ $ 1+IROFFH, DESCV, ICTXT )
+ IF( ICTXT_NEW.GE.0 )
+ $ CALL BLACS_GRIDEXIT( ICTXT_NEW )
+ IF( MYROW+MYCOL.GT.0 ) THEN
+ DO 40 J = 0, JW-1
+ SR( KWTOP+J ) = ZERO
+ SI( KWTOP+J ) = ZERO
+ 40 CONTINUE
+ END IF
+ CALL IGAMN2D( ICTXT, 'All', '1-Tree', 1, 1, INFQR, 1, -1, -1,
+ $ -1, -1, -1 )
+ CALL SGSUM2D( ICTXT, 'All', ' ', JW, 1, SR(KWTOP), JW, -1, -1 )
+ CALL SGSUM2D( ICTXT, 'All', ' ', JW, 1, SI(KWTOP), JW, -1, -1 )
+ END IF
+*
+* Adjust INFQR for offset from block border in submatrices.
+*
+ IF( INFQR.NE.0 )
+ $ INFQR = INFQR - IROFFH
+*
+* PSTRORD needs a clean margin near the diagonal.
+*
+ DO 50 J = 1, JW - 3
+ CALL PSELSET( T, J+2, J, DESCT, ZERO )
+ CALL PSELSET( T, J+3, J, DESCT, ZERO )
+ 50 CONTINUE
+ IF( JW.GT.2 )
+ $ CALL PSELSET( T, JW, JW-2, DESCT, ZERO )
+*
+* Check local residual for AED Schur decomposition.
+*
+ RESAED = 0.0
+*
+* Clean up the array SELECT for PSTRORD.
+*
+ DO 60 J = 1, NSEL
+ IWORK( J ) = 0
+ 60 CONTINUE
+*
+* Set local M counter to zero.
+*
+ MLOC = 0
+*
+* Outer deflation detection loop (label 80).
+* In this loop a bunch of undeflatable eigenvalues
+* are moved simultaneously.
+*
+ DO 70 J = 1, IROFFH + INFQR
+ IWORK( J ) = 1
+ 70 CONTINUE
+*
+ NS = JW
+ ILST = INFQR + 1 + IROFFH
+ IF( ILST.GT.1 ) THEN
+ CALL PSELGET( 'All', '1-Tree', ELEM, T, ILST, ILST-1, DESCT )
+ BULGE = ELEM.NE.ZERO
+ IF( BULGE ) ILST = ILST+1
+ END IF
+*
+ 80 CONTINUE
+ IF( ILST.LE.NS+IROFFH ) THEN
+*
+* Find the top-left corner of the local window.
+*
+ LILST = MAX(ILST,NS+IROFFH-NB+1)
+ IF( LILST.GT.1 ) THEN
+ CALL PSELGET( 'All', '1-Tree', ELEM, T, LILST, LILST-1,
+ $ DESCT )
+ BULGE = ELEM.NE.ZERO
+ IF( BULGE ) LILST = LILST+1
+ END IF
+*
+* Lock all eigenvalues outside the local window.
+*
+ DO 90 J = IROFFH+1, LILST-1
+ IWORK( J ) = 1
+ 90 CONTINUE
+ LILST0 = LILST
+*
+* Inner deflation detection loop (label 100).
+* In this loop, the undeflatable eigenvalues are moved to the
+* top-left corner of the local window.
+*
+ 100 CONTINUE
+ IF( LILST.LE.NS+IROFFH ) THEN
+ IF( NS.EQ.1 ) THEN
+ BULGE = .FALSE.
+ ELSE
+ CALL PSELGET( 'All', '1-Tree', ELEM, T, NS+IROFFH,
+ $ NS+IROFFH-1, DESCT )
+ BULGE = ELEM.NE.ZERO
+ END IF
+*
+* Small spike tip test for deflation.
+*
+ IF( .NOT.BULGE ) THEN
+*
+* Real eigenvalue.
+*
+ CALL PSELGET( 'All', '1-Tree', ELEM, T, NS+IROFFH,
+ $ NS+IROFFH, DESCT )
+ FOO = ABS( ELEM )
+ IF( FOO.EQ.ZERO )
+ $ FOO = ABS( S )
+ CALL PSELGET( 'All', '1-Tree', ELEM, V, 1+IROFFH,
+ $ NS+IROFFH, DESCV )
+ IF( ABS( S*ELEM ).LE.MAX( SMLNUM, ULP*FOO ) ) THEN
+*
+* Deflatable.
+*
+ NS = NS - 1
+ ELSE
+*
+* Undeflatable: move it up out of the way.
+*
+ IFST = NS
+ DO 110 J = LILST, JW+IROFFH
+ IWORK( J ) = 0
+ 110 CONTINUE
+ IWORK( IFST+IROFFH ) = 1
+ CALL PSTRORD( 'Vectors', IWORK, PAR, JW+IROFFH, T, 1,
+ $ 1, DESCT, V, 1, 1, DESCV, WORK,
+ $ WORK(JW+IROFFH+1), MLOC,
+ $ WORK(2*(JW+IROFFH)+1), LWORK-2*(JW+IROFFH),
+ $ IWORK(NSEL+1), LIWORK-NSEL, INFO )
+*
+* Adjust the array SELECT explicitly so that it does not
+* rely on the output of PSTRORD.
+*
+ IWORK( IFST+IROFFH ) = 0
+ IWORK( LILST ) = 1
+ LILST = LILST + 1
+*
+* In case of a rare exchange failure, adjust the
+* pointers ILST and LILST to the current place to avoid
+* unexpected behaviors.
+*
+ IF( INFO.NE.0 ) THEN
+ LILST = MAX(INFO, LILST)
+ ILST = MAX(INFO, ILST)
+ END IF
+ END IF
+ ELSE
+*
+* Complex conjugate pair.
+*
+ CALL PSELGET( 'All', '1-Tree', ELEM1, T, NS+IROFFH,
+ $ NS+IROFFH, DESCT )
+ CALL PSELGET( 'All', '1-Tree', ELEM2, T, NS+IROFFH,
+ $ NS+IROFFH-1, DESCT )
+ CALL PSELGET( 'All', '1-Tree', ELEM3, T, NS+IROFFH-1,
+ $ NS+IROFFH, DESCT )
+ FOO = ABS( ELEM1 ) + SQRT( ABS( ELEM2 ) )*
+ $ SQRT( ABS( ELEM3 ) )
+ IF( FOO.EQ.ZERO )
+ $ FOO = ABS( S )
+ CALL PSELGET( 'All', '1-Tree', ELEM1, V, 1+IROFFH,
+ $ NS+IROFFH, DESCV )
+ CALL PSELGET( 'All', '1-Tree', ELEM2, V, 1+IROFFH,
+ $ NS+IROFFH-1, DESCV )
+ IF( MAX( ABS( S*ELEM1 ), ABS( S*ELEM2 ) ).LE.
+ $ MAX( SMLNUM, ULP*FOO ) ) THEN
+*
+* Deflatable.
+*
+ NS = NS - 2
+ ELSE
+*
+* Undeflatable: move them up out of the way.
+*
+ IFST = NS
+ DO 120 J = LILST, JW+IROFFH
+ IWORK( J ) = 0
+ 120 CONTINUE
+ IWORK( IFST+IROFFH ) = 1
+ IWORK( IFST+IROFFH-1 ) = 1
+ CALL PSTRORD( 'Vectors', IWORK, PAR, JW+IROFFH, T, 1,
+ $ 1, DESCT, V, 1, 1, DESCV, WORK,
+ $ WORK(JW+IROFFH+1), MLOC,
+ $ WORK(2*(JW+IROFFH)+1), LWORK-2*(JW+IROFFH),
+ $ IWORK(NSEL+1), LIWORK-NSEL, INFO )
+*
+* Adjust the array SELECT explicitly so that it does not
+* rely on the output of PSTRORD.
+*
+ IWORK( IFST+IROFFH ) = 0
+ IWORK( IFST+IROFFH-1 ) = 0
+ IWORK( LILST ) = 1
+ IWORK( LILST+1 ) = 1
+ LILST = LILST + 2
+*
+* In case of a rare exchange failure, adjust the
+* pointers ILST and LILST to the current place to avoid
+* unexpected behaviors.
+*
+ IF( INFO.NE.0 ) THEN
+ LILST = MAX(INFO, LILST)
+ ILST = MAX(INFO, ILST)
+ END IF
+ END IF
+ END IF
+*
+* End of inner deflation detection loop.
+*
+ GO TO 100
+ END IF
+*
+* Unlock the eigenvalues outside the local window.
+* Then undeflatable eigenvalues are moved to the proper position.
+*
+ DO 130 J = ILST, LILST0-1
+ IWORK( J ) = 0
+ 130 CONTINUE
+ CALL PSTRORD( 'Vectors', IWORK, PAR, JW+IROFFH, T, 1, 1,
+ $ DESCT, V, 1, 1, DESCV, WORK, WORK(JW+IROFFH+1),
+ $ M, WORK(2*(JW+IROFFH)+1), LWORK-2*(JW+IROFFH),
+ $ IWORK(NSEL+1), LIWORK-NSEL, INFO )
+ ILST = M + 1
+*
+* In case of a rare exchange failure, adjust the pointer ILST to
+* the current place to avoid unexpected behaviors.
+*
+ IF( INFO.NE.0 )
+ $ ILST = MAX(INFO, ILST)
+*
+* End of outer deflation detection loop.
+*
+ GO TO 80
+ END IF
+
+*
+* Post-reordering step: copy output eigenvalues to output.
+*
+ CALL SCOPY( JW, WORK(1+IROFFH), 1, SR( KWTOP ), 1 )
+ CALL SCOPY( JW, WORK(JW+2*IROFFH+1), 1, SI( KWTOP ), 1 )
+*
+* Check local residual for reordered AED Schur decomposition.
+*
+ RESAED = 0.0
+*
+* Return to Hessenberg form.
+*
+ IF( NS.EQ.0 )
+ $ S = ZERO
+*
+ IF( NS.LT.JW .AND. SORTGRAD ) THEN
+*
+* Sorting diagonal blocks of T improves accuracy for
+* graded matrices. Bubble sort deals well with exchange
+* failures. Eigenvalues/shifts from T are also restored.
+*
+ ROUND = 0
+ SORTED = .FALSE.
+ I = NS + 1 + IROFFH
+ 140 CONTINUE
+ IF( SORTED )
+ $ GO TO 180
+ SORTED = .TRUE.
+ ROUND = ROUND + 1
+*
+ KEND = I - 1
+ I = INFQR + 1 + IROFFH
+ IF( I.EQ.NS+IROFFH ) THEN
+ K = I + 1
+ ELSE IF( SI( KWTOP-IROFFH + I-1 ).EQ.ZERO ) THEN
+ K = I + 1
+ ELSE
+ K = I + 2
+ END IF
+ 150 CONTINUE
+ IF( K.LE.KEND ) THEN
+ IF( K.EQ.I+1 ) THEN
+ EVI = ABS( SR( KWTOP-IROFFH+I-1 ) )
+ ELSE
+ EVI = ABS( SR( KWTOP-IROFFH+I-1 ) ) +
+ $ ABS( SI( KWTOP-IROFFH+I-1 ) )
+ END IF
+*
+ IF( K.EQ.KEND ) THEN
+ EVK = ABS( SR( KWTOP-IROFFH+K-1 ) )
+ ELSEIF( SI( KWTOP-IROFFH+K-1 ).EQ.ZERO ) THEN
+ EVK = ABS( SR( KWTOP-IROFFH+K-1 ) )
+ ELSE
+ EVK = ABS( SR( KWTOP-IROFFH+K-1 ) ) +
+ $ ABS( SI( KWTOP-IROFFH+K-1 ) )
+ END IF
+*
+ IF( EVI.GE.EVK ) THEN
+ I = K
+ ELSE
+ MLOC = 0
+ SORTED = .FALSE.
+ IFST = I
+ ILST = K
+ DO 160 J = 1, I-1
+ IWORK( J ) = 1
+ MLOC = MLOC + 1
+ 160 CONTINUE
+ IF( K.EQ.I+2 ) THEN
+ IWORK( I ) = 0
+ IWORK(I+1) = 0
+ ELSE
+ IWORK( I ) = 0
+ END IF
+ IF( K.NE.KEND .AND. SI( KWTOP-IROFFH+K-1 ).NE.ZERO ) THEN
+ IWORK( K ) = 1
+ IWORK(K+1) = 1
+ MLOC = MLOC + 2
+ ELSE
+ IWORK( K ) = 1
+ IF( K.LT.KEND ) IWORK(K+1) = 0
+ MLOC = MLOC + 1
+ END IF
+ DO 170 J = K+2, JW+IROFFH
+ IWORK( J ) = 0
+ 170 CONTINUE
+ CALL PSTRORD( 'Vectors', IWORK, PAR, JW+IROFFH, T, 1, 1,
+ $ DESCT, V, 1, 1, DESCV, WORK, WORK(JW+IROFFH+1), M,
+ $ WORK(2*(JW+IROFFH)+1), LWORK-2*(JW+IROFFH),
+ $ IWORK(NSEL+1), LIWORK-NSEL, IERR )
+ CALL SCOPY( JW, WORK(1+IROFFH), 1, SR( KWTOP ), 1 )
+ CALL SCOPY( JW, WORK(JW+2*IROFFH+1), 1, SI( KWTOP ), 1 )
+ IF( IERR.EQ.0 ) THEN
+ I = ILST
+ ELSE
+ I = K
+ END IF
+ END IF
+ IF( I.EQ.KEND ) THEN
+ K = I + 1
+ ELSE IF( SI( KWTOP-IROFFH+I-1 ).EQ.ZERO ) THEN
+ K = I + 1
+ ELSE
+ K = I + 2
+ END IF
+ GO TO 150
+ END IF
+ GO TO 140
+ 180 CONTINUE
+ END IF
+*
+* Restore number of rows and columns of T matrix descriptor.
+*
+ DESCT( M_ ) = NW+IROFFH
+ DESCT( N_ ) = NH+IROFFH
+*
+ IF( NS.LT.JW .OR. S.EQ.ZERO ) THEN
+ IF( NS.GT.1 .AND. S.NE.ZERO ) THEN
+*
+* Reflect spike back into lower triangle.
+*
+ RROWS = NUMROC( NS+IROFFH, NB, MYROW, DESCV(RSRC_), NPROW )
+ RCOLS = NUMROC( 1, 1, MYCOL, DESCV(CSRC_), NPCOL )
+ CALL DESCINIT( DESCR, NS+IROFFH, 1, NB, 1, DESCV(RSRC_),
+ $ DESCV(CSRC_), ICTXT, MAX(1, RROWS), INFO )
+ TAUROWS = NUMROC( 1, 1, MYCOL, DESCV(RSRC_), NPROW )
+ TAUCOLS = NUMROC( JW+IROFFH, NB, MYCOL, DESCV(CSRC_),
+ $ NPCOL )
+ CALL DESCINIT( DESCTAU, 1, JW+IROFFH, 1, NB, DESCV(RSRC_),
+ $ DESCV(CSRC_), ICTXT, MAX(1, TAUROWS), INFO )
+*
+ IR = 1
+ ITAU = IR + DESCR( LLD_ ) * RCOLS
+ IPW = ITAU + DESCTAU( LLD_ ) * TAUCOLS
+*
+ CALL PSLASET( 'All', NS+IROFFH, 1, ZERO, ZERO, WORK(ITAU),
+ $ 1, 1, DESCTAU )
+*
+ CALL PSCOPY( NS, V, 1+IROFFH, 1+IROFFH, DESCV, DESCV(M_),
+ $ WORK(IR), 1+IROFFH, 1, DESCR, 1 )
+ CALL PSLARFG( NS, BETA, 1+IROFFH, 1, WORK(IR), 2+IROFFH, 1,
+ $ DESCR, 1, WORK(ITAU+IROFFH) )
+ CALL PSELSET( WORK(IR), 1+IROFFH, 1, DESCR, ONE )
+*
+ CALL PSLASET( 'Lower', JW-2, JW-2, ZERO, ZERO, T, 3+IROFFH,
+ $ 1+IROFFH, DESCT )
+*
+ CALL PSLARF( 'Left', NS, JW, WORK(IR), 1+IROFFH, 1, DESCR,
+ $ 1, WORK(ITAU+IROFFH), T, 1+IROFFH, 1+IROFFH,
+ $ DESCT, WORK( IPW ) )
+ CALL PSLARF( 'Right', NS, NS, WORK(IR), 1+IROFFH, 1, DESCR,
+ $ 1, WORK(ITAU+IROFFH), T, 1+IROFFH, 1+IROFFH,
+ $ DESCT, WORK( IPW ) )
+ CALL PSLARF( 'Right', JW, NS, WORK(IR), 1+IROFFH, 1, DESCR,
+ $ 1, WORK(ITAU+IROFFH), V, 1+IROFFH, 1+IROFFH,
+ $ DESCV, WORK( IPW ) )
+*
+ ITAU = 1
+ IPW = ITAU + DESCTAU( LLD_ ) * TAUCOLS
+ CALL PSGEHRD( JW+IROFFH, 1+IROFFH, NS+IROFFH, T, 1, 1,
+ $ DESCT, WORK(ITAU), WORK( IPW ), LWORK-IPW+1, INFO )
+ END IF
+*
+* Copy updated reduced window into place.
+*
+ IF( KWTOP.GT.1 ) THEN
+ CALL PSELGET( 'All', '1-Tree', ELEM, V, 1+IROFFH,
+ $ 1+IROFFH, DESCV )
+ CALL PSELSET( H, KWTOP, KWTOP-1, DESCH, S*ELEM )
+ END IF
+ CALL PSLACPY( 'Upper', JW-1, JW-1, T, 1+IROFFH+1, 1+IROFFH,
+ $ DESCT, H, KWTOP+1, KWTOP, DESCH )
+ CALL PSLACPY( 'All', 1, JW, T, 1+IROFFH, 1+IROFFH, DESCT, H,
+ $ KWTOP, KWTOP, DESCH )
+ CALL PSLACPY( 'All', JW-1, 1, T, 1+IROFFH+1, 1+IROFFH+JW-1,
+ $ DESCT, H, KWTOP+1, KWTOP+JW-1, DESCH )
+*
+* Accumulate orthogonal matrix in order to update
+* H and Z, if requested.
+*
+ IF( NS.GT.1 .AND. S.NE.ZERO ) THEN
+ CALL PSORMHR( 'Right', 'No', JW+IROFFH, NS+IROFFH, 1+IROFFH,
+ $ NS+IROFFH, T, 1, 1, DESCT, WORK(ITAU), V, 1,
+ $ 1, DESCV, WORK( IPW ), LWORK-IPW+1, INFO )
+ END IF
+*
+* Update vertical slab in H.
+*
+ IF( WANTT ) THEN
+ LTOP = 1
+ ELSE
+ LTOP = KTOP
+ END IF
+ KLN = MAX( 0, KWTOP-LTOP )
+ IROFFHH = MOD( LTOP-1, NB )
+ ICOFFHH = MOD( KWTOP-1, NB )
+ HHRSRC = INDXG2P( LTOP, NB, MYROW, DESCH(RSRC_), NPROW )
+ HHCSRC = INDXG2P( KWTOP, NB, MYCOL, DESCH(CSRC_), NPCOL )
+ HHROWS = NUMROC( KLN+IROFFHH, NB, MYROW, HHRSRC, NPROW )
+ HHCOLS = NUMROC( JW+ICOFFHH, NB, MYCOL, HHCSRC, NPCOL )
+ CALL DESCINIT( DESCHH, KLN+IROFFHH, JW+ICOFFHH, NB, NB,
+ $ HHRSRC, HHCSRC, ICTXT, MAX(1, HHROWS), IERR )
+ CALL PSGEMM( 'No', 'No', KLN, JW, JW, ONE, H, LTOP,
+ $ KWTOP, DESCH, V, 1+IROFFH, 1+IROFFH, DESCV, ZERO,
+ $ WORK, 1+IROFFHH, 1+ICOFFHH, DESCHH )
+ CALL PSLACPY( 'All', KLN, JW, WORK, 1+IROFFHH, 1+ICOFFHH,
+ $ DESCHH, H, LTOP, KWTOP, DESCH )
+*
+* Update horizontal slab in H.
+*
+ IF( WANTT ) THEN
+ KLN = N-KBOT
+ IROFFHH = MOD( KWTOP-1, NB )
+ ICOFFHH = MOD( KBOT, NB )
+ HHRSRC = INDXG2P( KWTOP, NB, MYROW, DESCH(RSRC_), NPROW )
+ HHCSRC = INDXG2P( KBOT+1, NB, MYCOL, DESCH(CSRC_), NPCOL )
+ HHROWS = NUMROC( JW+IROFFHH, NB, MYROW, HHRSRC, NPROW )
+ HHCOLS = NUMROC( KLN+ICOFFHH, NB, MYCOL, HHCSRC, NPCOL )
+ CALL DESCINIT( DESCHH, JW+IROFFHH, KLN+ICOFFHH, NB, NB,
+ $ HHRSRC, HHCSRC, ICTXT, MAX(1, HHROWS), IERR )
+ CALL PSGEMM( 'Tr', 'No', JW, KLN, JW, ONE, V,
+ $ 1+IROFFH, 1+IROFFH, DESCV, H, KWTOP, KBOT+1,
+ $ DESCH, ZERO, WORK, 1+IROFFHH, 1+ICOFFHH, DESCHH )
+ CALL PSLACPY( 'All', JW, KLN, WORK, 1+IROFFHH, 1+ICOFFHH,
+ $ DESCHH, H, KWTOP, KBOT+1, DESCH )
+ END IF
+*
+* Update vertical slab in Z.
+*
+ IF( WANTZ ) THEN
+ KLN = IHIZ-ILOZ+1
+ IROFFZZ = MOD( ILOZ-1, NB )
+ ICOFFZZ = MOD( KWTOP-1, NB )
+ ZZRSRC = INDXG2P( ILOZ, NB, MYROW, DESCZ(RSRC_), NPROW )
+ ZZCSRC = INDXG2P( KWTOP, NB, MYCOL, DESCZ(CSRC_), NPCOL )
+ ZZROWS = NUMROC( KLN+IROFFZZ, NB, MYROW, ZZRSRC, NPROW )
+ ZZCOLS = NUMROC( JW+ICOFFZZ, NB, MYCOL, ZZCSRC, NPCOL )
+ CALL DESCINIT( DESCZZ, KLN+IROFFZZ, JW+ICOFFZZ, NB, NB,
+ $ ZZRSRC, ZZCSRC, ICTXT, MAX(1, ZZROWS), IERR )
+ CALL PSGEMM( 'No', 'No', KLN, JW, JW, ONE, Z, ILOZ,
+ $ KWTOP, DESCZ, V, 1+IROFFH, 1+IROFFH, DESCV,
+ $ ZERO, WORK, 1+IROFFZZ, 1+ICOFFZZ, DESCZZ )
+ CALL PSLACPY( 'All', KLN, JW, WORK, 1+IROFFZZ, 1+ICOFFZZ,
+ $ DESCZZ, Z, ILOZ, KWTOP, DESCZ )
+ END IF
+ END IF
+*
+* Return the number of deflations (ND) and the number of shifts (NS).
+* (Subtracting INFQR from the spike length takes care of the case of
+* a rare QR failure while calculating eigenvalues of the deflation
+* window.)
+*
+ ND = JW - NS
+ NS = NS - INFQR
+*
+* Return optimal workspace.
+*
+ WORK( 1 ) = FLOAT( LWKOPT )
+ IWORK( 1 ) = ILWKOPT + NSEL
+*
+* End of PSLAQR3
+*
+ END
diff --git a/SRC/pslaqr4.f b/SRC/pslaqr4.f
new file mode 100644
index 0000000..f47a5b4
--- /dev/null
+++ b/SRC/pslaqr4.f
@@ -0,0 +1,633 @@
+ SUBROUTINE PSLAQR4( WANTT, WANTZ, N, ILO, IHI, A, DESCA, WR, WI,
+ $ ILOZ, IHIZ, Z, DESCZ, T, LDT, V, LDV, WORK,
+ $ LWORK, INFO )
+*
+* Contribution from the Department of Computing Science and HPC2N,
+* Umea University, Sweden
+*
+* -- ScaLAPACK auxiliary routine (version 2.0.2) --
+* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver
+* May 1 2012
+*
+ IMPLICIT NONE
+*
+* .. Scalar Arguments ..
+ LOGICAL WANTT, WANTZ
+ INTEGER IHI, IHIZ, ILO, ILOZ, INFO, LDT, LDV, LWORK, N
+* ..
+* .. Array Arguments ..
+ INTEGER DESCA( * ), DESCZ( * )
+ REAL A( * ), T( LDT, * ), V( LDV, * ), WI( * ),
+ $ WORK( * ), WR( * ), Z( * )
+* ..
+*
+* Purpose
+* =======
+*
+* PSLAQR4 is an auxiliary routine used to find the Schur decomposition
+* and or eigenvalues of a matrix already in Hessenberg form from cols
+* ILO to IHI. This routine requires that the active block is small
+* enough, i.e. IHI-ILO+1 .LE. LDT, so that it can be solved by LAPACK.
+* Normally, it is called by PSLAQR1. All the inputs are assumed to be
+* valid without checking.
+*
+* Notes
+* =====
+*
+* Each global data object is described by an associated description
+* vector. This vector stores the information required to establish
+* the mapping between an object element and its corresponding process
+* and memory location.
+*
+* Let A be a generic term for any 2D block cyclicly distributed array.
+* Such a global array has an associated description vector DESCA.
+* In the following comments, the character _ should be read as
+* "of the global array".
+*
+* NOTATION STORED IN EXPLANATION
+* --------------- -------------- --------------------------------------
+* DTYPE_A(global) DESCA( DTYPE_ )The descriptor type. In this case,
+* DTYPE_A = 1.
+* CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating
+* the BLACS process grid A is distribu-
+* ted over. The context itself is glo-
+* bal, but the handle (the integer
+* value) may vary.
+* M_A (global) DESCA( M_ ) The number of rows in the global
+* array A.
+* N_A (global) DESCA( N_ ) The number of columns in the global
+* array A.
+* MB_A (global) DESCA( MB_ ) The blocking factor used to distribute
+* the rows of the array.
+* NB_A (global) DESCA( NB_ ) The blocking factor used to distribute
+* the columns of the array.
+* RSRC_A (global) DESCA( RSRC_ ) The process row over which the first
+* row of the array A is distributed.
+* CSRC_A (global) DESCA( CSRC_ ) The process column over which the
+* first column of the array A is
+* distributed.
+* LLD_A (local) DESCA( LLD_ ) The leading dimension of the local
+* array. LLD_A >= MAX(1,LOCr(M_A)).
+*
+* Let K be the number of rows or columns of a distributed matrix,
+* and assume that its process grid has dimension p x q.
+* LOCr( K ) denotes the number of elements of K that a process
+* would receive if K were distributed over the p processes of its
+* process column.
+* Similarly, LOCc( K ) denotes the number of elements of K that a
+* process would receive if K were distributed over the q processes of
+* its process row.
+* The values of LOCr() and LOCc() may be determined via a call to the
+* ScaLAPACK tool function, NUMROC:
+* LOCr( M ) = NUMROC( M, MB_A, MYROW, RSRC_A, NPROW ),
+* LOCc( N ) = NUMROC( N, NB_A, MYCOL, CSRC_A, NPCOL ).
+* An upper bound for these quantities may be computed by:
+* LOCr( M ) <= ceil( ceil(M/MB_A)/NPROW )*MB_A
+* LOCc( N ) <= ceil( ceil(N/NB_A)/NPCOL )*NB_A
+*
+* Arguments
+* =========
+*
+* WANTT (global input) LOGICAL
+* = .TRUE. : the full Schur form T is required;
+* = .FALSE.: only eigenvalues are required.
+*
+* WANTZ (global input) LOGICAL
+* = .TRUE. : the matrix of Schur vectors Z is required;
+* = .FALSE.: Schur vectors are not required.
+*
+* N (global input) INTEGER
+* The order of the Hessenberg matrix A (and Z if WANTZ).
+* N >= 0.
+*
+* ILO (global input) INTEGER
+* IHI (global input) INTEGER
+* It is assumed that A is already upper quasi-triangular in
+* rows and columns IHI+1:N, and that A(ILO,ILO-1) = 0 (unless
+* ILO = 1). PSLAQR4 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.
+*
+* A (global input/output) REAL array, dimension
+* (DESCA(LLD_),*)
+* On entry, the upper Hessenberg matrix A.
+* On exit, if WANTT is .TRUE., A is upper quasi-triangular in
+* rows and columns ILO:IHI, with any 2-by-2 or larger diagonal
+* blocks not yet in standard form. If WANTT is .FALSE., the
+* contents of A are unspecified on exit.
+*
+* DESCA (global and local input) INTEGER array of dimension DLEN_.
+* The array descriptor for the distributed matrix A.
+*
+* WR (global replicated output) REAL array,
+* dimension (N)
+* WI (global replicated output) REAL array,
+* dimension (N)
+* The real and imaginary parts, respectively, of the computed
+* eigenvalues ILO to IHI are stored in the corresponding
+* elements of WR and WI. If two eigenvalues are computed as a
+* complex conjugate pair, they are stored in consecutive
+* elements of WR and WI, say the i-th and (i+1)th, with
+* WI(i) > 0 and WI(i+1) < 0. If WANTT is .TRUE., the
+* eigenvalues are stored in the same order as on the diagonal
+* of the Schur form returned in A. A may be returned with
+* larger diagonal blocks until the next release.
+*
+* ILOZ (global input) INTEGER
+* IHIZ (global input) INTEGER
+* Specify the rows of Z to which transformations must be
+* applied if WANTZ is .TRUE..
+* 1 <= ILOZ <= ILO; IHI <= IHIZ <= N.
+*
+* Z (global input/output) REAL array.
+* If WANTZ is .TRUE., on entry Z must contain the current
+* matrix Z of transformations accumulated by PDHSEQR, 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.
+*
+* DESCZ (global and local input) INTEGER array of dimension DLEN_.
+* The array descriptor for the distributed matrix Z.
+*
+* T (local workspace) REAL array, dimension LDT*NW.
+*
+* LDT (local input) INTEGER
+* The leading dimension of the array T.
+* LDT >= IHI-ILO+1.
+*
+* V (local workspace) REAL array, dimension LDV*NW.
+*
+* LDV (local input) INTEGER
+* The leading dimension of the array V.
+* LDV >= IHI-ILO+1.
+*
+* WORK (local workspace) REAL array, dimension LWORK.
+*
+* LWORK (local input) INTEGER
+* The dimension of the work array WORK.
+* LWORK >= IHI-ILO+1.
+* WORK(LWORK) is a local array and LWORK is assumed big enough.
+* Typically LWORK >= 4*LDS*LDS if this routine is called by
+* PSLAQR1. (LDS = 385, see PSLAQR1)
+*
+* INFO (global output) INTEGER
+* < 0: parameter number -INFO incorrect or inconsistent;
+* = 0: successful exit;
+* > 0: PSLAQR4 failed to compute all the eigenvalues ILO to IHI
+* in a total of 30*(IHI-ILO+1) iterations; if INFO = i,
+* elements i+1:ihi of WR and WI contain those eigenvalues
+* which have been successfully computed.
+*
+* ================================================================
+* Implemented by
+* Meiyue Shao, Department of Computing Science and HPC2N,
+* Umea University, Sweden
+*
+* ================================================================
+* References:
+* B. Kagstrom, D. Kressner, and M. Shao,
+* On Aggressive Early Deflation in Parallel Variants of the QR
+* Algorithm.
+* Para 2010, to appear.
+*
+* ================================================================
+* .. Parameters ..
+ INTEGER BLOCK_CYCLIC_2D, CSRC_, CTXT_, DLEN_, DTYPE_,
+ $ LLD_, MB_, M_, NB_, N_, RSRC_
+ PARAMETER ( BLOCK_CYCLIC_2D = 1, DLEN_ = 9, DTYPE_ = 1,
+ $ CTXT_ = 2, M_ = 3, N_ = 4, MB_ = 5, NB_ = 6,
+ $ RSRC_ = 7, CSRC_ = 8, LLD_ = 9 )
+ REAL ZERO, ONE
+ PARAMETER ( ZERO = 0.0, ONE = 1.0 )
+* ..
+* .. Local Scalars ..
+ INTEGER CONTXT, HBL, I, I1, I2, IAFIRST, ICOL, ICOL1,
+ $ ICOL2, II, IROW, IROW1, IROW2, ITMP1, ITMP2,
+ $ IERR, J, JAFIRST, JJ, K, L, LDA, LDZ, LLDTMP,
+ $ MYCOL, MYROW, NODE, NPCOL, NPROW, NH, NMIN, NZ,
+ $ HSTEP, VSTEP, KKROW, KKCOL, KLN, LTOP, LEFT,
+ $ RIGHT, UP, DOWN, D1, D2
+* ..
+* .. Local Arrays ..
+ INTEGER DESCT( 9 ), DESCV( 9 ), DESCWH( 9 ),
+ $ DESCWV( 9 )
+* ..
+* .. External Functions ..
+ INTEGER NUMROC, ILAENV
+ EXTERNAL NUMROC, ILAENV
+* ..
+* .. External Subroutines ..
+ EXTERNAL BLACS_GRIDINFO, INFOG2L, SLASET,
+ $ SLAHQR, SLAQR4, DESCINIT, PSGEMM, PSGEMR2D,
+ $ SGEMM, SLAMOV, SGESD2D, SGERV2D,
+ $ SGEBS2D, SGEBR2D, IGEBS2D, IGEBR2D
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, MIN, MOD
+* ..
+* .. Executable Statements ..
+*
+ INFO = 0
+*
+ NH = IHI - ILO + 1
+ NZ = IHIZ - ILOZ + 1
+ IF( N.EQ.0 .OR. NH.EQ.0 )
+ $ RETURN
+*
+* NODE (IAFIRST,JAFIRST) OWNS A(1,1)
+*
+ HBL = DESCA( MB_ )
+ CONTXT = DESCA( CTXT_ )
+ LDA = DESCA( LLD_ )
+ IAFIRST = DESCA( RSRC_ )
+ JAFIRST = DESCA( CSRC_ )
+ LDZ = DESCZ( LLD_ )
+ CALL BLACS_GRIDINFO( CONTXT, NPROW, NPCOL, MYROW, MYCOL )
+ NODE = MYROW*NPCOL + MYCOL
+ LEFT = MOD( MYCOL+NPCOL-1, NPCOL )
+ RIGHT = MOD( MYCOL+1, NPCOL )
+ UP = MOD( MYROW+NPROW-1, NPROW )
+ DOWN = MOD( MYROW+1, NPROW )
+*
+* I1 and I2 are the indices of the first row and last column of A
+* to which transformations must be applied.
+*
+ I = IHI
+ L = ILO
+ IF( WANTT ) THEN
+ I1 = 1
+ I2 = N
+ LTOP = 1
+ ELSE
+ I1 = L
+ I2 = I
+ LTOP = L
+ END IF
+*
+* Copy the diagonal block to local and call LAPACK.
+*
+ CALL INFOG2L( ILO, ILO, DESCA, NPROW, NPCOL, MYROW, MYCOL,
+ $ IROW, ICOL, II, JJ )
+ IF ( MYROW .EQ. II ) THEN
+ CALL DESCINIT( DESCT, NH, NH, NH, NH, II, JJ, CONTXT,
+ $ LDT, IERR )
+ CALL DESCINIT( DESCV, NH, NH, NH, NH, II, JJ, CONTXT,
+ $ LDV, IERR )
+ ELSE
+ CALL DESCINIT( DESCT, NH, NH, NH, NH, II, JJ, CONTXT,
+ $ 1, IERR )
+ CALL DESCINIT( DESCV, NH, NH, NH, NH, II, JJ, CONTXT,
+ $ 1, IERR )
+ END IF
+ CALL PSGEMR2D( NH, NH, A, ILO, ILO, DESCA, T, 1, 1, DESCT,
+ $ CONTXT )
+ IF ( MYROW .EQ. II .AND. MYCOL .EQ. JJ ) THEN
+ CALL SLASET( 'All', NH, NH, ZERO, ONE, V, LDV )
+ NMIN = ILAENV( 12, 'SLAQR3', 'SV', NH, 1, NH, LWORK )
+ IF( NH .GT. NMIN ) THEN
+ CALL SLAQR4( .TRUE., .TRUE., NH, 1, NH, T, LDT, WR( ILO ),
+ $ WI( ILO ), 1, NH, V, LDV, WORK, LWORK, INFO )
+* Clean up the scratch used by SLAQR4.
+ CALL SLASET( 'L', NH-2, NH-2, ZERO, ZERO, T( 3, 1 ), LDT )
+ ELSE
+ CALL SLAHQR( .TRUE., .TRUE., NH, 1, NH, T, LDT, WR( ILO ),
+ $ WI( ILO ), 1, NH, V, LDV, INFO )
+ END IF
+ CALL SGEBS2D( CONTXT, 'All', ' ', NH, NH, V, LDV )
+ CALL IGEBS2D( CONTXT, 'All', ' ', 1, 1, INFO, 1 )
+ ELSE
+ CALL SGEBR2D( CONTXT, 'All', ' ', NH, NH, V, LDV, II, JJ )
+ CALL IGEBR2D( CONTXT, 'All', ' ', 1, 1, INFO, 1, II, JJ )
+ END IF
+ IF( INFO .NE. 0 ) INFO = INFO+ILO-1
+*
+* Copy the local matrix back to the diagonal block.
+*
+ CALL PSGEMR2D( NH, NH, T, 1, 1, DESCT, A, ILO, ILO, DESCA,
+ $ CONTXT )
+*
+* Update T and Z.
+*
+ IF( MOD( ILO-1, HBL )+NH .LE. HBL ) THEN
+*
+* Simplest case: the diagonal block is located on one processor.
+* Call SGEMM directly to perform the update.
+*
+ HSTEP = LWORK / NH
+ VSTEP = HSTEP
+*
+ IF( WANTT ) THEN
+*
+* Update horizontal slab in A.
+*
+ CALL INFOG2L( ILO, I+1, DESCA, NPROW, NPCOL, MYROW,
+ $ MYCOL, IROW, ICOL, II, JJ )
+ IF( MYROW .EQ. II ) THEN
+ ICOL1 = NUMROC( N, HBL, MYCOL, JAFIRST, NPCOL )
+ DO 10 KKCOL = ICOL, ICOL1, HSTEP
+ KLN = MIN( HSTEP, ICOL1-KKCOL+1 )
+ CALL SGEMM( 'T', 'N', NH, KLN, NH, ONE, V,
+ $ LDV, A( IROW+(KKCOL-1)*LDA ), LDA, ZERO, WORK,
+ $ NH )
+ CALL SLAMOV( 'A', NH, KLN, WORK, NH,
+ $ A( IROW+(KKCOL-1)*LDA ), LDA )
+ 10 CONTINUE
+ END IF
+*
+* Update vertical slab in A.
+*
+ CALL INFOG2L( LTOP, ILO, DESCA, NPROW, NPCOL, MYROW,
+ $ MYCOL, IROW, ICOL, II, JJ )
+ IF( MYCOL .EQ. JJ ) THEN
+ CALL INFOG2L( ILO-1, ILO, DESCA, NPROW, NPCOL,
+ $ MYROW, MYCOL, IROW1, ICOL1, ITMP1, ITMP2 )
+ IF( MYROW .NE. ITMP1 ) IROW1 = IROW1-1
+ DO 20 KKROW = IROW, IROW1, VSTEP
+ KLN = MIN( VSTEP, IROW1-KKROW+1 )
+ CALL SGEMM( 'N', 'N', KLN, NH, NH, ONE,
+ $ A( KKROW+(ICOL-1)*LDA ), LDA, V, LDV, ZERO,
+ $ WORK, KLN )
+ CALL SLAMOV( 'A', KLN, NH, WORK, KLN,
+ $ A( KKROW+(ICOL-1)*LDA ), LDA )
+ 20 CONTINUE
+ END IF
+ END IF
+*
+* Update vertical slab in Z.
+*
+ IF( WANTZ ) THEN
+ CALL INFOG2L( ILOZ, ILO, DESCZ, NPROW, NPCOL, MYROW,
+ $ MYCOL, IROW, ICOL, II, JJ )
+ IF( MYCOL .EQ. JJ ) THEN
+ CALL INFOG2L( IHIZ, ILO, DESCZ, NPROW, NPCOL,
+ $ MYROW, MYCOL, IROW1, ICOL1, ITMP1, ITMP2 )
+ IF( MYROW .NE. ITMP1 ) IROW1 = IROW1-1
+ DO 30 KKROW = IROW, IROW1, VSTEP
+ KLN = MIN( VSTEP, IROW1-KKROW+1 )
+ CALL SGEMM( 'N', 'N', KLN, NH, NH, ONE,
+ $ Z( KKROW+(ICOL-1)*LDZ ), LDZ, V, LDV, ZERO,
+ $ WORK, KLN )
+ CALL SLAMOV( 'A', KLN, NH, WORK, KLN,
+ $ Z( KKROW+(ICOL-1)*LDZ ), LDZ )
+ 30 CONTINUE
+ END IF
+ END IF
+*
+ ELSE IF( MOD( ILO-1, HBL )+NH .LE. 2*HBL ) THEN
+*
+* More complicated case: the diagonal block lay on a 2x2
+* processor mesh.
+* Call SGEMM locally and communicate by pair.
+*
+ D1 = HBL - MOD( ILO-1, HBL )
+ D2 = NH - D1
+ HSTEP = LWORK / NH
+ VSTEP = HSTEP
+*
+ IF( WANTT ) THEN
+*
+* Update horizontal slab in A.
+*
+ CALL INFOG2L( ILO, I+1, DESCA, NPROW, NPCOL, MYROW,
+ $ MYCOL, IROW, ICOL, II, JJ )
+ IF( MYROW .EQ. UP ) THEN
+ IF( MYROW .EQ. II ) THEN
+ ICOL1 = NUMROC( N, HBL, MYCOL, JAFIRST, NPCOL )
+ DO 40 KKCOL = ICOL, ICOL1, HSTEP
+ KLN = MIN( HSTEP, ICOL1-KKCOL+1 )
+ CALL SGEMM( 'T', 'N', NH, KLN, NH, ONE, V,
+ $ NH, A( IROW+(KKCOL-1)*LDA ), LDA, ZERO,
+ $ WORK, NH )
+ CALL SLAMOV( 'A', NH, KLN, WORK, NH,
+ $ A( IROW+(KKCOL-1)*LDA ), LDA )
+ 40 CONTINUE
+ END IF
+ ELSE
+ IF( MYROW .EQ. II ) THEN
+ ICOL1 = NUMROC( N, HBL, MYCOL, JAFIRST, NPCOL )
+ DO 50 KKCOL = ICOL, ICOL1, HSTEP
+ KLN = MIN( HSTEP, ICOL1-KKCOL+1 )
+ CALL SGEMM( 'T', 'N', D2, KLN, D1, ONE,
+ $ V( 1, D1+1 ), LDV, A( IROW+(KKCOL-1)*LDA ),
+ $ LDA, ZERO, WORK( D1+1 ), NH )
+ CALL SGESD2D( CONTXT, D2, KLN, WORK( D1+1 ),
+ $ NH, DOWN, MYCOL )
+ CALL SGERV2D( CONTXT, D1, KLN, WORK, NH, DOWN,
+ $ MYCOL )
+ CALL SGEMM( 'T', 'N', D1, KLN, D1, ONE,
+ $ V, LDV, A( IROW+(KKCOL-1)*LDA ), LDA, ONE,
+ $ WORK, NH )
+ CALL SLAMOV( 'A', D1, KLN, WORK, NH,
+ $ A( IROW+(KKCOL-1)*LDA ), LDA )
+ 50 CONTINUE
+ ELSE IF( UP .EQ. II ) THEN
+ ICOL1 = NUMROC( N, HBL, MYCOL, JAFIRST, NPCOL )
+ DO 60 KKCOL = ICOL, ICOL1, HSTEP
+ KLN = MIN( HSTEP, ICOL1-KKCOL+1 )
+ CALL SGEMM( 'T', 'N', D1, KLN, D2, ONE,
+ $ V( D1+1, 1 ), LDV, A( IROW+(KKCOL-1)*LDA ),
+ $ LDA, ZERO, WORK, NH )
+ CALL SGESD2D( CONTXT, D1, KLN, WORK, NH, UP,
+ $ MYCOL )
+ CALL SGERV2D( CONTXT, D2, KLN, WORK( D1+1 ),
+ $ NH, UP, MYCOL )
+ CALL SGEMM( 'T', 'N', D2, KLN, D2, ONE,
+ $ V( D1+1, D1+1 ), LDV,
+ $ A( IROW+(KKCOL-1)*LDA ), LDA, ONE,
+ $ WORK( D1+1 ), NH )
+ CALL SLAMOV( 'A', D2, KLN, WORK( D1+1 ), NH,
+ $ A( IROW+(KKCOL-1)*LDA ), LDA )
+ 60 CONTINUE
+ END IF
+ END IF
+*
+* Update vertical slab in A.
+*
+ CALL INFOG2L( LTOP, ILO, DESCA, NPROW, NPCOL, MYROW,
+ $ MYCOL, IROW, ICOL, II, JJ )
+ IF( MYCOL .EQ. LEFT ) THEN
+ IF( MYCOL .EQ. JJ ) THEN
+ CALL INFOG2L( ILO-1, ILO, DESCA, NPROW, NPCOL,
+ $ MYROW, MYCOL, IROW1, ICOL1, ITMP1, ITMP2 )
+ IF( MYROW .NE. ITMP1 ) IROW1 = IROW1-1
+ DO 70 KKROW = IROW, IROW1, VSTEP
+ KLN = MIN( VSTEP, IROW1-KKROW+1 )
+ CALL SGEMM( 'N', 'N', KLN, NH, NH, ONE,
+ $ A( KKROW+(ICOL-1)*LDA ), LDA, V, LDV,
+ $ ZERO, WORK, KLN )
+ CALL SLAMOV( 'A', KLN, NH, WORK, KLN,
+ $ A( KKROW+(ICOL-1)*LDA ), LDA )
+ 70 CONTINUE
+ END IF
+ ELSE
+ IF( MYCOL .EQ. JJ ) THEN
+ CALL INFOG2L( ILO-1, ILO, DESCA, NPROW, NPCOL,
+ $ MYROW, MYCOL, IROW1, ICOL1, ITMP1, ITMP2 )
+ IF( MYROW .NE. ITMP1 ) IROW1 = IROW1-1
+ DO 80 KKROW = IROW, IROW1, VSTEP
+ KLN = MIN( VSTEP, IROW1-KKROW+1 )
+ CALL SGEMM( 'N', 'N', KLN, D2, D1, ONE,
+ $ A( KKROW+(ICOL-1)*LDA ), LDA, V( 1, D1+1 ),
+ $ LDV, ZERO, WORK( 1+D1*KLN ), KLN )
+ CALL SGESD2D( CONTXT, KLN, D2, WORK( 1+D1*KLN ),
+ $ KLN, MYROW, RIGHT )
+ CALL SGERV2D( CONTXT, KLN, D1, WORK, KLN, MYROW,
+ $ RIGHT )
+ CALL SGEMM( 'N', 'N', KLN, D1, D1, ONE,
+ $ A( KKROW+(ICOL-1)*LDA ), LDA, V, LDV, ONE,
+ $ WORK, KLN )
+ CALL SLAMOV( 'A', KLN, D1, WORK, KLN,
+ $ A( KKROW+(ICOL-1)*LDA ), LDA )
+ 80 CONTINUE
+ ELSE IF ( LEFT .EQ. JJ ) THEN
+ CALL INFOG2L( ILO-1, ILO, DESCA, NPROW, NPCOL,
+ $ MYROW, MYCOL, IROW1, ICOL1, ITMP1, ITMP2 )
+ IF( MYROW .NE. ITMP1 ) IROW1 = IROW1-1
+ DO 90 KKROW = IROW, IROW1, VSTEP
+ KLN = MIN( VSTEP, IROW1-KKROW+1 )
+ CALL SGEMM( 'N', 'N', KLN, D1, D2, ONE,
+ $ A( KKROW+(ICOL-1)*LDA ), LDA, V( D1+1, 1 ),
+ $ LDV, ZERO, WORK, KLN )
+ CALL SGESD2D( CONTXT, KLN, D1, WORK, KLN, MYROW,
+ $ LEFT )
+ CALL SGERV2D( CONTXT, KLN, D2, WORK( 1+D1*KLN ),
+ $ KLN, MYROW, LEFT )
+ CALL SGEMM( 'N', 'N', KLN, D2, D2, ONE,
+ $ A( KKROW+(ICOL-1)*LDA ), LDA, V( D1+1, D1+1 ),
+ $ LDV, ONE, WORK( 1+D1*KLN ), KLN )
+ CALL SLAMOV( 'A', KLN, D2, WORK( 1+D1*KLN ), KLN,
+ $ A( KKROW+(ICOL-1)*LDA ), LDA )
+ 90 CONTINUE
+ END IF
+ END IF
+ END IF
+*
+* Update vertical slab in Z.
+*
+ IF( WANTZ ) THEN
+ CALL INFOG2L( ILOZ, ILO, DESCZ, NPROW, NPCOL, MYROW,
+ $ MYCOL, IROW, ICOL, II, JJ )
+ IF( MYCOL .EQ. LEFT ) THEN
+ IF( MYCOL .EQ. JJ ) THEN
+ CALL INFOG2L( IHIZ, ILO, DESCZ, NPROW, NPCOL,
+ $ MYROW, MYCOL, IROW1, ICOL1, ITMP1, ITMP2 )
+ IF( MYROW .NE. ITMP1 ) IROW1 = IROW1-1
+ DO 100 KKROW = IROW, IROW1, VSTEP
+ KLN = MIN( VSTEP, IROW1-KKROW+1 )
+ CALL SGEMM( 'N', 'N', KLN, NH, NH, ONE,
+ $ Z( KKROW+(ICOL-1)*LDZ ), LDZ, V, LDV, ZERO,
+ $ WORK, KLN )
+ CALL SLAMOV( 'A', KLN, NH, WORK, KLN,
+ $ Z( KKROW+(ICOL-1)*LDZ ), LDZ )
+ 100 CONTINUE
+ END IF
+ ELSE
+ IF( MYCOL .EQ. JJ ) THEN
+ CALL INFOG2L( IHIZ, ILO, DESCZ, NPROW, NPCOL,
+ $ MYROW, MYCOL, IROW1, ICOL1, ITMP1, ITMP2 )
+ IF( MYROW .NE. ITMP1 ) IROW1 = IROW1-1
+ DO 110 KKROW = IROW, IROW1, VSTEP
+ KLN = MIN( VSTEP, IROW1-KKROW+1 )
+ CALL SGEMM( 'N', 'N', KLN, D2, D1, ONE,
+ $ Z( KKROW+(ICOL-1)*LDZ ), LDZ, V( 1, D1+1 ),
+ $ LDV, ZERO, WORK( 1+D1*KLN ), KLN )
+ CALL SGESD2D( CONTXT, KLN, D2, WORK( 1+D1*KLN ),
+ $ KLN, MYROW, RIGHT )
+ CALL SGERV2D( CONTXT, KLN, D1, WORK, KLN, MYROW,
+ $ RIGHT )
+ CALL SGEMM( 'N', 'N', KLN, D1, D1, ONE,
+ $ Z( KKROW+(ICOL-1)*LDZ ), LDZ, V, LDV, ONE,
+ $ WORK, KLN )
+ CALL SLAMOV( 'A', KLN, D1, WORK, KLN,
+ $ Z( KKROW+(ICOL-1)*LDZ ), LDZ )
+ 110 CONTINUE
+ ELSE IF( LEFT .EQ. JJ ) THEN
+ CALL INFOG2L( IHIZ, ILO, DESCZ, NPROW, NPCOL,
+ $ MYROW, MYCOL, IROW1, ICOL1, ITMP1, ITMP2 )
+ IF( MYROW .NE. ITMP1 ) IROW1 = IROW1-1
+ DO 120 KKROW = IROW, IROW1, VSTEP
+ KLN = MIN( VSTEP, IROW1-KKROW+1 )
+ CALL SGEMM( 'N', 'N', KLN, D1, D2, ONE,
+ $ Z( KKROW+(ICOL-1)*LDZ ), LDZ, V( D1+1, 1 ),
+ $ LDV, ZERO, WORK, KLN )
+ CALL SGESD2D( CONTXT, KLN, D1, WORK, KLN, MYROW,
+ $ LEFT )
+ CALL SGERV2D( CONTXT, KLN, D2, WORK( 1+D1*KLN ),
+ $ KLN, MYROW, LEFT )
+ CALL SGEMM( 'N', 'N', KLN, D2, D2, ONE,
+ $ Z( KKROW+(ICOL-1)*LDZ ), LDZ,
+ $ V( D1+1, D1+1 ), LDV, ONE, WORK( 1+D1*KLN ),
+ $ KLN )
+ CALL SLAMOV( 'A', KLN, D2, WORK( 1+D1*KLN ),
+ $ KLN, Z( KKROW+(ICOL-1)*LDZ ), LDZ )
+ 120 CONTINUE
+ END IF
+ END IF
+ END IF
+*
+ ELSE
+*
+* Most complicated case: the diagonal block lay across the border
+* of the processor mesh.
+* Treat V as a distributed matrix and call PSGEMM.
+*
+ HSTEP = LWORK / NH * NPCOL
+ VSTEP = LWORK / NH * NPROW
+ LLDTMP = NUMROC( NH, NH, MYROW, 0, NPROW )
+ LLDTMP = MAX( 1, LLDTMP )
+ CALL DESCINIT( DESCV, NH, NH, NH, NH, 0, 0, CONTXT,
+ $ LLDTMP, IERR )
+ CALL DESCINIT( DESCWH, NH, HSTEP, NH, LWORK / NH, 0, 0,
+ $ CONTXT, LLDTMP, IERR )
+*
+ IF( WANTT ) THEN
+*
+* Update horizontal slab in A.
+*
+ DO 130 KKCOL = I+1, N, HSTEP
+ KLN = MIN( HSTEP, N-KKCOL+1 )
+ CALL PSGEMM( 'T', 'N', NH, KLN, NH, ONE, V, 1, 1,
+ $ DESCV, A, ILO, KKCOL, DESCA, ZERO, WORK, 1, 1,
+ $ DESCWH )
+ CALL PSGEMR2D( NH, KLN, WORK, 1, 1, DESCWH, A,
+ $ ILO, KKCOL, DESCA, CONTXT )
+ 130 CONTINUE
+*
+* Update vertical slab in A.
+*
+ DO 140 KKROW = LTOP, ILO-1, VSTEP
+ KLN = MIN( VSTEP, ILO-KKROW )
+ LLDTMP = NUMROC( KLN, LWORK / NH, MYROW, 0, NPROW )
+ LLDTMP = MAX( 1, LLDTMP )
+ CALL DESCINIT( DESCWV, KLN, NH, LWORK / NH, NH, 0, 0,
+ $ CONTXT, LLDTMP, IERR )
+ CALL PSGEMM( 'N', 'N', KLN, NH, NH, ONE, A, KKROW,
+ $ ILO, DESCA, V, 1, 1, DESCV, ZERO, WORK, 1, 1,
+ $ DESCWV )
+ CALL PSGEMR2D( KLN, NH, WORK, 1, 1, DESCWV, A, KKROW,
+ $ ILO, DESCA, CONTXT )
+ 140 CONTINUE
+ END IF
+*
+* Update vertical slab in Z.
+*
+ IF( WANTZ ) THEN
+ DO 150 KKROW = ILOZ, IHIZ, VSTEP
+ KLN = MIN( VSTEP, IHIZ-KKROW+1 )
+ LLDTMP = NUMROC( KLN, LWORK / NH, MYROW, 0, NPROW )
+ LLDTMP = MAX( 1, LLDTMP )
+ CALL DESCINIT( DESCWV, KLN, NH, LWORK / NH, NH, 0, 0,
+ $ CONTXT, LLDTMP, IERR )
+ CALL PSGEMM( 'N', 'N', KLN, NH, NH, ONE, Z, KKROW,
+ $ ILO, DESCZ, V, 1, 1, DESCV, ZERO, WORK, 1, 1,
+ $ DESCWV )
+ CALL PSGEMR2D( KLN, NH, WORK, 1, 1, DESCWV, Z,
+ $ KKROW, ILO, DESCZ, CONTXT )
+ 150 CONTINUE
+ END IF
+ END IF
+*
+* END OF PSLAQR4
+*
+ END
diff --git a/SRC/pslaqr5.f b/SRC/pslaqr5.f
new file mode 100644
index 0000000..9cba43a
--- /dev/null
+++ b/SRC/pslaqr5.f
@@ -0,0 +1,2275 @@
+ SUBROUTINE PSLAQR5( WANTT, WANTZ, KACC22, N, KTOP, KBOT, NSHFTS,
+ $ SR, SI, H, DESCH, ILOZ, IHIZ, Z, DESCZ, WORK,
+ $ LWORK, IWORK, LIWORK )
+*
+* Contribution from the Department of Computing Science and HPC2N,
+* Umea University, Sweden
+*
+* -- ScaLAPACK auxiliary routine (version 2.0.2) --
+* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver
+* May 1 2012
+*
+ IMPLICIT NONE
+*
+* .. Scalar Arguments ..
+ INTEGER IHIZ, ILOZ, KACC22, KBOT, KTOP, N, NSHFTS,
+ $ LWORK, LIWORK
+ LOGICAL WANTT, WANTZ
+* ..
+* .. Array Arguments ..
+ INTEGER DESCH( * ), DESCZ( * ), IWORK( * )
+ REAL H( * ), SI( * ), SR( * ), Z( * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* This auxiliary subroutine called by PSLAQR0 performs a
+* single small-bulge multi-shift QR sweep by chasing separated
+* groups of bulges along the main block diagonal of H.
+*
+* WANTT (global input) logical scalar
+* WANTT = .TRUE. if the quasi-triangular Schur factor
+* is being computed. WANTT is set to .FALSE. otherwise.
+*
+* WANTZ (global input) logical scalar
+* WANTZ = .TRUE. if the orthogonal Schur factor is being
+* computed. WANTZ is set to .FALSE. otherwise.
+*
+* KACC22 (global input) integer with value 0, 1, or 2.
+* Specifies the computation mode of far-from-diagonal
+* orthogonal updates.
+* = 1: PSLAQR5 accumulates reflections and uses matrix-matrix
+* multiply to update the far-from-diagonal matrix entries.
+* = 2: PSLAQR5 accumulates reflections, uses matrix-matrix
+* multiply to update the far-from-diagonal matrix entries,
+* and takes advantage of 2-by-2 block structure during
+* matrix multiplies.
+*
+* N (global input) integer scalar
+* N is the order of the Hessenberg matrix H upon which this
+* subroutine operates.
+*
+* KTOP (global input) integer scalar
+* KBOT (global input) integer scalar
+* These are the first and last rows and columns of an
+* isolated diagonal block upon which the QR sweep is to be
+* applied. It is assumed without a check that
+* either KTOP = 1 or H(KTOP,KTOP-1) = 0
+* and
+* either KBOT = N or H(KBOT+1,KBOT) = 0.
+*
+* NSHFTS (global input) integer scalar
+* NSHFTS gives the number of simultaneous shifts. NSHFTS
+* must be positive and even.
+*
+* SR (global input) REAL array of size (NSHFTS)
+* SI (global input) REAL array of size (NSHFTS)
+* SR contains the real parts and SI contains the imaginary
+* parts of the NSHFTS shifts of origin that define the
+* multi-shift QR sweep.
+*
+* H (local input/output) REAL array of size
+* (DESCH(LLD_),*)
+* 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.
+*
+* DESCH (global and local input) INTEGER array of dimension DLEN_.
+* The array descriptor for the distributed matrix H.
+*
+* ILOZ (global input) INTEGER
+* IHIZ (global input) INTEGER
+* Specify the rows of Z to which transformations must be
+* applied if WANTZ is .TRUE.. 1 .LE. ILOZ .LE. IHIZ .LE. N
+*
+* Z (local input/output) REAL array of size
+* (DESCZ(LLD_),*)
+* If WANTZ = .TRUE., then the QR Sweep orthogonal
+* similarity transformation is accumulated into
+* Z(ILOZ:IHIZ,ILO:IHI) from the right.
+* If WANTZ = .FALSE., then Z is unreferenced.
+*
+* DESCZ (global and local input) INTEGER array of dimension DLEN_.
+* The array descriptor for the distributed matrix Z.
+*
+* WORK (local workspace) REAL array, dimension(DWORK)
+*
+* LWORK (local input) INTEGER
+* The length of the workspace array WORK.
+*
+* IWORK (local workspace) INTEGER array, dimension (LIWORK)
+*
+* LIWORK (local input) INTEGER
+* The length of the workspace array IWORK.
+*
+* ================================================================
+* Based on contributions by
+* Robert Granat, Department of Computing Science and HPC2N,
+* University of Umea, Sweden.
+*
+* ============================================================
+* References:
+* K. Braman, R. Byers, and R. Mathias,
+* The Multi-Shift QR Algorithm Part I: Maintaining Well Focused
+* Shifts, and Level 3 Performance.
+* SIAM J. Matrix Anal. Appl., 23(4):929--947, 2002.
+*
+* R. Granat, B. Kagstrom, and D. Kressner,
+* A Novel Parallel QR Algorithm for Hybrid Distributed Momory HPC
+* Systems.
+* SIAM J. Sci. Comput., 32(4):2345--2378, 2010.
+*
+* ============================================================
+* .. Parameters ..
+ INTEGER BLOCK_CYCLIC_2D, CSRC_, CTXT_, DLEN_, DTYPE_,
+ $ LLD_, MB_, M_, NB_, N_, RSRC_
+ PARAMETER ( BLOCK_CYCLIC_2D = 1, DLEN_ = 9, DTYPE_ = 1,
+ $ CTXT_ = 2, M_ = 3, N_ = 4, MB_ = 5, NB_ = 6,
+ $ RSRC_ = 7, CSRC_ = 8, LLD_ = 9 )
+ REAL ZERO, ONE
+ PARAMETER ( ZERO = 0.0e0, ONE = 1.0e0 )
+ INTEGER NTINY
+ PARAMETER ( NTINY = 11 )
+* ..
+* .. Local Scalars ..
+ REAL ALPHA, BETA, H11, H12, H21, H22, REFSUM,
+ $ SAFMAX, SAFMIN, SCL, SMLNUM, SWAP, TST1, TST2,
+ $ ULP, TAU, ELEM, STAMP, DDUM, ORTH
+ 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, LLDH, LLDZ, LLDU, LLDV, LLDW, LLDWH,
+ $ INFO, ICTXT, NPROW, NPCOL, NB, IROFFH, ITOP,
+ $ NWIN, MYROW, MYCOL, LNS, NUMWIN, LKACC22,
+ $ LCHAIN, WIN, IDONEJOB, IPNEXT, ANMWIN, LENRBUF,
+ $ LENCBUF, ICHOFF, LRSRC, LCSRC, LKTOP, LKBOT,
+ $ II, JJ, SWIN, EWIN, LNWIN, DIM, LLKTOP, LLKBOT,
+ $ IPV, IPU, IPH, IPW, KU, KWH, KWV, NVE, LKS,
+ $ IDUM, NHO, DIR, WINID, INDX, ILOC, JLOC, RSRC1,
+ $ CSRC1, RSRC2, CSRC2, RSRC3, CSRC3, RSRC4, IPUU,
+ $ CSRC4, LROWS, LCOLS, INDXS, KS, JLOC1, ILOC1,
+ $ LKTOP1, LKTOP2, WCHUNK, NUMCHUNK, ODDEVEN,
+ $ CHUNKNUM, DIM1, DIM4, IPW3, HROWS, ZROWS,
+ $ HCOLS, IPW1, IPW2, RSRC, EAST, JLOC4, ILOC4,
+ $ WEST, CSRC, SOUTH, NORHT, INDXE, NORTH,
+ $ IHH, IPIW, LKBOT1, NPROCS, LIROFFH,
+ $ WINFIN, RWS3, CLS3, INDX2, HROWS2,
+ $ ZROWS2, HCOLS2, MNRBUF,
+ $ MXRBUF, MNCBUF, MXCBUF, LWKOPT
+ LOGICAL BLK22, BMP22, INTRO, DONEJOB, ODDNPROW,
+ $ ODDNPCOL, LQUERY, BCDONE
+ CHARACTER JBCMPZ*2, JOB
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ INTEGER PILAENVX, ICEIL, INDXG2P, INDXG2L, NUMROC
+ REAL SLAMCH, SLANGE
+ EXTERNAL SLAMCH, PILAENVX, ICEIL, INDXG2P, INDXG2L,
+ $ NUMROC, LSAME, SLANGE
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, FLOAT, MAX, MIN, MOD
+* ..
+* .. Local Arrays ..
+ REAL VT( 3 )
+* ..
+* .. External Subroutines ..
+ EXTERNAL SGEMM, SLABAD, SLAMOV, SLAQR1, SLARFG, SLASET,
+ $ STRMM, SLAQR6
+* ..
+* .. Executable Statements ..
+*
+ INFO = 0
+ ICTXT = DESCH( CTXT_ )
+ CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL )
+ NPROCS = NPROW*NPCOL
+ LLDH = DESCH( LLD_ )
+ LLDZ = DESCZ( LLD_ )
+ NB = DESCH( MB_ )
+ IROFFH = MOD( KTOP - 1, NB )
+ LQUERY = LWORK.EQ.-1 .OR. LIWORK.EQ.-1
+*
+* If there are no shifts, then there is nothing to do.
+*
+ IF( .NOT. LQUERY .AND. NSHFTS.LT.2 )
+ $ RETURN
+*
+* If the active block is empty or 1-by-1, then there
+* is nothing to do.
+*
+ IF( .NOT. LQUERY .AND. 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.
+*
+ IF( .NOT. LQUERY ) THEN
+ 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
+ END IF
+*
+* NSHFTS is supposed to be even, but if is odd,
+* then simply reduce it by one. The shuffle above
+* ensures that the dropped shift is real and that
+* the remaining shifts are paired.
+*
+ NS = NSHFTS - MOD( NSHFTS, 2 )
+*
+* Extract the size of the computational window.
+*
+ NWIN = PILAENVX( ICTXT, 19, 'PSLAQR5', JBCMPZ, N, NB, NB, NB )
+ NWIN = MIN( NWIN, KBOT-KTOP+1 )
+*
+* Adjust number of simultaneous shifts if it exceeds the limit
+* set by the number of diagonal blocks in the active submatrix
+* H(KTOP:KBOT,KTOP:KBOT).
+*
+ NS = MAX( 2, MIN( NS, ICEIL( KBOT-KTOP+1, NB )*NWIN/3 ) )
+ NS = NS - MOD( NS, 2 )
+
+*
+* Decide the number of simultaneous computational windows
+* from the number of shifts - each window should contain up to
+* (NWIN / 3) shifts. Also compute the number of shifts per
+* window and make sure that number is even.
+*
+ LNS = MIN( MAX( 2, NWIN / 3 ), MAX( 2, NS / MIN(NPROW,NPCOL) ) )
+ LNS = LNS - MOD( LNS, 2 )
+ NUMWIN = MAX( 1, MIN( ICEIL( NS, LNS ),
+ $ ICEIL( KBOT-KTOP+1, NB ) - 1 ) )
+ IF( NPROW.NE.NPCOL ) THEN
+ NUMWIN = MIN( NUMWIN, MIN(NPROW,NPCOL) )
+ LNS = MIN( LNS, MAX( 2, NS / MIN(NPROW,NPCOL) ) )
+ LNS = LNS - MOD( LNS, 2 )
+ END IF
+*
+* Machine constants for deflation.
+*
+ SAFMIN = SLAMCH( 'SAFE MINIMUM' )
+ SAFMAX = ONE / SAFMIN
+ CALL SLABAD( SAFMIN, SAFMAX )
+ ULP = SLAMCH( 'PRECISION' )
+ SMLNUM = SAFMIN*( FLOAT( N ) / ULP )
+*
+* Use accumulated reflections to update far-from-diagonal
+* entries on a local level?
+*
+ IF( LNS.LT.14 ) THEN
+ LKACC22 = 1
+ ELSE
+ LKACC22 = 2
+ END IF
+*
+* If so, exploit the 2-by-2 block structure?
+* ( Usually it is not efficient to exploit the 2-by-2 structure
+* because the block size is too small. )
+*
+ BLK22 = ( LNS.GT.2 ) .AND. ( KACC22.EQ.2 )
+*
+* Clear trash.
+*
+ IF( .NOT. LQUERY .AND. KTOP+2.LE.KBOT )
+ $ CALL PSELSET( H, KTOP+2, KTOP, DESCH, ZERO )
+*
+* NBMPS = number of 2-shift bulges in each chain
+*
+ NBMPS = LNS / 2
+*
+* KDU = width of slab
+*
+ KDU = 6*NBMPS - 3
+*
+* LCHAIN = length of each chain
+*
+ LCHAIN = 3 * NBMPS + 1
+*
+* Check if workspace query.
+*
+ IF( LQUERY ) THEN
+ HROWS = NUMROC( N, NB, MYROW, DESCH(RSRC_), NPROW )
+ HCOLS = NUMROC( N, NB, MYCOL, DESCH(CSRC_), NPCOL )
+ LWKOPT = (5+2*NUMWIN)*NB**2 + 2*HROWS*NB + HCOLS*NB +
+ $ MAX( HROWS*NB, HCOLS*NB )
+ WORK(1) = FLOAT(LWKOPT)
+ IWORK(1) = 5*NUMWIN
+ RETURN
+ END IF
+*
+* Check if KTOP and KBOT are valid.
+*
+ IF( KTOP.LT.1 .OR. KBOT.GT.N ) STOP
+*
+* Create and chase NUMWIN chains of NBMPS bulges.
+*
+* Set up window introduction.
+*
+ ANMWIN = 0
+ INTRO = .TRUE.
+ IPIW = 1
+*
+* Main loop:
+* While-loop over the computational windows which is
+* terminated when all windows have been introduced,
+* chased down to the bottom of the considered submatrix
+* and chased off.
+*
+ 20 CONTINUE
+*
+* Set up next window as long as we have less than the prescribed
+* number of windows. Each window is described an integer quadruple:
+* 1. Local value of KTOP (below denoted by LKTOP)
+* 2. Local value of KBOT (below denoted by LKBOT)
+* 3-4. Processor indices (LRSRC,LCSRC) associated with the window.
+* (5. Mark that decides if a window is fully processed or not)
+*
+* Notice - the next window is only introduced if the first block
+* in the active submatrix does not contain any other windows.
+*
+ IF( ANMWIN.GT.0 ) THEN
+ LKTOP = IWORK( 1+(ANMWIN-1)*5 )
+ ELSE
+ LKTOP = KTOP
+ END IF
+ IF( INTRO .AND. (ANMWIN.EQ.0 .OR. LKTOP.GT.ICEIL(KTOP,NB)*NB) )
+ $ THEN
+ ANMWIN = ANMWIN + 1
+*
+* Structure of IWORK:
+* IWORK( 1+(WIN-1)*5 ): start position
+* IWORK( 2+(WIN-1)*5 ): stop position
+* IWORK( 3+(WIN-1)*5 ): processor row id
+* IWORK( 4+(WIN-1)*5 ): processor col id
+* IWORK( 5+(WIN-1)*5 ): window status (0, 1, or 2)
+*
+ IWORK( 1+(ANMWIN-1)*5 ) = KTOP
+ IWORK( 2+(ANMWIN-1)*5 ) = KTOP +
+ $ MIN( NWIN,NB-IROFFH,KBOT-KTOP+1 ) - 1
+ IWORK( 3+(ANMWIN-1)*5 ) = INDXG2P( IWORK(1+(ANMWIN-1)*5), NB,
+ $ MYROW, DESCH(RSRC_), NPROW )
+ IWORK( 4+(ANMWIN-1)*5 ) = INDXG2P( IWORK(2+(ANMWIN-1)*5), NB,
+ $ MYCOL, DESCH(CSRC_), NPCOL )
+ IWORK( 5+(ANMWIN-1)*5 ) = 0
+ IPIW = 6+(ANMWIN-1)*5
+ IF( ANMWIN.EQ.NUMWIN ) INTRO = .FALSE.
+ END IF
+*
+* Do-loop over the number of windows.
+*
+ IPNEXT = 1
+ DONEJOB = .FALSE.
+ IDONEJOB = 0
+ LENRBUF = 0
+ LENCBUF = 0
+ ICHOFF = 0
+ DO 40 WIN = 1, ANMWIN
+*
+* Extract window information to simplify the rest.
+*
+ LRSRC = IWORK( 3+(WIN-1)*5 )
+ LCSRC = IWORK( 4+(WIN-1)*5 )
+ LKTOP = IWORK( 1+(WIN-1)*5 )
+ LKBOT = IWORK( 2+(WIN-1)*5 )
+ LNWIN = LKBOT - LKTOP + 1
+*
+* Check if anything to do for current window, i.e., if the local
+* chain of bulges has reached the next block border etc.
+*
+ IF( IWORK(5+(WIN-1)*5).LT.2 .AND. LNWIN.GT.1 .AND.
+ $ (LNWIN.GT.LCHAIN .OR. LKBOT.EQ.KBOT ) ) THEN
+ LIROFFH = MOD(LKTOP-1,NB)
+ SWIN = LKTOP-LIROFFH
+ EWIN = MIN(KBOT,LKTOP-LIROFFH+NB-1)
+ DIM = EWIN-SWIN+1
+ IF( DIM.LE.NTINY .AND. .NOT.LKBOT.EQ.KBOT ) THEN
+ IWORK( 5+(WIN-1)*5 ) = 2
+ GO TO 45
+ END IF
+ IDONEJOB = 1
+ IF( IWORK(5+(WIN-1)*5).EQ.0 ) THEN
+ IWORK(5+(WIN-1)*5) = 1
+ END IF
+*
+* Let the process that owns the corresponding window do the
+* local bulge chase.
+*
+ IF( MYROW.EQ.LRSRC .AND. MYCOL.EQ.LCSRC ) THEN
+*
+* Set the kind of job to do in SLAQR6:
+* 1. JOB = 'I': Introduce and chase bulges in window WIN
+* 2. JOB = 'C': Chase bulges from top to bottom of window WIN
+* 3. JOB = 'O': Chase bulges off window WIN
+* 4. JOB = 'A': All of 1-3 above is done - this will for
+* example happen for very small active
+* submatrices (like 2-by-2)
+*
+ LLKBOT = LLKTOP + LNWIN - 1
+ IF( LKTOP.EQ.KTOP .AND. LKBOT.EQ.KBOT ) THEN
+ JOB = 'All steps'
+ ICHOFF = 1
+ ELSEIF( LKTOP.EQ.KTOP ) THEN
+ JOB = 'Introduce and chase'
+ ELSEIF( LKBOT.EQ.KBOT ) THEN
+ JOB = 'Off-chase bulges'
+ ICHOFF = 1
+ ELSE
+ JOB = 'Chase bulges'
+ END IF
+*
+* Copy submatrix of H corresponding to window WIN into
+* workspace and set out additional workspace for storing
+* orthogonal transformations. This submatrix must be at
+* least (NTINY+1)-by-(NTINY+1) to fit into SLAQR6 - if not,
+* abort and go for cross border bulge chasing with this
+* particular window.
+*
+ II = INDXG2L( SWIN, NB, MYROW, DESCH(RSRC_), NPROW )
+ JJ = INDXG2L( SWIN, NB, MYCOL, DESCH(CSRC_), NPCOL )
+ LLKTOP = 1 + LIROFFH
+ LLKBOT = LLKTOP + LNWIN - 1
+*
+ IPU = IPNEXT
+ IPH = IPU + LNWIN**2
+ IPUU = IPH + MAX(NTINY+1,DIM)**2
+ IPV = IPUU + MAX(NTINY+1,DIM)**2
+ IPNEXT = IPH
+*
+ IF( LSAME( JOB, 'A' ) .OR. LSAME( JOB, 'O' ) .AND.
+ $ DIM.LT.NTINY+1 ) THEN
+ CALL SLASET( 'All', NTINY+1, NTINY+1, ZERO, ONE,
+ $ WORK(IPH), NTINY+1 )
+ END IF
+ CALL SLAMOV( 'Upper', DIM, DIM, H(II+(JJ-1)*LLDH), LLDH,
+ $ WORK(IPH), MAX(NTINY+1,DIM) )
+ CALL SCOPY( DIM-1, H(II+(JJ-1)*LLDH+1), LLDH+1,
+ $ WORK(IPH+1), MAX(NTINY+1,DIM)+1 )
+ IF( LSAME( JOB, 'C' ) .OR. LSAME( JOB, 'O') ) THEN
+ CALL SCOPY( DIM-2, H(II+(JJ-1)*LLDH+2), LLDH+1,
+ $ WORK(IPH+2), MAX(NTINY+1,DIM)+1 )
+ CALL SCOPY( DIM-3, H(II+(JJ-1)*LLDH+3), LLDH+1,
+ $ WORK(IPH+3), MAX(NTINY+1,DIM)+1 )
+ CALL SLASET( 'Lower', DIM-4, DIM-4, ZERO,
+ $ ZERO, WORK(IPH+4), MAX(NTINY+1,DIM) )
+ ELSE
+ CALL SLASET( 'Lower', DIM-2, DIM-2, ZERO,
+ $ ZERO, WORK(IPH+2), MAX(NTINY+1,DIM) )
+ END IF
+*
+ KU = MAX(NTINY+1,DIM) - KDU + 1
+ KWH = KDU + 1
+ NHO = ( MAX(NTINY+1,DIM)-KDU+1-4 ) - ( KDU+1 ) + 1
+ KWV = KDU + 4
+ NVE = MAX(NTINY+1,DIM) - KDU - KWV + 1
+ CALL SLASET( 'All', MAX(NTINY+1,DIM),
+ $ MAX(NTINY+1,DIM), ZERO, ONE, WORK(IPUU),
+ $ MAX(NTINY+1,DIM) )
+*
+* Small-bulge multi-shift QR sweep.
+*
+ LKS = MAX( 1, NS - WIN*LNS + 1 )
+ CALL SLAQR6( JOB, WANTT, .TRUE., LKACC22,
+ $ MAX(NTINY+1,DIM), LLKTOP, LLKBOT, LNS, SR( LKS ),
+ $ SI( LKS ), WORK(IPH), MAX(NTINY+1,DIM), LLKTOP,
+ $ LLKBOT, WORK(IPUU), MAX(NTINY+1,DIM), WORK(IPU),
+ $ 3, WORK( IPH+KU-1 ),
+ $ MAX(NTINY+1,DIM), NVE, WORK( IPH+KWV-1 ),
+ $ MAX(NTINY+1,DIM), NHO, WORK( IPH-1+KU+(KWH-1)*
+ $ MAX(NTINY+1,DIM) ), MAX(NTINY+1,DIM) )
+*
+* Copy submatrix of H back.
+*
+ CALL SLAMOV( 'Upper', DIM, DIM, WORK(IPH),
+ $ MAX(NTINY+1,DIM), H(II+(JJ-1)*LLDH), LLDH )
+ CALL SCOPY( DIM-1, WORK(IPH+1), MAX(NTINY+1,DIM)+1,
+ $ H(II+(JJ-1)*LLDH+1), LLDH+1 )
+ IF( LSAME( JOB, 'I' ) .OR. LSAME( JOB, 'C' ) ) THEN
+ CALL SCOPY( DIM-2, WORK(IPH+2), DIM+1,
+ $ H(II+(JJ-1)*LLDH+2), LLDH+1 )
+ CALL SCOPY( DIM-3, WORK(IPH+3), DIM+1,
+ $ H(II+(JJ-1)*LLDH+3), LLDH+1 )
+ ELSE
+ CALL SLASET( 'Lower', DIM-2, DIM-2, ZERO,
+ $ ZERO, H(II+(JJ-1)*LLDH+2), LLDH )
+ END IF
+*
+* Copy actual submatrix of U to the correct place
+* of the buffer.
+*
+ CALL SLAMOV( 'All', LNWIN, LNWIN,
+ $ WORK(IPUU+(MAX(NTINY+1,DIM)*LIROFFH)+LIROFFH),
+ $ MAX(NTINY+1,DIM), WORK(IPU), LNWIN )
+ END IF
+*
+* In case the local submatrix was smaller than
+* (NTINY+1)-by-(NTINY+1) we go here and proceed.
+*
+ 45 CONTINUE
+ ELSE
+ IWORK( 5+(WIN-1)*5 ) = 2
+ END IF
+*
+* Increment counter for buffers of orthogonal transformations.
+*
+ IF( MYROW.EQ.LRSRC .OR. MYCOL.EQ.LCSRC ) THEN
+ IF( IDONEJOB.EQ.1 .AND. IWORK(5+(WIN-1)*5).LT.2 ) THEN
+ IF( MYROW.EQ.LRSRC ) LENRBUF = LENRBUF + LNWIN*LNWIN
+ IF( MYCOL.EQ.LCSRC ) LENCBUF = LENCBUF + LNWIN*LNWIN
+ END IF
+ END IF
+ 40 CONTINUE
+*
+* Did some work in the above do-loop?
+*
+ CALL IGSUM2D( ICTXT, 'All', '1-Tree', 1, 1, IDONEJOB, 1, -1, -1 )
+ DONEJOB = IDONEJOB.GT.0
+*
+* Chased off bulges from first window?
+*
+ IF( NPROCS.GT.1 )
+ $ CALL IGAMX2D( ICTXT, 'All', '1-Tree', 1, 1, ICHOFF, 1, -1,
+ $ -1, -1, -1, -1 )
+*
+* If work was done in the do-loop over local windows, perform
+* updates, otherwise go for cross border bulge chasing and updates.
+*
+ IF( DONEJOB ) THEN
+*
+* Broadcast orthogonal transformations.
+*
+ 49 CONTINUE
+ IF( LENRBUF.GT.0 .OR. LENCBUF.GT.0 ) THEN
+ DO 50 DIR = 1, 2
+ BCDONE = .FALSE.
+ DO 60 WIN = 1, ANMWIN
+ IF( ( LENRBUF.EQ.0 .AND. LENCBUF.EQ.0 ) .OR.
+ $ BCDONE ) GO TO 62
+ LRSRC = IWORK( 3+(WIN-1)*5 )
+ LCSRC = IWORK( 4+(WIN-1)*5 )
+ IF( MYROW.EQ.LRSRC .AND. MYCOL.EQ.LCSRC ) THEN
+ IF( DIR.EQ.1 .AND. LENRBUF.GT.0 .AND.
+ $ NPCOL.GT.1 ) THEN
+ CALL SGEBS2D( ICTXT, 'Row', '1-Tree', LENRBUF,
+ $ 1, WORK, LENRBUF )
+ ELSEIF( DIR.EQ.2 .AND. LENCBUF.GT.0 .AND.
+ $ NPROW.GT.1 ) THEN
+ CALL SGEBS2D( ICTXT, 'Col', '1-Tree', LENCBUF,
+ $ 1, WORK, LENCBUF )
+ END IF
+ IF( LENRBUF.GT.0 )
+ $ CALL SLAMOV( 'All', LENRBUF, 1, WORK, LENRBUF,
+ $ WORK(1+LENRBUF), LENCBUF )
+ BCDONE = .TRUE.
+ ELSEIF( MYROW.EQ.LRSRC .AND. DIR.EQ.1 ) THEN
+ IF( LENRBUF.GT.0 .AND. NPCOL.GT.1 ) THEN
+ CALL SGEBR2D( ICTXT, 'Row', '1-Tree', LENRBUF,
+ $ 1, WORK, LENRBUF, LRSRC, LCSRC )
+ BCDONE = .TRUE.
+ END IF
+ ELSEIF( MYCOL.EQ.LCSRC .AND. DIR.EQ.2 ) THEN
+ IF( LENCBUF.GT.0 .AND. NPROW.GT.1 ) THEN
+ CALL SGEBR2D( ICTXT, 'Col', '1-Tree', LENCBUF,
+ $ 1, WORK(1+LENRBUF), LENCBUF, LRSRC, LCSRC )
+ BCDONE = .TRUE.
+ END IF
+ END IF
+ 62 CONTINUE
+ 60 CONTINUE
+ 50 CONTINUE
+ END IF
+*
+* Compute updates - make sure to skip windows that was skipped
+* regarding local bulge chasing.
+*
+ DO 65 DIR = 1, 2
+ WINID = 0
+ IF( DIR.EQ.1 ) THEN
+ IPNEXT = 1
+ ELSE
+ IPNEXT = 1 + LENRBUF
+ END IF
+ DO 70 WIN = 1, ANMWIN
+ IF( IWORK( 5+(WIN-1)*5 ).EQ.2 ) GO TO 75
+ LRSRC = IWORK( 3+(WIN-1)*5 )
+ LCSRC = IWORK( 4+(WIN-1)*5 )
+ LKTOP = IWORK( 1+(WIN-1)*5 )
+ LKBOT = IWORK( 2+(WIN-1)*5 )
+ LNWIN = LKBOT - LKTOP + 1
+ IF( (MYROW.EQ.LRSRC.AND.LENRBUF.GT.0.AND.DIR.EQ.1) .OR.
+ $ (MYCOL.EQ.LCSRC.AND.LENCBUF.GT.0.AND.DIR.EQ.2 ) )
+ $ THEN
+*
+* Set up workspaces.
+*
+ IPU = IPNEXT
+ IPNEXT = IPU + LNWIN*LNWIN
+ IPW = 1 + LENRBUF + LENCBUF
+ LIROFFH = MOD(LKTOP-1,NB)
+ WINID = WINID + 1
+*
+* Recompute JOB to see if block structure of U could
+* possibly be exploited or not.
+*
+ IF( LKTOP.EQ.KTOP .AND. LKBOT.EQ.KBOT ) THEN
+ JOB = 'All steps'
+ ELSEIF( LKTOP.EQ.KTOP ) THEN
+ JOB = 'Introduce and chase'
+ ELSEIF( LKBOT.EQ.KBOT ) THEN
+ JOB = 'Off-chase bulges'
+ ELSE
+ JOB = 'Chase bulges'
+ END IF
+ END IF
+*
+* Use U to update far-from-diagonal entries in H.
+* If required, use U to update Z as well.
+*
+ IF( .NOT. BLK22 .OR. .NOT. LSAME(JOB,'C')
+ $ .OR. LNS.LE.2 ) THEN
+*
+ IF( DIR.EQ.2 .AND. LENCBUF.GT.0 .AND.
+ $ MYCOL.EQ.LCSRC ) THEN
+ IF( WANTT ) THEN
+ DO 80 INDX = 1, LKTOP-LIROFFH-1, NB
+ CALL INFOG2L( INDX, LKTOP, DESCH, NPROW,
+ $ NPCOL, MYROW, MYCOL, ILOC, JLOC, RSRC1,
+ $ CSRC1 )
+ IF( MYROW.EQ.RSRC1.AND.MYCOL.EQ.CSRC1 ) THEN
+ LROWS = MIN( NB, LKTOP-INDX )
+ CALL SGEMM('No transpose', 'No transpose',
+ $ LROWS, LNWIN, LNWIN, ONE,
+ $ H((JLOC-1)*LLDH+ILOC), LLDH,
+ $ WORK( IPU ), LNWIN, ZERO,
+ $ WORK(IPW),
+ $ LROWS )
+ CALL SLAMOV( 'All', LROWS, LNWIN,
+ $ WORK(IPW), LROWS,
+ $ H((JLOC-1)*LLDH+ILOC), LLDH )
+ END IF
+ 80 CONTINUE
+ END IF
+ IF( WANTZ ) THEN
+ DO 90 INDX = 1, N, NB
+ CALL INFOG2L( INDX, LKTOP, DESCZ, NPROW,
+ $ NPCOL, MYROW, MYCOL, ILOC, JLOC, RSRC1,
+ $ CSRC1 )
+ IF( MYROW.EQ.RSRC1.AND.MYCOL.EQ.CSRC1 ) THEN
+ LROWS = MIN(NB,N-INDX+1)
+ CALL SGEMM( 'No transpose',
+ $ 'No transpose', LROWS, LNWIN, LNWIN,
+ $ ONE, Z((JLOC-1)*LLDZ+ILOC), LLDZ,
+ $ WORK( IPU ), LNWIN, ZERO,
+ $ WORK(IPW), LROWS )
+ CALL SLAMOV( 'All', LROWS, LNWIN,
+ $ WORK(IPW), LROWS,
+ $ Z((JLOC-1)*LLDZ+ILOC), LLDZ )
+ END IF
+ 90 CONTINUE
+ END IF
+ END IF
+*
+* Update the rows of H affected by the bulge-chase.
+*
+ IF( DIR.EQ.1 .AND. LENRBUF.GT.0 .AND.
+ $ MYROW.EQ.LRSRC ) THEN
+ IF( WANTT ) THEN
+ IF( ICEIL(LKBOT,NB).EQ.ICEIL(KBOT,NB) ) THEN
+ LCOLS = MIN(ICEIL(KBOT,NB)*NB,N) - KBOT
+ ELSE
+ LCOLS = 0
+ END IF
+ IF( LCOLS.GT.0 ) THEN
+ INDX = KBOT + 1
+ CALL INFOG2L( LKTOP, INDX, DESCH, NPROW,
+ $ NPCOL, MYROW, MYCOL, ILOC, JLOC,
+ $ RSRC1, CSRC1 )
+ IF( MYROW.EQ.RSRC1.AND.MYCOL.EQ.CSRC1 ) THEN
+ CALL SGEMM( 'Transpose', 'No Transpose',
+ $ LNWIN, LCOLS, LNWIN, ONE, WORK(IPU),
+ $ LNWIN, H((JLOC-1)*LLDH+ILOC), LLDH,
+ $ ZERO, WORK(IPW), LNWIN )
+ CALL SLAMOV( 'All', LNWIN, LCOLS,
+ $ WORK(IPW), LNWIN,
+ $ H((JLOC-1)*LLDH+ILOC), LLDH )
+ END IF
+ END IF
+ 93 CONTINUE
+ INDXS = ICEIL(LKBOT,NB)*NB + 1
+ DO 95 INDX = INDXS, N, NB
+ CALL INFOG2L( LKTOP, INDX,
+ $ DESCH, NPROW, NPCOL, MYROW, MYCOL,
+ $ ILOC, JLOC, RSRC1, CSRC1 )
+ IF( MYROW.EQ.RSRC1.AND.MYCOL.EQ.CSRC1 ) THEN
+ LCOLS = MIN( NB, N-INDX+1 )
+ CALL SGEMM( 'Transpose', 'No Transpose',
+ $ LNWIN, LCOLS, LNWIN, ONE, WORK(IPU),
+ $ LNWIN, H((JLOC-1)*LLDH+ILOC), LLDH,
+ $ ZERO, WORK(IPW),
+ $ LNWIN )
+ CALL SLAMOV( 'All', LNWIN, LCOLS,
+ $ WORK(IPW), LNWIN,
+ $ H((JLOC-1)*LLDH+ILOC), LLDH )
+ END IF
+ 95 CONTINUE
+ END IF
+ END IF
+ ELSE
+ KS = LNWIN-LNS/2*3
+*
+* The LNWIN-by-LNWIN matrix U containing the accumulated
+* orthogonal transformations has the following structure:
+*
+* [ U11 U12 ]
+* U = [ ],
+* [ U21 U22 ]
+*
+* where U21 is KS-by-KS upper triangular and U12 is
+* (LNWIN-KS)-by-(LNWIN-KS) lower triangular.
+* Here, KS = LNS.
+*
+* Update the columns of H and Z affected by the bulge
+* chasing.
+*
+* Compute H2*U21 + H1*U11 in workspace.
+*
+ IF( DIR.EQ.2 .AND. LENCBUF.GT.0 .AND.
+ $ MYCOL.EQ.LCSRC ) THEN
+ IF( WANTT ) THEN
+ DO 100 INDX = 1, LKTOP-LIROFFH-1, NB
+ CALL INFOG2L( INDX, LKTOP, DESCH, NPROW,
+ $ NPCOL, MYROW, MYCOL, ILOC, JLOC, RSRC1,
+ $ CSRC1 )
+ IF( MYROW.EQ.RSRC1.AND.MYCOL.EQ.CSRC1 ) THEN
+ JLOC1 = INDXG2L( LKTOP+LNWIN-KS, NB,
+ $ MYCOL, DESCH( CSRC_ ), NPCOL )
+ LROWS = MIN( NB, LKTOP-INDX )
+ CALL SLAMOV( 'All', LROWS, KS,
+ $ H((JLOC1-1)*LLDH+ILOC ), LLDH,
+ $ WORK(IPW), LROWS )
+ CALL STRMM( 'Right', 'Upper',
+ $ 'No transpose','Non-unit', LROWS,
+ $ KS, ONE, WORK( IPU+LNWIN-KS ), LNWIN,
+ $ WORK(IPW), LROWS )
+ CALL SGEMM('No transpose', 'No transpose',
+ $ LROWS, KS, LNWIN-KS, ONE,
+ $ H((JLOC-1)*LLDH+ILOC), LLDH,
+ $ WORK( IPU ), LNWIN, ONE, WORK(IPW),
+ $ LROWS )
+*
+* Compute H1*U12 + H2*U22 in workspace.
+*
+ CALL SLAMOV( 'All', LROWS, LNWIN-KS,
+ $ H((JLOC-1)*LLDH+ILOC), LLDH,
+ $ WORK( IPW+KS*LROWS ), LROWS )
+ CALL STRMM( 'Right', 'Lower',
+ $ 'No transpose', 'Non-Unit',
+ $ LROWS, LNWIN-KS, ONE,
+ $ WORK( IPU+LNWIN*KS ), LNWIN,
+ $ WORK( IPW+KS*LROWS ), LROWS )
+ CALL SGEMM('No transpose', 'No transpose',
+ $ LROWS, LNWIN-KS, KS, ONE,
+ $ H((JLOC1-1)*LLDH+ILOC), LLDH,
+ $ WORK( IPU+LNWIN*KS+LNWIN-KS ), LNWIN,
+ $ ONE, WORK( IPW+KS*LROWS ), LROWS )
+*
+* Copy workspace to H.
+*
+ CALL SLAMOV( 'All', LROWS, LNWIN,
+ $ WORK(IPW), LROWS,
+ $ H((JLOC-1)*LLDH+ILOC), LLDH )
+ END IF
+ 100 CONTINUE
+ END IF
+*
+ IF( WANTZ ) THEN
+*
+* Compute Z2*U21 + Z1*U11 in workspace.
+*
+ DO 110 INDX = 1, N, NB
+ CALL INFOG2L( INDX, LKTOP, DESCZ, NPROW,
+ $ NPCOL, MYROW, MYCOL, ILOC, JLOC, RSRC1,
+ $ CSRC1 )
+ IF( MYROW.EQ.RSRC1.AND.MYCOL.EQ.CSRC1 ) THEN
+ JLOC1 = INDXG2L( LKTOP+LNWIN-KS, NB,
+ $ MYCOL, DESCZ( CSRC_ ), NPCOL )
+ LROWS = MIN(NB,N-INDX+1)
+ CALL SLAMOV( 'All', LROWS, KS,
+ $ Z((JLOC1-1)*LLDZ+ILOC ), LLDZ,
+ $ WORK(IPW), LROWS )
+ CALL STRMM( 'Right', 'Upper',
+ $ 'No transpose', 'Non-unit',
+ $ LROWS, KS, ONE, WORK( IPU+LNWIN-KS ),
+ $ LNWIN, WORK(IPW), LROWS )
+ CALL SGEMM( 'No transpose',
+ $ 'No transpose', LROWS, KS, LNWIN-KS,
+ $ ONE, Z((JLOC-1)*LLDZ+ILOC), LLDZ,
+ $ WORK( IPU ), LNWIN, ONE, WORK(IPW),
+ $ LROWS )
+*
+* Compute Z1*U12 + Z2*U22 in workspace.
+*
+ CALL SLAMOV( 'All', LROWS, LNWIN-KS,
+ $ Z((JLOC-1)*LLDZ+ILOC), LLDZ,
+ $ WORK( IPW+KS*LROWS ), LROWS)
+ CALL STRMM( 'Right', 'Lower',
+ $ 'No transpose', 'Non-unit',
+ $ LROWS, LNWIN-KS, ONE,
+ $ WORK( IPU+LNWIN*KS ), LNWIN,
+ $ WORK( IPW+KS*LROWS ), LROWS )
+ CALL SGEMM( 'No transpose',
+ $ 'No transpose', LROWS, LNWIN-KS, KS,
+ $ ONE, Z((JLOC1-1)*LLDZ+ILOC), LLDZ,
+ $ WORK( IPU+LNWIN*KS+LNWIN-KS ), LNWIN,
+ $ ONE, WORK( IPW+KS*LROWS ),
+ $ LROWS )
+*
+* Copy workspace to Z.
+*
+ CALL SLAMOV( 'All', LROWS, LNWIN,
+ $ WORK(IPW), LROWS,
+ $ Z((JLOC-1)*LLDZ+ILOC), LLDZ )
+ END IF
+ 110 CONTINUE
+ END IF
+ END IF
+*
+ IF( DIR.EQ.1 .AND. LENRBUF.GT.0 .AND.
+ $ MYROW.EQ.LRSRC ) THEN
+ IF( WANTT ) THEN
+ INDXS = ICEIL(LKBOT,NB)*NB + 1
+ DO 120 INDX = INDXS, N, NB
+ CALL INFOG2L( LKTOP, INDX,
+ $ DESCH, NPROW, NPCOL, MYROW, MYCOL, ILOC,
+ $ JLOC, RSRC1, CSRC1 )
+ IF( MYROW.EQ.RSRC1.AND.MYCOL.EQ.CSRC1 ) THEN
+*
+* Compute U21**T*H2 + U11**T*H1 in workspace.
+*
+ ILOC1 = INDXG2L( LKTOP+LNWIN-KS, NB,
+ $ MYROW, DESCH( RSRC_ ), NPROW )
+ LCOLS = MIN( NB, N-INDX+1 )
+ CALL SLAMOV( 'All', KS, LCOLS,
+ $ H((JLOC-1)*LLDH+ILOC1), LLDH,
+ $ WORK(IPW), LNWIN )
+ CALL STRMM( 'Left', 'Upper', 'Transpose',
+ $ 'Non-unit', KS, LCOLS, ONE,
+ $ WORK( IPU+LNWIN-KS ), LNWIN,
+ $ WORK(IPW), LNWIN )
+ CALL SGEMM( 'Transpose', 'No transpose',
+ $ KS, LCOLS, LNWIN-KS, ONE, WORK(IPU),
+ $ LNWIN, H((JLOC-1)*LLDH+ILOC), LLDH,
+ $ ONE, WORK(IPW), LNWIN )
+*
+* Compute U12**T*H1 + U22**T*H2 in workspace.
+*
+ CALL SLAMOV( 'All', LNWIN-KS, LCOLS,
+ $ H((JLOC-1)*LLDH+ILOC), LLDH,
+ $ WORK( IPW+KS ), LNWIN )
+ CALL STRMM( 'Left', 'Lower', 'Transpose',
+ $ 'Non-unit', LNWIN-KS, LCOLS, ONE,
+ $ WORK( IPU+LNWIN*KS ), LNWIN,
+ $ WORK( IPW+KS ), LNWIN )
+ CALL SGEMM( 'Transpose', 'No Transpose',
+ $ LNWIN-KS, LCOLS, KS, ONE,
+ $ WORK( IPU+LNWIN*KS+LNWIN-KS ), LNWIN,
+ $ H((JLOC-1)*LLDH+ILOC1), LLDH,
+ $ ONE, WORK( IPW+KS ), LNWIN )
+*
+* Copy workspace to H.
+*
+ CALL SLAMOV( 'All', LNWIN, LCOLS,
+ $ WORK(IPW), LNWIN,
+ $ H((JLOC-1)*LLDH+ILOC), LLDH )
+ END IF
+ 120 CONTINUE
+ END IF
+ END IF
+ END IF
+*
+* Update position information about current window.
+*
+ IF( DIR.EQ.2 ) THEN
+ IF( LKBOT.EQ.KBOT ) THEN
+ LKTOP = KBOT+1
+ LKBOT = KBOT+1
+ IWORK( 1+(WIN-1)*5 ) = LKTOP
+ IWORK( 2+(WIN-1)*5 ) = LKBOT
+ IWORK( 5+(WIN-1)*5 ) = 2
+ ELSE
+ LKTOP = MIN( LKTOP + LNWIN - LCHAIN,
+ $ ICEIL( LKTOP, NB )*NB - LCHAIN + 1,
+ $ KBOT )
+ IWORK( 1+(WIN-1)*5 ) = LKTOP
+ LKBOT = MIN( LKBOT + LNWIN - LCHAIN,
+ $ ICEIL( LKBOT, NB )*NB, KBOT )
+ IWORK( 2+(WIN-1)*5 ) = LKBOT
+ LNWIN = LKBOT-LKTOP+1
+ IF( LNWIN.EQ.LCHAIN ) IWORK(5+(WIN-1)*5) = 2
+ END IF
+ END IF
+ 75 CONTINUE
+ 70 CONTINUE
+ 65 CONTINUE
+*
+* If bulges were chasen off from first window, the window is
+* removed.
+*
+ IF( ICHOFF.GT.0 ) THEN
+ DO 128 WIN = 2, ANMWIN
+ IWORK( 1+(WIN-2)*5 ) = IWORK( 1+(WIN-1)*5 )
+ IWORK( 2+(WIN-2)*5 ) = IWORK( 2+(WIN-1)*5 )
+ IWORK( 3+(WIN-2)*5 ) = IWORK( 3+(WIN-1)*5 )
+ IWORK( 4+(WIN-2)*5 ) = IWORK( 4+(WIN-1)*5 )
+ IWORK( 5+(WIN-2)*5 ) = IWORK( 5+(WIN-1)*5 )
+ 128 CONTINUE
+ ANMWIN = ANMWIN - 1
+ IPIW = 6+(ANMWIN-1)*5
+ END IF
+*
+* If we have no more windows, return.
+*
+ IF( ANMWIN.LT.1 ) RETURN
+*
+ ELSE
+*
+* Set up windows such that as many bulges as possible can be
+* moved over the border to the next block. Make sure that the
+* cross border window is at least (NTINY+1)-by-(NTINY+1), unless
+* we are chasing off the bulges from the last window. This is
+* accomplished by setting the bottom index LKBOT such that the
+* local window has the correct size.
+*
+* If LKBOT then becomes larger than KBOT, the endpoint of the whole
+* global submatrix, or LKTOP from a window located already residing
+* at the other side of the border, this is taken care of by some
+* dirty tricks.
+*
+ DO 130 WIN = 1, ANMWIN
+ LKTOP1 = IWORK( 1+(WIN-1)*5 )
+ LKBOT = IWORK( 2+(WIN-1)*5 )
+ LNWIN = MAX( 6, MIN( LKBOT - LKTOP1 + 1, LCHAIN ) )
+ LKBOT1 = MAX( MIN( KBOT, ICEIL(LKTOP1,NB)*NB+LCHAIN),
+ $ MIN( KBOT, MIN( LKTOP1+2*LNWIN-1,
+ $ (ICEIL(LKTOP1,NB)+1)*NB ) ) )
+ IWORK( 2+(WIN-1)*5 ) = LKBOT1
+ 130 CONTINUE
+ ICHOFF = 0
+*
+* Keep a record over what windows that were moved over the borders
+* such that we can delay some windows due to lack of space on the
+* other side of the border; we do not want to leave any of the
+* bulges behind...
+*
+* IWORK( 5+(WIN-1)*5 ) = 0: window WIN has not been processed
+* IWORK( 5+(WIN-1)*5 ) = 1: window WIN is being processed (need to
+* know for updates)
+* IWORK( 5+(WIN-1)*5 ) = 2: window WIN has been fully processed
+*
+* So, start by marking all windows as not processed.
+*
+ DO 135 WIN = 1, ANMWIN
+ IWORK( 5+(WIN-1)*5 ) = 0
+ 135 CONTINUE
+*
+* Do the cross border bulge-chase as follows: Start from the
+* first window (the one that is closest to be chased off the
+* diagonal of H) and take the odd windows first followed by the
+* even ones. To not get into hang-problems on processor meshes
+* with at least one odd dimension, the windows will in such a case
+* be processed in chunks of {the minimum odd process dimension}-1
+* windows to avoid overlapping processor scopes in forming the
+* cross border computational windows and the cross border update
+* regions.
+*
+ WCHUNK = MAX( 1, MIN( ANMWIN, NPROW-1, NPCOL-1 ) )
+ NUMCHUNK = ICEIL( ANMWIN, WCHUNK )
+*
+* Based on the computed chunk of windows, start working with
+* crossborder bulge-chasing. Repeat this as long as there is
+* still work left to do (137 is a kind of do-while statement).
+*
+ 137 CONTINUE
+*
+* Zero out LENRBUF and LENCBUF each time we restart this loop.
+*
+ LENRBUF = 0
+ LENCBUF = 0
+*
+ DO 140 ODDEVEN = 1, MIN( 2, ANMWIN )
+ DO 150 CHUNKNUM = 1, NUMCHUNK
+ IPNEXT = 1
+ DO 160 WIN = ODDEVEN+(CHUNKNUM-1)*WCHUNK,
+ $ MIN(ANMWIN,MAX(1,ODDEVEN+(CHUNKNUM)*WCHUNK-1)), 2
+*
+* Get position and size of the WIN:th active window and
+* make sure that we skip the cross border bulge for this
+* window if the window is not shared between several data
+* layout blocks (and processors).
+*
+* Also, delay windows that do not have sufficient size of
+* the other side of the border. Moreover, make sure to skip
+* windows that was already processed in the last round of
+* the do-while loop (137).
+*
+ IF( IWORK( 5+(WIN-1)*5 ).EQ.2 ) GO TO 165
+ LKTOP = IWORK( 1+(WIN-1)*5 )
+ LKBOT = IWORK( 2+(WIN-1)*5 )
+ IF( WIN.GT.1 ) THEN
+ LKTOP2 = IWORK( 1+(WIN-2)*5 )
+ ELSE
+ LKTOP2 = KBOT+1
+ END IF
+ IF( ICEIL(LKTOP,NB).EQ.ICEIL(LKBOT,NB) .OR.
+ $ LKBOT.GE.LKTOP2 ) GO TO 165
+ LNWIN = LKBOT - LKTOP + 1
+ IF( LNWIN.LE.NTINY .AND. LKBOT.NE.KBOT .AND.
+ $ .NOT. MOD(LKBOT,NB).EQ.0 ) GO TO 165
+*
+* If window is going to be processed, mark it as processed.
+*
+ IWORK( 5+(WIN-1)*5 ) = 1
+*
+* Extract processors for current cross border window,
+* as below:
+*
+* 1 | 2
+* --+--
+* 3 | 4
+*
+ RSRC1 = IWORK( 3+(WIN-1)*5 )
+ CSRC1 = IWORK( 4+(WIN-1)*5 )
+ RSRC2 = RSRC1
+ CSRC2 = MOD( CSRC1+1, NPCOL )
+ RSRC3 = MOD( RSRC1+1, NPROW )
+ CSRC3 = CSRC1
+ RSRC4 = MOD( RSRC1+1, NPROW )
+ CSRC4 = MOD( CSRC1+1, NPCOL )
+*
+* Form group of four processors for cross border window.
+*
+ IF( ( MYROW.EQ.RSRC1 .AND. MYCOL.EQ.CSRC1 ) .OR.
+ $ ( MYROW.EQ.RSRC2 .AND. MYCOL.EQ.CSRC2 ) .OR.
+ $ ( MYROW.EQ.RSRC3 .AND. MYCOL.EQ.CSRC3 ) .OR.
+ $ ( MYROW.EQ.RSRC4 .AND. MYCOL.EQ.CSRC4 ) ) THEN
+*
+* Compute the upper and lower parts of the active
+* window.
+*
+ DIM1 = NB - MOD(LKTOP-1,NB)
+ DIM4 = LNWIN - DIM1
+*
+* Temporarily compute a new value of the size of the
+* computational window that is larger than or equal to
+* NTINY+1; call the *real* value DIM.
+*
+ DIM = LNWIN
+ LNWIN = MAX(NTINY+1,LNWIN)
+*
+* Divide workspace.
+*
+ IPU = IPNEXT
+ IPH = IPU + DIM**2
+ IPUU = IPH + LNWIN**2
+ IPV = IPUU + LNWIN**2
+ IPNEXT = IPH
+ IF( DIM.LT.LNWIN ) THEN
+ CALL SLASET( 'All', LNWIN, LNWIN, ZERO,
+ $ ONE, WORK( IPH ), LNWIN )
+ ELSE
+ CALL SLASET( 'All', DIM, DIM, ZERO,
+ $ ZERO, WORK( IPH ), LNWIN )
+ END IF
+*
+* Form the active window.
+*
+ IF( MYROW.EQ.RSRC1 .AND. MYCOL.EQ.CSRC1 ) THEN
+ ILOC = INDXG2L( LKTOP, NB, MYROW,
+ $ DESCH( RSRC_ ), NPROW )
+ JLOC = INDXG2L( LKTOP, NB, MYCOL,
+ $ DESCH( CSRC_ ), NPCOL )
+ CALL SLAMOV( 'All', DIM1, DIM1,
+ $ H((JLOC-1)*LLDH+ILOC), LLDH, WORK(IPH),
+ $ LNWIN )
+ IF( RSRC1.NE.RSRC4 .OR. CSRC1.NE.CSRC4 ) THEN
+* Proc#1 <==> Proc#4
+ CALL SGESD2D( ICTXT, DIM1, DIM1,
+ $ WORK(IPH), LNWIN, RSRC4, CSRC4 )
+ CALL SGERV2D( ICTXT, DIM4, DIM4,
+ $ WORK(IPH+DIM1*LNWIN+DIM1),
+ $ LNWIN, RSRC4, CSRC4 )
+ END IF
+ END IF
+ IF( MYROW.EQ.RSRC4 .AND. MYCOL.EQ.CSRC4 ) THEN
+ ILOC = INDXG2L( LKTOP+DIM1, NB, MYROW,
+ $ DESCH( RSRC_ ), NPROW )
+ JLOC = INDXG2L( LKTOP+DIM1, NB, MYCOL,
+ $ DESCH( CSRC_ ), NPCOL )
+ CALL SLAMOV( 'All', DIM4, DIM4,
+ $ H((JLOC-1)*LLDH+ILOC), LLDH,
+ $ WORK(IPH+DIM1*LNWIN+DIM1),
+ $ LNWIN )
+ IF( RSRC4.NE.RSRC1 .OR. CSRC4.NE.CSRC1 ) THEN
+* Proc#4 <==> Proc#1
+ CALL SGESD2D( ICTXT, DIM4, DIM4,
+ $ WORK(IPH+DIM1*LNWIN+DIM1),
+ $ LNWIN, RSRC1, CSRC1 )
+ CALL SGERV2D( ICTXT, DIM1, DIM1,
+ $ WORK(IPH), LNWIN, RSRC1, CSRC1 )
+ END IF
+ END IF
+ IF( MYROW.EQ.RSRC2 .AND. MYCOL.EQ.CSRC2 ) THEN
+ ILOC = INDXG2L( LKTOP, NB, MYROW,
+ $ DESCH( RSRC_ ), NPROW )
+ JLOC = INDXG2L( LKTOP+DIM1, NB, MYCOL,
+ $ DESCH( CSRC_ ), NPCOL )
+ CALL SLAMOV( 'All', DIM1, DIM4,
+ $ H((JLOC-1)*LLDH+ILOC), LLDH,
+ $ WORK(IPH+DIM1*LNWIN), LNWIN )
+ IF( RSRC2.NE.RSRC1 .OR. CSRC2.NE.CSRC1 ) THEN
+* Proc#2 ==> Proc#1
+ CALL SGESD2D( ICTXT, DIM1, DIM4,
+ $ WORK(IPH+DIM1*LNWIN),
+ $ LNWIN, RSRC1, CSRC1 )
+ END IF
+ END IF
+ IF( MYROW.EQ.RSRC2 .AND. MYCOL.EQ.CSRC2 ) THEN
+ IF( RSRC2.NE.RSRC4 .OR. CSRC2.NE.CSRC4 ) THEN
+* Proc#2 ==> Proc#4
+ CALL SGESD2D( ICTXT, DIM1, DIM4,
+ $ WORK(IPH+DIM1*LNWIN),
+ $ LNWIN, RSRC4, CSRC4 )
+ END IF
+ END IF
+ IF( MYROW.EQ.RSRC3 .AND. MYCOL.EQ.CSRC3 ) THEN
+ ILOC = INDXG2L( LKTOP+DIM1, NB, MYROW,
+ $ DESCH( RSRC_ ), NPROW )
+ JLOC = INDXG2L( LKTOP+DIM1-1, NB, MYCOL,
+ $ DESCH( CSRC_ ), NPCOL )
+ CALL SLAMOV( 'All', 1, 1,
+ $ H((JLOC-1)*LLDH+ILOC), LLDH,
+ $ WORK(IPH+(DIM1-1)*LNWIN+DIM1),
+ $ LNWIN )
+ IF( RSRC3.NE.RSRC1 .OR. CSRC3.NE.CSRC1 ) THEN
+* Proc#3 ==> Proc#1
+ CALL SGESD2D( ICTXT, 1, 1,
+ $ WORK(IPH+(DIM1-1)*LNWIN+DIM1),
+ $ LNWIN, RSRC1, CSRC1 )
+ END IF
+ END IF
+ IF( MYROW.EQ.RSRC3 .AND. MYCOL.EQ.CSRC3 ) THEN
+ IF( RSRC3.NE.RSRC4 .OR. CSRC3.NE.CSRC4 ) THEN
+* Proc#3 ==> Proc#4
+ CALL SGESD2D( ICTXT, 1, 1,
+ $ WORK(IPH+(DIM1-1)*LNWIN+DIM1),
+ $ LNWIN, RSRC4, CSRC4 )
+ END IF
+ END IF
+ IF( MYROW.EQ.RSRC1 .AND. MYCOL.EQ.CSRC1 ) THEN
+ IF( RSRC1.NE.RSRC2 .OR. CSRC1.NE.CSRC2 ) THEN
+* Proc#1 <== Proc#2
+ CALL SGERV2D( ICTXT, DIM1, DIM4,
+ $ WORK(IPH+DIM1*LNWIN),
+ $ LNWIN, RSRC2, CSRC2 )
+ END IF
+ IF( RSRC1.NE.RSRC3 .OR. CSRC1.NE.CSRC3 ) THEN
+* Proc#1 <== Proc#3
+ CALL SGERV2D( ICTXT, 1, 1,
+ $ WORK(IPH+(DIM1-1)*LNWIN+DIM1),
+ $ LNWIN, RSRC3, CSRC3 )
+ END IF
+ END IF
+ IF( MYROW.EQ.RSRC4 .AND. MYCOL.EQ.CSRC4 ) THEN
+ IF( RSRC4.NE.RSRC2 .OR. CSRC4.NE.CSRC2 ) THEN
+* Proc#4 <== Proc#2
+ CALL SGERV2D( ICTXT, DIM1, DIM4,
+ $ WORK(IPH+DIM1*LNWIN),
+ $ LNWIN, RSRC2, CSRC2 )
+ END IF
+ IF( RSRC4.NE.RSRC3 .OR. CSRC4.NE.CSRC3 ) THEN
+* Proc#4 <== Proc#3
+ CALL SGERV2D( ICTXT, 1, 1,
+ $ WORK(IPH+(DIM1-1)*LNWIN+DIM1),
+ $ LNWIN, RSRC3, CSRC3 )
+ END IF
+ END IF
+*
+* Prepare for call to SLAQR6 - it could happen that no
+* bulges where introduced in the pre-cross border step
+* since the chain was too long to fit in the top-left
+* part of the cross border window. In such a case, the
+* bulges are introduced here instead. It could also
+* happen that the bottom-right part is too small to hold
+* the whole chain -- in such a case, the bulges are
+* chasen off immediately, as well.
+*
+ IF( (MYROW.EQ.RSRC1 .AND. MYCOL.EQ.CSRC1) .OR.
+ $ (MYROW.EQ.RSRC4 .AND. MYCOL.EQ.CSRC4) ) THEN
+ IF( LKTOP.EQ.KTOP .AND. LKBOT.EQ.KBOT .AND.
+ $ (DIM1.LE.LCHAIN .OR. DIM1.LE.NTINY ) ) THEN
+ JOB = 'All steps'
+ ICHOFF = 1
+ ELSEIF( LKTOP.EQ.KTOP .AND.
+ $ ( DIM1.LE.LCHAIN .OR. DIM1.LE.NTINY ) ) THEN
+ JOB = 'Introduce and chase'
+ ELSEIF( LKBOT.EQ.KBOT ) THEN
+ JOB = 'Off-chase bulges'
+ ICHOFF = 1
+ ELSE
+ JOB = 'Chase bulges'
+ END IF
+ KU = LNWIN - KDU + 1
+ KWH = KDU + 1
+ NHO = ( LNWIN-KDU+1-4 ) - ( KDU+1 ) + 1
+ KWV = KDU + 4
+ NVE = LNWIN - KDU - KWV + 1
+ CALL SLASET( 'All', LNWIN, LNWIN,
+ $ ZERO, ONE, WORK(IPUU), LNWIN )
+*
+* Small-bulge multi-shift QR sweep.
+*
+ LKS = MAX(1, NS - WIN*LNS + 1)
+ CALL SLAQR6( JOB, WANTT, .TRUE., LKACC22, LNWIN,
+ $ 1, DIM, LNS, SR( LKS ), SI( LKS ),
+ $ WORK(IPH), LNWIN, 1, DIM,
+ $ WORK(IPUU), LNWIN, WORK(IPU), 3,
+ $ WORK( IPH+KU-1 ), LNWIN, NVE,
+ $ WORK( IPH+KWV-1 ), LNWIN, NHO,
+ $ WORK( IPH-1+KU+(KWH-1)*LNWIN ), LNWIN )
+*
+* Copy local submatrices of H back to global matrix.
+*
+ IF( MYROW.EQ.RSRC1 .AND. MYCOL.EQ.CSRC1 ) THEN
+ ILOC = INDXG2L( LKTOP, NB, MYROW,
+ $ DESCH( RSRC_ ), NPROW )
+ JLOC = INDXG2L( LKTOP, NB, MYCOL,
+ $ DESCH( CSRC_ ), NPCOL )
+ CALL SLAMOV( 'All', DIM1, DIM1, WORK(IPH),
+ $ LNWIN, H((JLOC-1)*LLDH+ILOC),
+ $ LLDH )
+ END IF
+ IF( MYROW.EQ.RSRC4 .AND. MYCOL.EQ.CSRC4 ) THEN
+ ILOC = INDXG2L( LKTOP+DIM1, NB, MYROW,
+ $ DESCH( RSRC_ ), NPROW )
+ JLOC = INDXG2L( LKTOP+DIM1, NB, MYCOL,
+ $ DESCH( CSRC_ ), NPCOL )
+ CALL SLAMOV( 'All', DIM4, DIM4,
+ $ WORK(IPH+DIM1*LNWIN+DIM1),
+ $ LNWIN, H((JLOC-1)*LLDH+ILOC), LLDH )
+ END IF
+*
+* Copy actual submatrix of U to the correct place of
+* the buffer.
+*
+ CALL SLAMOV( 'All', DIM, DIM,
+ $ WORK(IPUU), LNWIN, WORK(IPU), DIM )
+ END IF
+*
+* Return data to process 2 and 3.
+*
+ RWS3 = MIN(3,DIM4)
+ CLS3 = MIN(3,DIM1)
+ IF( MYROW.EQ.RSRC1 .AND. MYCOL.EQ.CSRC1 ) THEN
+ IF( RSRC1.NE.RSRC3 .OR. CSRC1.NE.CSRC3 ) THEN
+* Proc#1 ==> Proc#3
+ CALL SGESD2D( ICTXT, RWS3, CLS3,
+ $ WORK( IPH+(DIM1-CLS3)*LNWIN+DIM1 ),
+ $ LNWIN, RSRC3, CSRC3 )
+ END IF
+ END IF
+ IF( MYROW.EQ.RSRC4 .AND. MYCOL.EQ.CSRC4 ) THEN
+ IF( RSRC4.NE.RSRC2 .OR. CSRC4.NE.CSRC2 ) THEN
+* Proc#4 ==> Proc#2
+ CALL SGESD2D( ICTXT, DIM1, DIM4,
+ $ WORK( IPH+DIM1*LNWIN),
+ $ LNWIN, RSRC2, CSRC2 )
+ END IF
+ END IF
+ IF( MYROW.EQ.RSRC2 .AND. MYCOL.EQ.CSRC2 ) THEN
+ ILOC = INDXG2L( LKTOP, NB, MYROW,
+ $ DESCH( RSRC_ ), NPROW )
+ JLOC = INDXG2L( LKTOP+DIM1, NB, MYCOL,
+ $ DESCH( CSRC_ ), NPCOL )
+ IF( RSRC2.NE.RSRC4 .OR. CSRC2.NE.CSRC4 ) THEN
+* Proc#2 <== Proc#4
+ CALL SGERV2D( ICTXT, DIM1, DIM4,
+ $ WORK(IPH+DIM1*LNWIN),
+ $ LNWIN, RSRC4, CSRC4 )
+ END IF
+ CALL SLAMOV( 'All', DIM1, DIM4,
+ $ WORK( IPH+DIM1*LNWIN ), LNWIN,
+ $ H((JLOC-1)*LLDH+ILOC), LLDH )
+ END IF
+ IF( MYROW.EQ.RSRC3 .AND. MYCOL.EQ.CSRC3 ) THEN
+ ILOC = INDXG2L( LKTOP+DIM1, NB, MYROW,
+ $ DESCH( RSRC_ ), NPROW )
+ JLOC = INDXG2L( LKTOP+DIM1-CLS3, NB, MYCOL,
+ $ DESCH( CSRC_ ), NPCOL )
+ IF( RSRC3.NE.RSRC1 .OR. CSRC3.NE.CSRC1 ) THEN
+* Proc#3 <== Proc#1
+ CALL SGERV2D( ICTXT, RWS3, CLS3,
+ $ WORK( IPH+(DIM1-CLS3)*LNWIN+DIM1 ),
+ $ LNWIN, RSRC1, CSRC1 )
+ END IF
+ CALL SLAMOV( 'Upper', RWS3, CLS3,
+ $ WORK( IPH+(DIM1-CLS3)*LNWIN+DIM1 ),
+ $ LNWIN, H((JLOC-1)*LLDH+ILOC),
+ $ LLDH )
+ IF( RWS3.GT.1 .AND. CLS3.GT.1 ) THEN
+ ELEM = WORK( IPH+(DIM1-CLS3)*LNWIN+DIM1+1 )
+ IF( ELEM.NE.ZERO ) THEN
+ CALL SLAMOV( 'Lower', RWS3-1, CLS3-1,
+ $ WORK( IPH+(DIM1-CLS3)*LNWIN+DIM1+1 ),
+ $ LNWIN, H((JLOC-1)*LLDH+ILOC+1), LLDH )
+ END IF
+ END IF
+ END IF
+*
+* Restore correct value of LNWIN.
+*
+ LNWIN = DIM
+*
+ END IF
+*
+* Increment counter for buffers of orthogonal
+* transformations.
+*
+ IF( MYROW.EQ.RSRC1 .OR. MYCOL.EQ.CSRC1 .OR.
+ $ MYROW.EQ.RSRC4 .OR. MYCOL.EQ.CSRC4 ) THEN
+ IF( MYROW.EQ.RSRC1 .OR. MYROW.EQ.RSRC4 )
+ $ LENRBUF = LENRBUF + LNWIN*LNWIN
+ IF( MYCOL.EQ.CSRC1 .OR. MYCOL.EQ.CSRC4 )
+ $ LENCBUF = LENCBUF + LNWIN*LNWIN
+ END IF
+*
+* If no cross border bulge chasing was performed for the
+* current WIN:th window, the processor jump to this point
+* and consider the next one.
+*
+ 165 CONTINUE
+*
+ 160 CONTINUE
+*
+* Broadcast orthogonal transformations -- this will only happen
+* if the buffer associated with the orthogonal transformations
+* is not empty (controlled by LENRBUF, for row-wise
+* broadcasts, and LENCBUF, for column-wise broadcasts).
+*
+ DO 170 DIR = 1, 2
+ BCDONE = .FALSE.
+ DO 180 WIN = ODDEVEN+(CHUNKNUM-1)*WCHUNK,
+ $ MIN(ANMWIN,MAX(1,ODDEVEN+(CHUNKNUM)*WCHUNK-1)), 2
+ IF( ( LENRBUF.EQ.0 .AND. LENCBUF.EQ.0 ) .OR.
+ $ BCDONE ) GO TO 185
+ RSRC1 = IWORK( 3+(WIN-1)*5 )
+ CSRC1 = IWORK( 4+(WIN-1)*5 )
+ RSRC4 = MOD( RSRC1+1, NPROW )
+ CSRC4 = MOD( CSRC1+1, NPCOL )
+ IF( ( MYROW.EQ.RSRC1 .AND. MYCOL.EQ.CSRC1 ) .OR.
+ $ ( MYROW.EQ.RSRC4 .AND. MYCOL.EQ.CSRC4 ) ) THEN
+ IF( DIR.EQ.1 .AND. LENRBUF.GT.0 .AND.
+ $ NPCOL.GT.1 .AND. NPROCS.GT.2 ) THEN
+ IF( MYROW.EQ.RSRC1 .OR. ( MYROW.EQ.RSRC4
+ $ .AND. RSRC4.NE.RSRC1 ) ) THEN
+ CALL SGEBS2D( ICTXT, 'Row', '1-Tree',
+ $ LENRBUF, 1, WORK, LENRBUF )
+ ELSE
+ CALL SGEBR2D( ICTXT, 'Row', '1-Tree',
+ $ LENRBUF, 1, WORK, LENRBUF, RSRC1,
+ $ CSRC1 )
+ END IF
+ ELSEIF( DIR.EQ.2 .AND. LENCBUF.GT.0 .AND.
+ $ NPROW.GT.1 .AND. NPROCS.GT.2 ) THEN
+ IF( MYCOL.EQ.CSRC1 .OR. ( MYCOL.EQ.CSRC4
+ $ .AND. CSRC4.NE.CSRC1 ) ) THEN
+ CALL SGEBS2D( ICTXT, 'Col', '1-Tree',
+ $ LENCBUF, 1, WORK, LENCBUF )
+ ELSE
+ CALL SGEBR2D( ICTXT, 'Col', '1-Tree',
+ $ LENCBUF, 1, WORK(1+LENRBUF), LENCBUF,
+ $ RSRC1, CSRC1 )
+ END IF
+ END IF
+ IF( LENRBUF.GT.0 .AND. ( MYCOL.EQ.CSRC1 .OR.
+ $ ( MYCOL.EQ.CSRC4 .AND. CSRC4.NE.CSRC1 ) ) )
+ $ CALL SLAMOV( 'All', LENRBUF, 1, WORK, LENRBUF,
+ $ WORK(1+LENRBUF), LENCBUF )
+ BCDONE = .TRUE.
+ ELSEIF( MYROW.EQ.RSRC1 .AND. DIR.EQ.1 ) THEN
+ IF( LENRBUF.GT.0 .AND. NPCOL.GT.1 )
+ $ CALL SGEBR2D( ICTXT, 'Row', '1-Tree', LENRBUF,
+ $ 1, WORK, LENRBUF, RSRC1, CSRC1 )
+ BCDONE = .TRUE.
+ ELSEIF( MYCOL.EQ.CSRC1 .AND. DIR.EQ.2 ) THEN
+ IF( LENCBUF.GT.0 .AND. NPROW.GT.1 )
+ $ CALL SGEBR2D( ICTXT, 'Col', '1-Tree', LENCBUF,
+ $ 1, WORK(1+LENRBUF), LENCBUF, RSRC1, CSRC1 )
+ BCDONE = .TRUE.
+ ELSEIF( MYROW.EQ.RSRC4 .AND. DIR.EQ.1 ) THEN
+ IF( LENRBUF.GT.0 .AND. NPCOL.GT.1 )
+ $ CALL SGEBR2D( ICTXT, 'Row', '1-Tree', LENRBUF,
+ $ 1, WORK, LENRBUF, RSRC4, CSRC4 )
+ BCDONE = .TRUE.
+ ELSEIF( MYCOL.EQ.CSRC4 .AND. DIR.EQ.2 ) THEN
+ IF( LENCBUF.GT.0 .AND. NPROW.GT.1 )
+ $ CALL SGEBR2D( ICTXT, 'Col', '1-Tree', LENCBUF,
+ $ 1, WORK(1+LENRBUF), LENCBUF, RSRC4, CSRC4 )
+ BCDONE = .TRUE.
+ END IF
+ 185 CONTINUE
+ 180 CONTINUE
+ 170 CONTINUE
+*
+* Prepare for computing cross border updates by exchanging
+* data in cross border update regions in H and Z.
+*
+ DO 190 DIR = 1, 2
+ WINID = 0
+ IPW3 = 1
+ DO 200 WIN = ODDEVEN+(CHUNKNUM-1)*WCHUNK,
+ $ MIN(ANMWIN,MAX(1,ODDEVEN+(CHUNKNUM)*WCHUNK-1)), 2
+ IF( IWORK( 5+(WIN-1)*5 ).NE.1 ) GO TO 205
+*
+* Make sure this part of the code is only executed when
+* there has been some work performed on the WIN:th
+* window.
+*
+ LKTOP = IWORK( 1+(WIN-1)*5 )
+ LKBOT = IWORK( 2+(WIN-1)*5 )
+*
+* Extract processor indices associated with
+* the current window.
+*
+ RSRC1 = IWORK( 3+(WIN-1)*5 )
+ CSRC1 = IWORK( 4+(WIN-1)*5 )
+ RSRC4 = MOD( RSRC1+1, NPROW )
+ CSRC4 = MOD( CSRC1+1, NPCOL )
+*
+* Compute local number of rows and columns
+* of H and Z to exchange.
+*
+ IF(((MYCOL.EQ.CSRC1.OR.MYCOL.EQ.CSRC4).AND.DIR.EQ.2)
+ $ .OR.((MYROW.EQ.RSRC1.OR.MYROW.EQ.RSRC4).AND.
+ $ DIR.EQ.1)) THEN
+ WINID = WINID + 1
+ LNWIN = LKBOT - LKTOP + 1
+ IPU = IPNEXT
+ DIM1 = NB - MOD(LKTOP-1,NB)
+ DIM4 = LNWIN - DIM1
+ IPNEXT = IPU + LNWIN*LNWIN
+ IF( DIR.EQ.2 ) THEN
+ IF( WANTZ ) THEN
+ ZROWS = NUMROC( N, NB, MYROW, DESCZ( RSRC_ ),
+ $ NPROW )
+ ELSE
+ ZROWS = 0
+ END IF
+ IF( WANTT ) THEN
+ HROWS = NUMROC( LKTOP-1, NB, MYROW,
+ $ DESCH( RSRC_ ), NPROW )
+ ELSE
+ HROWS = 0
+ END IF
+ ELSE
+ ZROWS = 0
+ HROWS = 0
+ END IF
+ IF( DIR.EQ.1 ) THEN
+ IF( WANTT ) THEN
+ HCOLS = NUMROC( N - (LKTOP+DIM1-1), NB,
+ $ MYCOL, CSRC4, NPCOL )
+ IF( MYCOL.EQ.CSRC4 ) HCOLS = HCOLS - DIM4
+ ELSE
+ HCOLS = 0
+ END IF
+ ELSE
+ HCOLS = 0
+ END IF
+ IPW = MAX( 1 + LENRBUF + LENCBUF, IPW3 )
+ IPW1 = IPW + HROWS * LNWIN
+ IF( WANTZ ) THEN
+ IPW2 = IPW1 + LNWIN * HCOLS
+ IPW3 = IPW2 + ZROWS * LNWIN
+ ELSE
+ IPW3 = IPW1 + LNWIN * HCOLS
+ END IF
+ END IF
+*
+* Let each process row and column involved in the updates
+* exchange data in H and Z with their neighbours.
+*
+ IF( DIR.EQ.2 .AND. WANTT .AND. LENCBUF.GT.0 ) THEN
+ IF( MYCOL.EQ.CSRC1 .OR. MYCOL.EQ.CSRC4 ) THEN
+ DO 210 INDX = 1, NPROW
+ IF( MYCOL.EQ.CSRC1 ) THEN
+ CALL INFOG2L( 1+(INDX-1)*NB, LKTOP, DESCH,
+ $ NPROW, NPCOL, MYROW, MYCOL, ILOC,
+ $ JLOC1, RSRC, CSRC1 )
+ IF( MYROW.EQ.RSRC ) THEN
+ CALL SLAMOV( 'All', HROWS, DIM1,
+ $ H((JLOC1-1)*LLDH+ILOC), LLDH,
+ $ WORK(IPW), HROWS )
+ IF( NPCOL.GT.1 ) THEN
+ EAST = MOD( MYCOL + 1, NPCOL )
+ CALL SGESD2D( ICTXT, HROWS, DIM1,
+ $ WORK(IPW), HROWS, RSRC, EAST )
+ CALL SGERV2D( ICTXT, HROWS, DIM4,
+ $ WORK(IPW+HROWS*DIM1), HROWS,
+ $ RSRC, EAST )
+ END IF
+ END IF
+ END IF
+ IF( MYCOL.EQ.CSRC4 ) THEN
+ CALL INFOG2L( 1+(INDX-1)*NB, LKTOP+DIM1,
+ $ DESCH, NPROW, NPCOL, MYROW, MYCOL,
+ $ ILOC, JLOC4, RSRC, CSRC4 )
+ IF( MYROW.EQ.RSRC ) THEN
+ CALL SLAMOV( 'All', HROWS, DIM4,
+ $ H((JLOC4-1)*LLDH+ILOC), LLDH,
+ $ WORK(IPW+HROWS*DIM1), HROWS )
+ IF( NPCOL.GT.1 ) THEN
+ WEST = MOD( MYCOL - 1 + NPCOL,
+ $ NPCOL )
+ CALL SGESD2D( ICTXT, HROWS, DIM4,
+ $ WORK(IPW+HROWS*DIM1), HROWS,
+ $ RSRC, WEST )
+ CALL SGERV2D( ICTXT, HROWS, DIM1,
+ $ WORK(IPW), HROWS, RSRC, WEST )
+ END IF
+ END IF
+ END IF
+ 210 CONTINUE
+ END IF
+ END IF
+*
+ IF( DIR.EQ.1 .AND. WANTT .AND. LENRBUF.GT.0 ) THEN
+ IF( MYROW.EQ.RSRC1 .OR. MYROW.EQ.RSRC4 ) THEN
+ DO 220 INDX = 1, NPCOL
+ IF( MYROW.EQ.RSRC1 ) THEN
+ IF( INDX.EQ.1 ) THEN
+ IF( LKBOT.LT.N ) THEN
+ CALL INFOG2L( LKTOP, LKBOT+1, DESCH,
+ $ NPROW, NPCOL, MYROW, MYCOL,
+ $ ILOC1, JLOC, RSRC1, CSRC )
+ ELSE
+ CSRC = -1
+ END IF
+ ELSEIF( MOD(LKBOT,NB).NE.0 ) THEN
+ CALL INFOG2L( LKTOP,
+ $ (ICEIL(LKBOT,NB)+(INDX-2))*NB+1,
+ $ DESCH, NPROW, NPCOL, MYROW, MYCOL,
+ $ ILOC1, JLOC, RSRC1, CSRC )
+ ELSE
+ CALL INFOG2L( LKTOP,
+ $ (ICEIL(LKBOT,NB)+(INDX-1))*NB+1,
+ $ DESCH, NPROW, NPCOL, MYROW, MYCOL,
+ $ ILOC1, JLOC, RSRC1, CSRC )
+ END IF
+ IF( MYCOL.EQ.CSRC ) THEN
+ CALL SLAMOV( 'All', DIM1, HCOLS,
+ $ H((JLOC-1)*LLDH+ILOC1), LLDH,
+ $ WORK(IPW1), LNWIN )
+ IF( NPROW.GT.1 ) THEN
+ SOUTH = MOD( MYROW + 1, NPROW )
+ CALL SGESD2D( ICTXT, DIM1, HCOLS,
+ $ WORK(IPW1), LNWIN, SOUTH,
+ $ CSRC )
+ CALL SGERV2D( ICTXT, DIM4, HCOLS,
+ $ WORK(IPW1+DIM1), LNWIN, SOUTH,
+ $ CSRC )
+ END IF
+ END IF
+ END IF
+ IF( MYROW.EQ.RSRC4 ) THEN
+ IF( INDX.EQ.1 ) THEN
+ IF( LKBOT.LT.N ) THEN
+ CALL INFOG2L( LKTOP+DIM1, LKBOT+1,
+ $ DESCH, NPROW, NPCOL, MYROW,
+ $ MYCOL, ILOC4, JLOC, RSRC4,
+ $ CSRC )
+ ELSE
+ CSRC = -1
+ END IF
+ ELSEIF( MOD(LKBOT,NB).NE.0 ) THEN
+ CALL INFOG2L( LKTOP+DIM1,
+ $ (ICEIL(LKBOT,NB)+(INDX-2))*NB+1,
+ $ DESCH, NPROW, NPCOL, MYROW, MYCOL,
+ $ ILOC4, JLOC, RSRC4, CSRC )
+ ELSE
+ CALL INFOG2L( LKTOP+DIM1,
+ $ (ICEIL(LKBOT,NB)+(INDX-1))*NB+1,
+ $ DESCH, NPROW, NPCOL, MYROW, MYCOL,
+ $ ILOC4, JLOC, RSRC4, CSRC )
+ END IF
+ IF( MYCOL.EQ.CSRC ) THEN
+ CALL SLAMOV( 'All', DIM4, HCOLS,
+ $ H((JLOC-1)*LLDH+ILOC4), LLDH,
+ $ WORK(IPW1+DIM1), LNWIN )
+ IF( NPROW.GT.1 ) THEN
+ NORTH = MOD( MYROW - 1 + NPROW,
+ $ NPROW )
+ CALL SGESD2D( ICTXT, DIM4, HCOLS,
+ $ WORK(IPW1+DIM1), LNWIN, NORTH,
+ $ CSRC )
+ CALL SGERV2D( ICTXT, DIM1, HCOLS,
+ $ WORK(IPW1), LNWIN, NORTH,
+ $ CSRC )
+ END IF
+ END IF
+ END IF
+ 220 CONTINUE
+ END IF
+ END IF
+*
+ IF( DIR.EQ.2 .AND. WANTZ .AND. LENCBUF.GT.0) THEN
+ IF( MYCOL.EQ.CSRC1 .OR. MYCOL.EQ.CSRC4 ) THEN
+ DO 230 INDX = 1, NPROW
+ IF( MYCOL.EQ.CSRC1 ) THEN
+ CALL INFOG2L( 1+(INDX-1)*NB, LKTOP,
+ $ DESCZ, NPROW, NPCOL, MYROW, MYCOL,
+ $ ILOC, JLOC1, RSRC, CSRC1 )
+ IF( MYROW.EQ.RSRC ) THEN
+ CALL SLAMOV( 'All', ZROWS, DIM1,
+ $ Z((JLOC1-1)*LLDZ+ILOC), LLDZ,
+ $ WORK(IPW2), ZROWS )
+ IF( NPCOL.GT.1 ) THEN
+ EAST = MOD( MYCOL + 1, NPCOL )
+ CALL SGESD2D( ICTXT, ZROWS, DIM1,
+ $ WORK(IPW2), ZROWS, RSRC,
+ $ EAST )
+ CALL SGERV2D( ICTXT, ZROWS, DIM4,
+ $ WORK(IPW2+ZROWS*DIM1),
+ $ ZROWS, RSRC, EAST )
+ END IF
+ END IF
+ END IF
+ IF( MYCOL.EQ.CSRC4 ) THEN
+ CALL INFOG2L( 1+(INDX-1)*NB,
+ $ LKTOP+DIM1, DESCZ, NPROW, NPCOL,
+ $ MYROW, MYCOL, ILOC, JLOC4, RSRC,
+ $ CSRC4 )
+ IF( MYROW.EQ.RSRC ) THEN
+ CALL SLAMOV( 'All', ZROWS, DIM4,
+ $ Z((JLOC4-1)*LLDZ+ILOC), LLDZ,
+ $ WORK(IPW2+ZROWS*DIM1), ZROWS )
+ IF( NPCOL.GT.1 ) THEN
+ WEST = MOD( MYCOL - 1 + NPCOL,
+ $ NPCOL )
+ CALL SGESD2D( ICTXT, ZROWS, DIM4,
+ $ WORK(IPW2+ZROWS*DIM1),
+ $ ZROWS, RSRC, WEST )
+ CALL SGERV2D( ICTXT, ZROWS, DIM1,
+ $ WORK(IPW2), ZROWS, RSRC,
+ $ WEST )
+ END IF
+ END IF
+ END IF
+ 230 CONTINUE
+ END IF
+ END IF
+*
+* If no exchanges was performed for the current window,
+* all processors jump to this point and try the next
+* one.
+*
+ 205 CONTINUE
+*
+ 200 CONTINUE
+*
+* Compute crossborder bulge-chase updates.
+*
+ WINID = 0
+ IF( DIR.EQ.1 ) THEN
+ IPNEXT = 1
+ ELSE
+ IPNEXT = 1 + LENRBUF
+ END IF
+ IPW3 = 1
+ DO 240 WIN = ODDEVEN+(CHUNKNUM-1)*WCHUNK,
+ $ MIN(ANMWIN,MAX(1,ODDEVEN+(CHUNKNUM)*WCHUNK-1)), 2
+ IF( IWORK( 5+(WIN-1)*5 ).NE.1 ) GO TO 245
+*
+* Only perform this part of the code if there was really
+* some work performed on the WIN:th window.
+*
+ LKTOP = IWORK( 1+(WIN-1)*5 )
+ LKBOT = IWORK( 2+(WIN-1)*5 )
+ LNWIN = LKBOT - LKTOP + 1
+*
+* Extract the processor indices associated with
+* the current window.
+*
+ RSRC1 = IWORK( 3+(WIN-1)*5 )
+ CSRC1 = IWORK( 4+(WIN-1)*5 )
+ RSRC4 = MOD( RSRC1+1, NPROW )
+ CSRC4 = MOD( CSRC1+1, NPCOL )
+*
+ IF(((MYCOL.EQ.CSRC1.OR.MYCOL.EQ.CSRC4).AND.DIR.EQ.2)
+ $ .OR.((MYROW.EQ.RSRC1.OR.MYROW.EQ.RSRC4).AND.
+ $ DIR.EQ.1)) THEN
+*
+* Set up workspaces.
+*
+ WINID = WINID + 1
+ LKTOP = IWORK( 1+(WIN-1)*5 )
+ LKBOT = IWORK( 2+(WIN-1)*5 )
+ LNWIN = LKBOT - LKTOP + 1
+ DIM1 = NB - MOD(LKTOP-1,NB)
+ DIM4 = LNWIN - DIM1
+ IPU = IPNEXT + (WINID-1)*LNWIN*LNWIN
+ IF( DIR.EQ.2 ) THEN
+ IF( WANTZ ) THEN
+ ZROWS = NUMROC( N, NB, MYROW, DESCZ( RSRC_ ),
+ $ NPROW )
+ ELSE
+ ZROWS = 0
+ END IF
+ IF( WANTT ) THEN
+ HROWS = NUMROC( LKTOP-1, NB, MYROW,
+ $ DESCH( RSRC_ ), NPROW )
+ ELSE
+ HROWS = 0
+ END IF
+ ELSE
+ ZROWS = 0
+ HROWS = 0
+ END IF
+ IF( DIR.EQ.1 ) THEN
+ IF( WANTT ) THEN
+ HCOLS = NUMROC( N - (LKTOP+DIM1-1), NB,
+ $ MYCOL, CSRC4, NPCOL )
+ IF( MYCOL.EQ.CSRC4 ) HCOLS = HCOLS - DIM4
+ ELSE
+ HCOLS = 0
+ END IF
+ ELSE
+ HCOLS = 0
+ END IF
+*
+* IPW = local copy of overlapping column block of H
+* IPW1 = local copy of overlapping row block of H
+* IPW2 = local copy of overlapping column block of Z
+* IPW3 = workspace for right hand side of matrix
+* multiplication
+*
+ IPW = MAX( 1 + LENRBUF + LENCBUF, IPW3 )
+ IPW1 = IPW + HROWS * LNWIN
+ IF( WANTZ ) THEN
+ IPW2 = IPW1 + LNWIN * HCOLS
+ IPW3 = IPW2 + ZROWS * LNWIN
+ ELSE
+ IPW3 = IPW1 + LNWIN * HCOLS
+ END IF
+*
+* Recompute job to see if special structure of U
+* could possibly be exploited.
+*
+ IF( LKTOP.EQ.KTOP .AND. LKBOT.EQ.KBOT ) THEN
+ JOB = 'All steps'
+ ELSEIF( LKTOP.EQ.KTOP .AND.
+ $ ( DIM1.LT.LCHAIN+1 .OR. DIM1.LE.NTINY ) )
+ $ THEN
+ JOB = 'Introduce and chase'
+ ELSEIF( LKBOT.EQ.KBOT ) THEN
+ JOB = 'Off-chase bulges'
+ ELSE
+ JOB = 'Chase bulges'
+ END IF
+ END IF
+*
+* Test if to exploit sparsity structure of
+* orthogonal matrix U.
+*
+ KS = DIM1+DIM4-LNS/2*3
+ IF( .NOT. BLK22 .OR. DIM1.NE.KS .OR.
+ $ DIM4.NE.KS .OR. LSAME(JOB,'I') .OR.
+ $ LSAME(JOB,'O') .OR. LNS.LE.2 ) THEN
+*
+* Update the columns of H and Z.
+*
+ IF( DIR.EQ.2 .AND. WANTT .AND. LENCBUF.GT.0 ) THEN
+ DO 250 INDX = 1, MIN(LKTOP-1,1+(NPROW-1)*NB), NB
+ IF( MYCOL.EQ.CSRC1 ) THEN
+ CALL INFOG2L( INDX, LKTOP, DESCH, NPROW,
+ $ NPCOL, MYROW, MYCOL, ILOC, JLOC,
+ $ RSRC, CSRC1 )
+ IF( MYROW.EQ.RSRC ) THEN
+ CALL SGEMM( 'No transpose',
+ $ 'No transpose', HROWS, DIM1,
+ $ LNWIN, ONE, WORK( IPW ), HROWS,
+ $ WORK( IPU ), LNWIN, ZERO,
+ $ WORK(IPW3), HROWS )
+ CALL SLAMOV( 'All', HROWS, DIM1,
+ $ WORK(IPW3), HROWS,
+ $ H((JLOC-1)*LLDH+ILOC), LLDH )
+ END IF
+ END IF
+ IF( MYCOL.EQ.CSRC4 ) THEN
+ CALL INFOG2L( INDX, LKTOP+DIM1, DESCH,
+ $ NPROW, NPCOL, MYROW, MYCOL, ILOC,
+ $ JLOC, RSRC, CSRC4 )
+ IF( MYROW.EQ.RSRC ) THEN
+ CALL SGEMM( 'No transpose',
+ $ 'No transpose', HROWS, DIM4,
+ $ LNWIN, ONE, WORK( IPW ), HROWS,
+ $ WORK( IPU+LNWIN*DIM1 ), LNWIN,
+ $ ZERO, WORK(IPW3), HROWS )
+ CALL SLAMOV( 'All', HROWS, DIM4,
+ $ WORK(IPW3), HROWS,
+ $ H((JLOC-1)*LLDH+ILOC), LLDH )
+ END IF
+ END IF
+ 250 CONTINUE
+ END IF
+*
+ IF( DIR.EQ.2 .AND. WANTZ .AND. LENCBUF.GT.0 ) THEN
+ DO 260 INDX = 1, MIN(N,1+(NPROW-1)*NB), NB
+ IF( MYCOL.EQ.CSRC1 ) THEN
+ CALL INFOG2L( INDX, LKTOP, DESCZ, NPROW,
+ $ NPCOL, MYROW, MYCOL, ILOC, JLOC,
+ $ RSRC, CSRC1 )
+ IF( MYROW.EQ.RSRC ) THEN
+ CALL SGEMM( 'No transpose',
+ $ 'No transpose', ZROWS, DIM1,
+ $ LNWIN, ONE, WORK( IPW2 ),
+ $ ZROWS, WORK( IPU ), LNWIN,
+ $ ZERO, WORK(IPW3), ZROWS )
+ CALL SLAMOV( 'All', ZROWS, DIM1,
+ $ WORK(IPW3), ZROWS,
+ $ Z((JLOC-1)*LLDZ+ILOC), LLDZ )
+ END IF
+ END IF
+ IF( MYCOL.EQ.CSRC4 ) THEN
+ CALL INFOG2L( INDX, LKTOP+DIM1, DESCZ,
+ $ NPROW, NPCOL, MYROW, MYCOL, ILOC,
+ $ JLOC, RSRC, CSRC4 )
+ IF( MYROW.EQ.RSRC ) THEN
+ CALL SGEMM( 'No transpose',
+ $ 'No transpose', ZROWS, DIM4,
+ $ LNWIN, ONE, WORK( IPW2 ),
+ $ ZROWS,
+ $ WORK( IPU+LNWIN*DIM1 ), LNWIN,
+ $ ZERO, WORK(IPW3), ZROWS )
+ CALL SLAMOV( 'All', ZROWS, DIM4,
+ $ WORK(IPW3), ZROWS,
+ $ Z((JLOC-1)*LLDZ+ILOC), LLDZ )
+ END IF
+ END IF
+ 260 CONTINUE
+ END IF
+*
+* Update the rows of H.
+*
+ IF( DIR.EQ.1 .AND. WANTT .AND. LENRBUF.GT.0 ) THEN
+ IF( LKBOT.LT.N ) THEN
+ IF( MYROW.EQ.RSRC1.AND.MYCOL.EQ.CSRC4 .AND.
+ $ MOD(LKBOT,NB).NE.0 ) THEN
+ INDX = LKBOT + 1
+ CALL INFOG2L( LKTOP, INDX, DESCH, NPROW,
+ $ NPCOL, MYROW, MYCOL, ILOC, JLOC,
+ $ RSRC1, CSRC4 )
+ CALL SGEMM( 'Transpose', 'No Transpose',
+ $ DIM1, HCOLS, LNWIN, ONE, WORK(IPU),
+ $ LNWIN, WORK( IPW1 ), LNWIN, ZERO,
+ $ WORK(IPW3), DIM1 )
+ CALL SLAMOV( 'All', DIM1, HCOLS,
+ $ WORK(IPW3), DIM1,
+ $ H((JLOC-1)*LLDH+ILOC), LLDH )
+ END IF
+ IF( MYROW.EQ.RSRC4.AND.MYCOL.EQ.CSRC4 .AND.
+ $ MOD(LKBOT,NB).NE.0 ) THEN
+ INDX = LKBOT + 1
+ CALL INFOG2L( LKTOP+DIM1, INDX, DESCH,
+ $ NPROW, NPCOL, MYROW, MYCOL, ILOC,
+ $ JLOC, RSRC4, CSRC4 )
+ CALL SGEMM( 'Transpose', 'No Transpose',
+ $ DIM4, HCOLS, LNWIN, ONE,
+ $ WORK( IPU+DIM1*LNWIN ), LNWIN,
+ $ WORK( IPW1), LNWIN, ZERO,
+ $ WORK(IPW3), DIM4 )
+ CALL SLAMOV( 'All', DIM4, HCOLS,
+ $ WORK(IPW3), DIM4,
+ $ H((JLOC-1)*LLDH+ILOC), LLDH )
+ END IF
+ INDXS = ICEIL(LKBOT,NB)*NB + 1
+ IF( MOD(LKBOT,NB).NE.0 ) THEN
+ INDXE = MIN(N,INDXS+(NPCOL-2)*NB)
+ ELSE
+ INDXE = MIN(N,INDXS+(NPCOL-1)*NB)
+ END IF
+ DO 270 INDX = INDXS, INDXE, NB
+ IF( MYROW.EQ.RSRC1 ) THEN
+ CALL INFOG2L( LKTOP, INDX, DESCH,
+ $ NPROW, NPCOL, MYROW, MYCOL, ILOC,
+ $ JLOC, RSRC1, CSRC )
+ IF( MYCOL.EQ.CSRC ) THEN
+ CALL SGEMM( 'Transpose',
+ $ 'No Transpose', DIM1, HCOLS,
+ $ LNWIN, ONE, WORK( IPU ), LNWIN,
+ $ WORK( IPW1 ), LNWIN, ZERO,
+ $ WORK(IPW3), DIM1 )
+ CALL SLAMOV( 'All', DIM1, HCOLS,
+ $ WORK(IPW3), DIM1,
+ $ H((JLOC-1)*LLDH+ILOC), LLDH )
+ END IF
+ END IF
+ IF( MYROW.EQ.RSRC4 ) THEN
+ CALL INFOG2L( LKTOP+DIM1, INDX, DESCH,
+ $ NPROW, NPCOL, MYROW, MYCOL, ILOC,
+ $ JLOC, RSRC4, CSRC )
+ IF( MYCOL.EQ.CSRC ) THEN
+ CALL SGEMM( 'Transpose',
+ $ 'No Transpose', DIM4, HCOLS,
+ $ LNWIN, ONE,
+ $ WORK( IPU+LNWIN*DIM1 ), LNWIN,
+ $ WORK( IPW1 ), LNWIN,
+ $ ZERO, WORK(IPW3), DIM4 )
+ CALL SLAMOV( 'All', DIM4, HCOLS,
+ $ WORK(IPW3), DIM4,
+ $ H((JLOC-1)*LLDH+ILOC), LLDH )
+ END IF
+ END IF
+ 270 CONTINUE
+ END IF
+ END IF
+ ELSE
+*
+* Update the columns of H and Z.
+*
+* Compute H2*U21 + H1*U11 on the left side of the border.
+*
+ IF( DIR.EQ.2 .AND. WANTT .AND. LENCBUF.GT.0 ) THEN
+ INDXE = MIN(LKTOP-1,1+(NPROW-1)*NB)
+ DO 280 INDX = 1, INDXE, NB
+ IF( MYCOL.EQ.CSRC1 ) THEN
+ CALL INFOG2L( INDX, LKTOP, DESCH, NPROW,
+ $ NPCOL, MYROW, MYCOL, ILOC, JLOC,
+ $ RSRC, CSRC1 )
+ IF( MYROW.EQ.RSRC ) THEN
+ CALL SLAMOV( 'All', HROWS, KS,
+ $ WORK( IPW+HROWS*DIM4), HROWS,
+ $ WORK(IPW3), HROWS )
+ CALL STRMM( 'Right', 'Upper',
+ $ 'No transpose',
+ $ 'Non-unit', HROWS, KS, ONE,
+ $ WORK( IPU+DIM4 ), LNWIN,
+ $ WORK(IPW3), HROWS )
+ CALL SGEMM( 'No transpose',
+ $ 'No transpose', HROWS, KS, DIM4,
+ $ ONE, WORK( IPW ), HROWS,
+ $ WORK( IPU ), LNWIN, ONE,
+ $ WORK(IPW3), HROWS )
+ CALL SLAMOV( 'All', HROWS, KS,
+ $ WORK(IPW3), HROWS,
+ $ H((JLOC-1)*LLDH+ILOC), LLDH )
+ END IF
+ END IF
+*
+* Compute H1*U12 + H2*U22 on the right side of
+* the border.
+*
+ IF( MYCOL.EQ.CSRC4 ) THEN
+ CALL INFOG2L( INDX, LKTOP+DIM1, DESCH,
+ $ NPROW, NPCOL, MYROW, MYCOL, ILOC,
+ $ JLOC, RSRC, CSRC4 )
+ IF( MYROW.EQ.RSRC ) THEN
+ CALL SLAMOV( 'All', HROWS, DIM4,
+ $ WORK(IPW), HROWS, WORK( IPW3 ),
+ $ HROWS )
+ CALL STRMM( 'Right', 'Lower',
+ $ 'No transpose',
+ $ 'Non-unit', HROWS, DIM4, ONE,
+ $ WORK( IPU+LNWIN*KS ), LNWIN,
+ $ WORK( IPW3 ), HROWS )
+ CALL SGEMM( 'No transpose',
+ $ 'No transpose', HROWS, DIM4, KS,
+ $ ONE, WORK( IPW+HROWS*DIM4),
+ $ HROWS,
+ $ WORK( IPU+LNWIN*KS+DIM4 ), LNWIN,
+ $ ONE, WORK( IPW3 ), HROWS )
+ CALL SLAMOV( 'All', HROWS, DIM4,
+ $ WORK(IPW3), HROWS,
+ $ H((JLOC-1)*LLDH+ILOC), LLDH )
+ END IF
+ END IF
+ 280 CONTINUE
+ END IF
+*
+ IF( DIR.EQ.2 .AND. WANTZ .AND. LENCBUF.GT.0 ) THEN
+*
+* Compute Z2*U21 + Z1*U11 on the left side
+* of border.
+*
+ INDXE = MIN(N,1+(NPROW-1)*NB)
+ DO 290 INDX = 1, INDXE, NB
+ IF( MYCOL.EQ.CSRC1 ) THEN
+ CALL INFOG2L( INDX, I, DESCZ, NPROW,
+ $ NPCOL, MYROW, MYCOL, ILOC, JLOC,
+ $ RSRC, CSRC1 )
+ IF( MYROW.EQ.RSRC ) THEN
+ CALL SLAMOV( 'All', ZROWS, KS,
+ $ WORK( IPW2+ZROWS*DIM4),
+ $ ZROWS, WORK(IPW3), ZROWS )
+ CALL STRMM( 'Right', 'Upper',
+ $ 'No transpose',
+ $ 'Non-unit', ZROWS, KS, ONE,
+ $ WORK( IPU+DIM4 ), LNWIN,
+ $ WORK(IPW3), ZROWS )
+ CALL SGEMM( 'No transpose',
+ $ 'No transpose', ZROWS, KS,
+ $ DIM4, ONE, WORK( IPW2 ),
+ $ ZROWS, WORK( IPU ), LNWIN,
+ $ ONE, WORK(IPW3), ZROWS )
+ CALL SLAMOV( 'All', ZROWS, KS,
+ $ WORK(IPW3), ZROWS,
+ $ Z((JLOC-1)*LLDZ+ILOC), LLDZ )
+ END IF
+ END IF
+*
+* Compute Z1*U12 + Z2*U22 on the right side
+* of border.
+*
+ IF( MYCOL.EQ.CSRC4 ) THEN
+ CALL INFOG2L( INDX, I+DIM1, DESCZ,
+ $ NPROW, NPCOL, MYROW, MYCOL, ILOC,
+ $ JLOC, RSRC, CSRC4 )
+ IF( MYROW.EQ.RSRC ) THEN
+ CALL SLAMOV( 'All', ZROWS, DIM4,
+ $ WORK(IPW2), ZROWS,
+ $ WORK( IPW3 ), ZROWS )
+ CALL STRMM( 'Right', 'Lower',
+ $ 'No transpose',
+ $ 'Non-unit', ZROWS, DIM4,
+ $ ONE, WORK( IPU+LNWIN*KS ),
+ $ LNWIN, WORK( IPW3 ), ZROWS )
+ CALL SGEMM( 'No transpose',
+ $ 'No transpose', ZROWS, DIM4,
+ $ KS, ONE,
+ $ WORK( IPW2+ZROWS*(DIM4)),
+ $ ZROWS,
+ $ WORK( IPU+LNWIN*KS+DIM4 ),
+ $ LNWIN, ONE, WORK( IPW3 ),
+ $ ZROWS )
+ CALL SLAMOV( 'All', ZROWS, DIM4,
+ $ WORK(IPW3), ZROWS,
+ $ Z((JLOC-1)*LLDZ+ILOC), LLDZ )
+ END IF
+ END IF
+ 290 CONTINUE
+ END IF
+*
+ IF( DIR.EQ.1 .AND. WANTT .AND. LENRBUF.GT.0) THEN
+ IF ( LKBOT.LT.N ) THEN
+*
+* Compute U21**T*H2 + U11**T*H1 on the upper
+* side of the border.
+*
+ IF( MYROW.EQ.RSRC1.AND.MYCOL.EQ.CSRC4.AND.
+ $ MOD(LKBOT,NB).NE.0 ) THEN
+ INDX = LKBOT + 1
+ CALL INFOG2L( LKTOP, INDX, DESCH, NPROW,
+ $ NPCOL, MYROW, MYCOL, ILOC, JLOC,
+ $ RSRC1, CSRC4 )
+ CALL SLAMOV( 'All', KS, HCOLS,
+ $ WORK( IPW1+DIM4 ), LNWIN,
+ $ WORK(IPW3), KS )
+ CALL STRMM( 'Left', 'Upper', 'Transpose',
+ $ 'Non-unit', KS, HCOLS, ONE,
+ $ WORK( IPU+DIM4 ), LNWIN,
+ $ WORK(IPW3), KS )
+ CALL SGEMM( 'Transpose', 'No transpose',
+ $ KS, HCOLS, DIM4, ONE, WORK(IPU),
+ $ LNWIN, WORK(IPW1), LNWIN,
+ $ ONE, WORK(IPW3), KS )
+ CALL SLAMOV( 'All', KS, HCOLS,
+ $ WORK(IPW3), KS,
+ $ H((JLOC-1)*LLDH+ILOC), LLDH )
+ END IF
+*
+* Compute U12**T*H1 + U22**T*H2 one the lower
+* side of the border.
+*
+ IF( MYROW.EQ.RSRC4.AND.MYCOL.EQ.CSRC4.AND.
+ $ MOD(LKBOT,NB).NE.0 ) THEN
+ INDX = LKBOT + 1
+ CALL INFOG2L( LKTOP+DIM1, INDX, DESCH,
+ $ NPROW, NPCOL, MYROW, MYCOL, ILOC,
+ $ JLOC, RSRC4, CSRC4 )
+ CALL SLAMOV( 'All', DIM4, HCOLS,
+ $ WORK( IPW1 ), LNWIN,
+ $ WORK( IPW3 ), DIM4 )
+ CALL STRMM( 'Left', 'Lower', 'Transpose',
+ $ 'Non-unit', DIM4, HCOLS, ONE,
+ $ WORK( IPU+LNWIN*KS ), LNWIN,
+ $ WORK( IPW3 ), DIM4 )
+ CALL SGEMM( 'Transpose', 'No Transpose',
+ $ DIM4, HCOLS, KS, ONE,
+ $ WORK( IPU+LNWIN*KS+DIM4 ), LNWIN,
+ $ WORK( IPW1+DIM1 ), LNWIN,
+ $ ONE, WORK( IPW3), DIM4 )
+ CALL SLAMOV( 'All', DIM4, HCOLS,
+ $ WORK(IPW3), DIM4,
+ $ H((JLOC-1)*LLDH+ILOC), LLDH )
+ END IF
+*
+* Compute U21**T*H2 + U11**T*H1 on upper side
+* on border.
+*
+ INDXS = ICEIL(LKBOT,NB)*NB+1
+ IF( MOD(LKBOT,NB).NE.0 ) THEN
+ INDXE = MIN(N,INDXS+(NPCOL-2)*NB)
+ ELSE
+ INDXE = MIN(N,INDXS+(NPCOL-1)*NB)
+ END IF
+ DO 300 INDX = INDXS, INDXE, NB
+ IF( MYROW.EQ.RSRC1 ) THEN
+ CALL INFOG2L( LKTOP, INDX, DESCH,
+ $ NPROW, NPCOL, MYROW, MYCOL, ILOC,
+ $ JLOC, RSRC1, CSRC )
+ IF( MYCOL.EQ.CSRC ) THEN
+ CALL SLAMOV( 'All', KS, HCOLS,
+ $ WORK( IPW1+DIM4 ), LNWIN,
+ $ WORK(IPW3), KS )
+ CALL STRMM( 'Left', 'Upper',
+ $ 'Transpose', 'Non-unit',
+ $ KS, HCOLS, ONE,
+ $ WORK( IPU+DIM4 ), LNWIN,
+ $ WORK(IPW3), KS )
+ CALL SGEMM( 'Transpose',
+ $ 'No transpose', KS, HCOLS,
+ $ DIM4, ONE, WORK(IPU), LNWIN,
+ $ WORK(IPW1), LNWIN, ONE,
+ $ WORK(IPW3), KS )
+ CALL SLAMOV( 'All', KS, HCOLS,
+ $ WORK(IPW3), KS,
+ $ H((JLOC-1)*LLDH+ILOC), LLDH )
+ END IF
+ END IF
+*
+* Compute U12**T*H1 + U22**T*H2 on lower
+* side of border.
+*
+ IF( MYROW.EQ.RSRC4 ) THEN
+ CALL INFOG2L( LKTOP+DIM1, INDX, DESCH,
+ $ NPROW, NPCOL, MYROW, MYCOL, ILOC,
+ $ JLOC, RSRC4, CSRC )
+ IF( MYCOL.EQ.CSRC ) THEN
+ CALL SLAMOV( 'All', DIM4, HCOLS,
+ $ WORK( IPW1 ), LNWIN,
+ $ WORK( IPW3 ), DIM4 )
+ CALL STRMM( 'Left', 'Lower',
+ $ 'Transpose','Non-unit',
+ $ DIM4, HCOLS, ONE,
+ $ WORK( IPU+LNWIN*KS ), LNWIN,
+ $ WORK( IPW3 ), DIM4 )
+ CALL SGEMM( 'Transpose',
+ $ 'No Transpose', DIM4, HCOLS,
+ $ KS, ONE,
+ $ WORK( IPU+LNWIN*KS+DIM4 ),
+ $ LNWIN, WORK( IPW1+DIM1 ),
+ $ LNWIN, ONE, WORK( IPW3),
+ $ DIM4 )
+ CALL SLAMOV( 'All', DIM4, HCOLS,
+ $ WORK(IPW3), DIM4,
+ $ H((JLOC-1)*LLDH+ILOC), LLDH )
+ END IF
+ END IF
+ 300 CONTINUE
+ END IF
+ END IF
+ END IF
+*
+* Update window information - mark processed windows are
+* completed.
+*
+ IF( DIR.EQ.2 ) THEN
+ IF( LKBOT.EQ.KBOT ) THEN
+ LKTOP = KBOT+1
+ LKBOT = KBOT+1
+ IWORK( 1+(WIN-1)*5 ) = LKTOP
+ IWORK( 2+(WIN-1)*5 ) = LKBOT
+ ELSE
+ LKTOP = MIN( LKTOP + LNWIN - LCHAIN,
+ $ MIN( KBOT, ICEIL( LKBOT, NB )*NB ) -
+ $ LCHAIN + 1 )
+ IWORK( 1+(WIN-1)*5 ) = LKTOP
+ LKBOT = MIN( MAX( LKBOT + LNWIN - LCHAIN,
+ $ LKTOP + NWIN - 1), MIN( KBOT,
+ $ ICEIL( LKBOT, NB )*NB ) )
+ IWORK( 2+(WIN-1)*5 ) = LKBOT
+ END IF
+ IF( IWORK( 5+(WIN-1)*5 ).EQ.1 )
+ $ IWORK( 5+(WIN-1)*5 ) = 2
+ IWORK( 3+(WIN-1)*5 ) = RSRC4
+ IWORK( 4+(WIN-1)*5 ) = CSRC4
+ END IF
+*
+* If nothing was done for the WIN:th window, all
+* processors come here and consider the next one
+* instead.
+*
+ 245 CONTINUE
+ 240 CONTINUE
+ 190 CONTINUE
+ 150 CONTINUE
+ 140 CONTINUE
+*
+* Chased off bulges from first window?
+*
+ IF( NPROCS.GT.1 )
+ $ CALL IGAMX2D( ICTXT, 'All', '1-Tree', 1, 1, ICHOFF, 1,
+ $ -1, -1, -1, -1, -1 )
+*
+* If the bulge was chasen off from first window it is removed.
+*
+ IF( ICHOFF.GT.0 ) THEN
+ DO 198 WIN = 2, ANMWIN
+ IWORK( 1+(WIN-2)*5 ) = IWORK( 1+(WIN-1)*5 )
+ IWORK( 2+(WIN-2)*5 ) = IWORK( 2+(WIN-1)*5 )
+ IWORK( 3+(WIN-2)*5 ) = IWORK( 3+(WIN-1)*5 )
+ IWORK( 4+(WIN-2)*5 ) = IWORK( 4+(WIN-1)*5 )
+ 198 CONTINUE
+ ANMWIN = ANMWIN - 1
+ IPIW = 6+(ANMWIN-1)*5
+ END IF
+*
+* If we have no more windows, return.
+*
+ IF( ANMWIN.LT.1 ) RETURN
+*
+* Check for any more windows to bring over the border.
+*
+ WINFIN = 0
+ DO 199 WIN = 1, ANMWIN
+ WINFIN = WINFIN+IWORK( 5+(WIN-1)*5 )
+ 199 CONTINUE
+ IF( WINFIN.LT.2*ANMWIN ) GO TO 137
+*
+* Zero out process mark for each window - this is legal now when
+* the process starts over with local bulge-chasing etc.
+*
+ DO 201 WIN = 1, ANMWIN
+ IWORK( 5+(WIN-1)*5 ) = 0
+ 201 CONTINUE
+*
+ END IF
+*
+* Go back to local bulge-chase and see if there is more work to do.
+*
+ GO TO 20
+*
+* End of PSLAQR5
+*
+ END
diff --git a/SRC/pslarfb.f b/SRC/pslarfb.f
index a912079..2bf4e08 100644
--- a/SRC/pslarfb.f
+++ b/SRC/pslarfb.f
@@ -1,10 +1,9 @@
SUBROUTINE PSLARFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, V, IV,
$ JV, DESCV, T, C, IC, JC, DESCC, WORK )
*
-* -- ScaLAPACK auxiliary routine (version 1.7) --
-* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
-* and University of California, Berkeley.
-* May 1, 1997
+* -- ScaLAPACK auxiliary routine (version 2.0.2) --
+* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver
+* May 1 2012
*
* .. Scalar Arguments ..
CHARACTER SIDE, TRANS, DIRECT, STOREV
@@ -237,7 +236,7 @@
* .. External Subroutines ..
EXTERNAL BLACS_GRIDINFO, INFOG1L, INFOG2L, PB_TOPGET,
$ PBSTRAN, SGEBR2D, SGEBS2D, SGEMM,
- $ SGSUM2D, SLACPY, SLASET, STRBR2D,
+ $ SGSUM2D, SLAMOV, SLASET, STRBR2D,
$ STRBS2D, STRMM
* ..
* .. Intrinsic Functions ..
@@ -324,7 +323,7 @@
IF( MYROW.EQ.IVROW )
$ CALL STRBS2D( ICTXT, 'Rowwise', ROWBTOP, UPLO,
$ 'Non unit', K, K, T, NBV )
- CALL SLACPY( 'All', MPC, K, V( IOFFV ), LDV, WORK( IPV ),
+ CALL SLAMOV( 'All', MPC, K, V( IOFFV ), LDV, WORK( IPV ),
$ LV )
ELSE
CALL SGEBR2D( ICTXT, 'Rowwise', ROWBTOP, MPC, K,
@@ -461,11 +460,11 @@
CALL SLASET( 'All', IROFFV, K, ZERO, ZERO,
$ WORK( IPW ), LW )
IPW1 = IPW + IROFFV
- CALL SLACPY( 'All', NPV, K, V( IOFFV ), LDV,
+ CALL SLAMOV( 'All', NPV, K, V( IOFFV ), LDV,
$ WORK( IPW1 ), LW )
ELSE
IPW1 = IPW
- CALL SLACPY( 'All', NPV, K, V( IOFFV ), LDV,
+ CALL SLAMOV( 'All', NPV, K, V( IOFFV ), LDV,
$ WORK( IPW1 ), LW )
END IF
*
@@ -624,11 +623,11 @@
CALL SLASET( 'All', K, ICOFFV, ZERO, ZERO,
$ WORK( IPW ), LW )
IPW1 = IPW + ICOFFV * LW
- CALL SLACPY( 'All', K, MQV, V( IOFFV ), LDV,
+ CALL SLAMOV( 'All', K, MQV, V( IOFFV ), LDV,
$ WORK( IPW1 ), LW )
ELSE
IPW1 = IPW
- CALL SLACPY( 'All', K, MQV, V( IOFFV ), LDV,
+ CALL SLAMOV( 'All', K, MQV, V( IOFFV ), LDV,
$ WORK( IPW1 ), LW )
END IF
*
@@ -772,7 +771,7 @@
IF( MYCOL.EQ.IVCOL )
$ CALL STRBS2D( ICTXT, 'Columnwise', COLBTOP, UPLO,
$ 'Non unit', K, K, T, MBV )
- CALL SLACPY( 'All', K, NQC, V( IOFFV ), LDV, WORK( IPV ),
+ CALL SLAMOV( 'All', K, NQC, V( IOFFV ), LDV, WORK( IPV ),
$ LV )
ELSE
CALL SGEBR2D( ICTXT, 'Columnwise', COLBTOP, K, NQC,
diff --git a/SRC/pslarzb.f b/SRC/pslarzb.f
index 5dfc484..3a4544a 100644
--- a/SRC/pslarzb.f
+++ b/SRC/pslarzb.f
@@ -243,7 +243,7 @@
EXTERNAL BLACS_ABORT, BLACS_GRIDINFO, INFOG2L,
$ PBSMATADD, PBSTRAN, PB_TOPGET, PXERBLA,
$ SGEBR2D, SGEBS2D, SGEMM,
- $ SGSUM2D, SLACPY, SLASET, STRBR2D,
+ $ SGSUM2D, SLAMOV, SLASET, STRBR2D,
$ STRBS2D, STRMM
* ..
* .. Intrinsic Functions ..
@@ -380,10 +380,10 @@
*
IF( MYROW.EQ.IVROW ) THEN
IF( MYCOL.EQ.IVCOL ) THEN
- CALL SLACPY( 'All', K, MQV, V( IOFFV ), LDV,
+ CALL SLAMOV( 'All', K, MQV, V( IOFFV ), LDV,
$ WORK( IPW+ICOFFV*LW ), LW )
ELSE
- CALL SLACPY( 'All', K, MQV, V( IOFFV ), LDV,
+ CALL SLAMOV( 'All', K, MQV, V( IOFFV ), LDV,
$ WORK( IPW ), LW )
END IF
END IF
@@ -513,7 +513,7 @@
IF( MYCOL.EQ.IVCOL )
$ CALL STRBS2D( ICTXT, 'Columnwise', COLBTOP, 'Lower',
$ 'Non unit', K, K, T, MBV )
- CALL SLACPY( 'All', K, NQC2, V( IOFFV ), LDV, WORK( IPV ),
+ CALL SLAMOV( 'All', K, NQC2, V( IOFFV ), LDV, WORK( IPV ),
$ LV )
ELSE
CALL SGEBR2D( ICTXT, 'Columnwise', COLBTOP, K, NQC2,
diff --git a/SRC/pslascl.f b/SRC/pslascl.f
index 45c2236..0811666 100644
--- a/SRC/pslascl.f
+++ b/SRC/pslascl.f
@@ -153,10 +153,10 @@
EXTERNAL BLACS_GRIDINFO, CHK1MAT, INFOG2L, PXERBLA
* ..
* .. External Functions ..
- LOGICAL LSAME
+ LOGICAL LSAME, SISNAN
INTEGER ICEIL, NUMROC
REAL PSLAMCH
- EXTERNAL ICEIL, LSAME, NUMROC, PSLAMCH
+ EXTERNAL SISNAN, ICEIL, LSAME, NUMROC, PSLAMCH
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MIN, MOD
@@ -189,8 +189,10 @@
END IF
IF( ITYPE.EQ.-1 ) THEN
INFO = -1
- ELSE IF( CFROM.EQ.ZERO ) THEN
+ ELSE IF( CFROM.EQ.ZERO .OR. SISNAN(CFROM) ) THEN
INFO = -4
+ ELSE IF( SISNAN(CTO) ) THEN
+ INFO = -5
END IF
END IF
END IF
@@ -230,18 +232,32 @@
*
10 CONTINUE
CFROM1 = CFROMC*SMLNUM
- CTO1 = CTOC / BIGNUM
- IF( ABS( CFROM1 ).GT.ABS( CTOC ) .AND. CTOC.NE.ZERO ) THEN
- MUL = SMLNUM
- DONE = .FALSE.
- CFROMC = CFROM1
- ELSE IF( ABS( CTO1 ).GT.ABS( CFROMC ) ) THEN
- MUL = BIGNUM
- DONE = .FALSE.
- CTOC = CTO1
- ELSE
+ 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
*
IOFFA = ( JJA - 1 ) * LDA
diff --git a/SRC/pslasmsub.f b/SRC/pslasmsub.f
index 0010999..9872651 100644
--- a/SRC/pslasmsub.f
+++ b/SRC/pslasmsub.f
@@ -77,7 +77,7 @@
* Arguments
* =========
*
-* A (global input) REAL array, dimension
+* A (global input) REAL array, dimension
* (DESCA(LLD_),*)
* On entry, the Hessenberg matrix whose tridiagonal part is
* being scanned.
@@ -100,11 +100,11 @@
* On exit, this yields the bottom portion of the unreduced
* submatrix. This will satisfy: L <= M <= I-1.
*
-* SMLNUM (global input) REAL
+* SMLNUM (global input) REAL
* On entry, a "small number" for the given matrix.
* Unchanged on exit.
*
-* BUF (local output) REAL array of size LWORK.
+* BUF (local output) REAL array of size LWORK.
*
* LWORK (global input) INTEGER
* On exit, LWORK is the size of the work buffer.
@@ -126,7 +126,7 @@
* DO 20 K = I, L + 1, -1
* TST1 = ABS( H( K-1, K-1 ) ) + ABS( H( K, K ) )
* IF( TST1.EQ.ZERO )
-* $ TST1 = SLANHS( '1', I-L+1, H( L, L ), LDH, WORK )
+* $ TST1 = DLANHS( '1', I-L+1, H( L, L ), LDH, WORK )
* IF( ABS( H( K, K-1 ) ).LE.MAX( ULP*TST1, SMLNUM ) )
* $ GO TO 30
* 20 CONTINUE
@@ -146,11 +146,11 @@
PARAMETER ( ZERO = 0.0E+0 )
* ..
* .. Local Scalars ..
- INTEGER CONTXT, DOWN, HBL, IBUF1, IBUF2, ICOL1, ICOL2,
- $ II, III, IRCV1, IRCV2, IROW1, IROW2, ISRC,
- $ ISTR1, ISTR2, ITMP1, ITMP2, JJ, JJJ, JSRC, LDA,
- $ LEFT, MODKM1, MYCOL, MYROW, NPCOL, NPROW, NUM,
- $ RIGHT, UP
+ INTEGER CONTXT, DOWN, HBL, IAFIRST, IBUF1, IBUF2,
+ $ ICOL1, ICOL2, II, III, IRCV1, IRCV2, IROW1,
+ $ IROW2, ISRC, ISTR1, ISTR2, ITMP1, ITMP2,
+ $ JAFIRST, JJ, JJJ, JSRC, LDA, LEFT, MODKM1,
+ $ MYCOL, MYROW, NPCOL, NPROW, NUM, RIGHT, UP
REAL H10, H11, H22, TST1, ULP
* ..
* .. External Functions ..
@@ -170,6 +170,8 @@
HBL = DESCA( MB_ )
CONTXT = DESCA( CTXT_ )
LDA = DESCA( LLD_ )
+ IAFIRST = DESCA( RSRC_ )
+ JAFIRST = DESCA( CSRC_ )
ULP = PSLAMCH( CONTXT, 'PRECISION' )
CALL BLACS_GRIDINFO( CONTXT, NPROW, NPCOL, MYROW, MYCOL )
LEFT = MOD( MYCOL+NPCOL-1, NPCOL )
@@ -333,10 +335,10 @@
*
* FIND SOME NORM OF THE LOCAL H(L:I,L:I)
*
- CALL INFOG1L( L, HBL, NPROW, MYROW, 0, ITMP1, III )
- IROW2 = NUMROC( I, HBL, MYROW, 0, NPROW )
- CALL INFOG1L( L, HBL, NPCOL, MYCOL, 0, ITMP2, III )
- ICOL2 = NUMROC( I, HBL, MYCOL, 0, NPCOL )
+ CALL INFOG1L( L, HBL, NPROW, MYROW, IAFIRST, ITMP1, III )
+ IROW2 = NUMROC( I, HBL, MYROW, IAFIRST, NPROW )
+ CALL INFOG1L( L, HBL, NPCOL, MYCOL, JAFIRST, ITMP2, III )
+ ICOL2 = NUMROC( I, HBL, MYCOL, JAFIRST, NPCOL )
DO 30 III = ITMP1, IROW2
DO 20 JJJ = ITMP2, ICOL2
TST1 = TST1 + ABS( A( ( JJJ-1 )*LDA+III ) )
diff --git a/SRC/pslasrt.f b/SRC/pslasrt.f
index c2bb630..96a55ac 100644
--- a/SRC/pslasrt.f
+++ b/SRC/pslasrt.f
@@ -1,10 +1,9 @@
SUBROUTINE PSLASRT( ID, N, D, Q, IQ, JQ, DESCQ, WORK, LWORK,
$ IWORK, LIWORK, INFO )
*
-* -- ScaLAPACK auxiliary routine (version 1.7) --
-* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
-* and University of California, Berkeley.
-* February 22, 2000
+* -- ScaLAPACK auxiliary routine (version 2.0.2) --
+* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver
+* May 1 2012
*
* .. Scalar Arguments ..
CHARACTER ID
@@ -97,7 +96,7 @@
* ..
* .. External Subroutines ..
EXTERNAL BLACS_GRIDINFO, CHK1MAT, PXERBLA, SCOPY,
- $ SGERV2D, SGESD2D, SLACPY, SLAPST
+ $ SGERV2D, SGESD2D, SLAMOV, SLAPST
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN, MOD
@@ -247,7 +246,7 @@
ND = ND + NB
GO TO 20
END IF
- CALL SLACPY( 'Full', NP, NQ, WORK, NP, Q( IIQ ), LDQ )
+ CALL SLAMOV( 'Full', NP, NQ, WORK, NP, Q( IIQ ), LDQ )
*
* End of PSLASRT
*
diff --git a/SRC/psormrq.f b/SRC/psormrq.f
index ef17af0..d4b574f 100644
--- a/SRC/psormrq.f
+++ b/SRC/psormrq.f
@@ -223,7 +223,7 @@
$ RSRC_ = 7, CSRC_ = 8, LLD_ = 9 )
* ..
* .. Local Scalars ..
- LOGICAL LEFT, LQUERY, NOTRAN
+ LOGICAL LEFT, LQUERY, NOTRAN, RIGHT, TRAN
CHARACTER COLBTOP, ROWBTOP, TRANST
INTEGER I, I1, I2, I3, IACOL, IB, ICCOL, ICOFFA,
$ ICOFFC, ICROW, ICTXT, IINFO, IPW, IROFFC, LCM,
@@ -258,8 +258,20 @@
IF( NPROW.EQ.-1 ) THEN
INFO = -(900+CTXT_)
ELSE
- LEFT = LSAME( SIDE, 'L' )
- NOTRAN = LSAME( TRANS, 'N' )
+ IF( LSAME( SIDE, 'L' ) ) THEN
+ LEFT = .TRUE.
+ RIGHT = .FALSE.
+ ELSE
+ LEFT = .FALSE.
+ RIGHT = .TRUE.
+ END IF
+ IF( LSAME( TRANS, 'N' ) ) THEN
+ NOTRAN = .TRUE.
+ TRAN = .FALSE.
+ ELSE
+ NOTRAN = .FALSE.
+ TRAN = .TRUE.
+ END IF
*
* NQ is the order of Q
*
@@ -439,8 +451,8 @@
$ WORK( IPW ) )
10 CONTINUE
*
- IF( ( LEFT .AND. .NOT.NOTRAN ) .OR.
- $ ( .NOT.LEFT .AND. NOTRAN ) ) THEN
+ IF( ( RIGHT .AND. TRAN ) .OR.
+ $ ( LEFT .AND. NOTRAN ) ) THEN
IB = I2 - IA
IF( LEFT ) THEN
MI = M - K + IB
diff --git a/SRC/pspbtrf.f b/SRC/pspbtrf.f
index e12a2c5..5eea78f 100644
--- a/SRC/pspbtrf.f
+++ b/SRC/pspbtrf.f
@@ -1,10 +1,9 @@
SUBROUTINE PSPBTRF( UPLO, N, BW, A, JA, DESCA, AF, LAF, WORK,
$ LWORK, INFO )
*
-* -- ScaLAPACK routine (version 1.7) --
-* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
-* and University of California, Berkeley.
-* April 3, 2000
+* -- ScaLAPACK routine (version 2.0.2) --
+* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver
+* May 1 2012
*
* .. Scalar Arguments ..
CHARACTER UPLO
@@ -378,7 +377,7 @@
EXTERNAL BLACS_GRIDEXIT, BLACS_GRIDINFO, DESC_CONVERT,
$ GLOBCHK, IGAMX2D, IGEBR2D, IGEBS2D, PXERBLA,
$ RESHAPE, SAXPY, SGEMM, SGERV2D, SGESD2D,
- $ SLACPY, SLATCPY, SPBTRF, SPOTRF, SSYRK, STBTRS,
+ $ SLAMOV, SLATCPY, SPBTRF, SPOTRF, SSYRK, STBTRS,
$ STRMM, STRRV2D, STRSD2D, STRSM, STRTRS
* ..
* .. External Functions ..
@@ -863,7 +862,7 @@
* Copy last diagonal block into AF storage for subsequent
* operations.
*
- CALL SLACPY( 'N', BW, BW, A( OFST+ODD_SIZE*LLDA+1 ), LLDA-1,
+ CALL SLAMOV( 'N', BW, BW, A( OFST+ODD_SIZE*LLDA+1 ), LLDA-1,
$ AF( ODD_SIZE*BW+MBW2+1 ), BW )
*
* Receive cont. to diagonal block that is stored on this proc.
@@ -945,7 +944,7 @@
* Move block into place that it will be expected to be for
* calcs.
*
- CALL SLACPY( 'N', BW, BW, AF( ODD_SIZE*BW+1 ), BW,
+ CALL SLAMOV( 'N', BW, BW, AF( ODD_SIZE*BW+1 ), BW,
$ AF( ODD_SIZE*BW+2*MBW2+1 ), BW )
*
ELSE
@@ -1100,7 +1099,7 @@
*
* Move the connection block in preparation.
*
- CALL SLACPY( 'L', BW, BW, A( ( OFST+1+ODD_SIZE*LLDA ) ),
+ CALL SLAMOV( 'L', BW, BW, A( ( OFST+1+ODD_SIZE*LLDA ) ),
$ LLDA-1, AF( ODD_SIZE*BW+2*MBW2+1+BW-BW ), BW )
*
*
@@ -1112,7 +1111,7 @@
*
* Move the resulting block back to its location in main storage.
*
- CALL SLACPY( 'L', BW, BW, AF( ODD_SIZE*BW+2*MBW2+1+BW-BW ),
+ CALL SLAMOV( 'L', BW, BW, AF( ODD_SIZE*BW+2*MBW2+1+BW-BW ),
$ BW, A( ( OFST+1+ODD_SIZE*LLDA ) ), LLDA-1 )
*
*
@@ -1321,7 +1320,7 @@
* Move block into place that it will be expected to be for
* calcs.
*
- CALL SLACPY( 'N', BW, BW, AF( ODD_SIZE*BW+1 ), BW,
+ CALL SLAMOV( 'N', BW, BW, AF( ODD_SIZE*BW+1 ), BW,
$ AF( ODD_SIZE*BW+2*MBW2+1 ), BW )
*
ELSE
diff --git a/SRC/pspbtrsv.f b/SRC/pspbtrsv.f
index 2145102..0f4e410 100644
--- a/SRC/pspbtrsv.f
+++ b/SRC/pspbtrsv.f
@@ -1,10 +1,9 @@
SUBROUTINE PSPBTRSV( UPLO, TRANS, N, BW, NRHS, A, JA, DESCA, B,
$ IB, DESCB, AF, LAF, WORK, LWORK, INFO )
*
-* -- ScaLAPACK routine (version 1.7) --
-* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
-* and University of California, Berkeley.
-* April 3, 2000
+* -- ScaLAPACK routine (version 2.0.2) --
+* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver
+* May 1 2012
*
* .. Scalar Arguments ..
CHARACTER TRANS, UPLO
@@ -395,7 +394,7 @@
* .. External Subroutines ..
EXTERNAL BLACS_GRIDEXIT, BLACS_GRIDINFO, DESC_CONVERT,
$ GLOBCHK, PXERBLA, RESHAPE, SGEMM, SGERV2D,
- $ SGESD2D, SLACPY, SMATADD, STBTRS, STRMM, STRTRS
+ $ SGESD2D, SLAMOV, SMATADD, STBTRS, STRMM, STRTRS
* ..
* .. External Functions ..
LOGICAL LSAME
@@ -761,7 +760,7 @@
* First copy and multiply it into temporary storage,
* then use it on RHS
*
- CALL SLACPY( 'N', BW, NRHS,
+ CALL SLAMOV( 'N', BW, NRHS,
$ B( PART_OFFSET+ODD_SIZE-BW+1 ), LLDB,
$ WORK( 1 ), BW )
*
@@ -1085,7 +1084,7 @@
* First copy and multiply it into temporary storage,
* then use it on RHS
*
- CALL SLACPY( 'N', BW, NRHS, B( PART_OFFSET+ODD_SIZE+1 ),
+ CALL SLAMOV( 'N', BW, NRHS, B( PART_OFFSET+ODD_SIZE+1 ),
$ LLDB, WORK( 1+BW-BW ), BW )
*
CALL STRMM( 'L', 'U', 'T', 'N', BW, NRHS, -ONE,
@@ -1135,7 +1134,7 @@
* First copy and multiply it into temporary storage,
* then use it on RHS
*
- CALL SLACPY( 'N', BW, NRHS,
+ CALL SLAMOV( 'N', BW, NRHS,
$ B( PART_OFFSET+ODD_SIZE-BW+1 ), LLDB,
$ WORK( 1 ), BW )
*
@@ -1459,7 +1458,7 @@
* First copy and multiply it into temporary storage,
* then use it on RHS
*
- CALL SLACPY( 'N', BW, NRHS, B( PART_OFFSET+ODD_SIZE+1 ),
+ CALL SLAMOV( 'N', BW, NRHS, B( PART_OFFSET+ODD_SIZE+1 ),
$ LLDB, WORK( 1+BW-BW ), BW )
*
CALL STRMM( 'L', 'L', 'N', 'N', BW, NRHS, -ONE,
diff --git a/SRC/psrot.f b/SRC/psrot.f
new file mode 100644
index 0000000..af8ee20
--- /dev/null
+++ b/SRC/psrot.f
@@ -0,0 +1,442 @@
+ SUBROUTINE PSROT( N, X, IX, JX, DESCX, INCX, Y, IY, JY, DESCY,
+ $ INCY, CS, SN, WORK, LWORK, INFO )
+*
+* Contribution from the Department of Computing Science and HPC2N,
+* Umea University, Sweden
+*
+* -- ScaLAPACK auxiliary routine (version 2.0.1) --
+* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
+* Univ. of Colorado Denver and University of California, Berkeley.
+* January, 2012
+*
+ IMPLICIT NONE
+*
+* .. Scalar Arguments ..
+ INTEGER N, IX, JX, INCX, IY, JY, INCY, LWORK, INFO
+ REAL CS, SN
+* ..
+* .. Array Arguments ..
+ INTEGER DESCX( * ), DESCY( * )
+ REAL X( * ), Y( * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+* PSROT applies a planar rotation defined by CS and SN to the
+* two distributed vectors sub(X) and sub(Y).
+*
+* Notes
+* =====
+*
+* Each global data object is described by an associated description
+* vector. This vector stores the information required to establish
+* the mapping between an object element and its corresponding process
+* and memory location.
+*
+* Let A be a generic term for any 2D block cyclicly distributed array.
+* Such a global array has an associated description vector DESCA.
+* In the following comments, the character _ should be read as
+* "of the global array".
+*
+* NOTATION STORED IN EXPLANATION
+* --------------- -------------- --------------------------------------
+* DTYPE_A(global) DESCA( DTYPE_ )The descriptor type. In this case,
+* DTYPE_A = 1.
+* CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating
+* the BLACS process grid A is distribu-
+* ted over. The context itself is glo-
+* bal, but the handle (the integer
+* value) may vary.
+* M_A (global) DESCA( M_ ) The number of rows in the global
+* array A.
+* N_A (global) DESCA( N_ ) The number of columns in the global
+* array A.
+* MB_A (global) DESCA( MB_ ) The blocking factor used to distribute
+* the rows of the array.
+* NB_A (global) DESCA( NB_ ) The blocking factor used to distribute
+* the columns of the array.
+* RSRC_A (global) DESCA( RSRC_ ) The process row over which the first
+* row of the array A is distributed.
+* CSRC_A (global) DESCA( CSRC_ ) The process column over which the
+* first column of the array A is
+* distributed.
+* LLD_A (local) DESCA( LLD_ ) The leading dimension of the local
+* array. LLD_A >= MAX(1,LOCr(M_A)).
+*
+* Let K be the number of rows or columns of a distributed matrix,
+* and assume that its process grid has dimension p x q.
+* LOCr( K ) denotes the number of elements of K that a process
+* would receive if K were distributed over the p processes of its
+* process column.
+* Similarly, LOCc( K ) denotes the number of elements of K that a
+* process would receive if K were distributed over the q processes of
+* its process row.
+* The values of LOCr() and LOCc() may be determined via a call to the
+* ScaLAPACK tool function, NUMROC:
+* LOCr( M ) = NUMROC( M, MB_A, MYROW, RSRC_A, NPROW ),
+* LOCc( N ) = NUMROC( N, NB_A, MYCOL, CSRC_A, NPCOL ).
+* An upper bound for these quantities may be computed by:
+* LOCr( M ) <= ceil( ceil(M/MB_A)/NPROW )*MB_A
+* LOCc( N ) <= ceil( ceil(N/NB_A)/NPCOL )*NB_A
+*
+* Arguments
+* =========
+*
+* N (global input) INTEGER
+* The number of elements to operate on when applying the planar
+* rotation to X and Y. N>=0.
+*
+* X (local input/local output) DOUBLE PRECSION array of dimension
+* ( (JX-1)*M_X + IX + ( N - 1 )*abs( INCX ) )
+* This array contains the entries of the distributed vector
+* sub( X ).
+*
+* IX (global input) INTEGER
+* The global row index of the submatrix of the distributed
+* matrix X to operate on. If INCX = 1, then it is required
+* that IX = IY. 1 <= IX <= M_X.
+*
+* JX (global input) INTEGER
+* The global column index of the submatrix of the distributed
+* matrix X to operate on. If INCX = M_X, then it is required
+* that JX = JY. 1 <= IX <= N_X.
+*
+* DESCX (global and local input) INTEGER array of dimension 9
+* The array descriptor of the distributed matrix X.
+*
+* INCX (global input) INTEGER
+* The global increment for the elements of X. Only two values
+* of INCX are supported in this version, namely 1 and M_X.
+* Moreover, it must hold that INCX = M_X if INCY = M_Y and
+* that INCX = 1 if INCY = 1.
+*
+* Y (local input/local output) DOUBLE PRECSION array of dimension
+* ( (JY-1)*M_Y + IY + ( N - 1 )*abs( INCY ) )
+* This array contains the entries of the distributed vector
+* sub( Y ).
+*
+* IY (global input) INTEGER
+* The global row index of the submatrix of the distributed
+* matrix Y to operate on. If INCY = 1, then it is required
+* that IY = IX. 1 <= IY <= M_Y.
+*
+* JY (global input) INTEGER
+* The global column index of the submatrix of the distributed
+* matrix Y to operate on. If INCY = M_X, then it is required
+* that JY = JX. 1 <= JY <= N_Y.
+*
+* DESCY (global and local input) INTEGER array of dimension 9
+* The array descriptor of the distributed matrix Y.
+*
+* INCY (global input) INTEGER
+* The global increment for the elements of Y. Only two values
+* of INCY are supported in this version, namely 1 and M_Y.
+* Moreover, it must hold that INCY = M_Y if INCX = M_X and
+* that INCY = 1 if INCX = 1.
+*
+* CS (global input) REAL
+* SN (global input) REAL
+* The parameters defining the properties of the planar
+* rotation. It must hold that 0 <= CS,SN <= 1 and that
+* SN**2 + CS**2 = 1. The latter is hardly checked in
+* finite precision arithmetics.
+*
+* WORK (local input) REAL array of dimension LWORK
+* Local workspace area.
+*
+* LWORK (local input) INTEGER
+* The length of the workspace array WORK.
+* If INCX = 1 and INCY = 1, then LWORK = 2*MB_X
+*
+* If LWORK = -1, then a workspace query is assumed; the
+* routine only calculates the optimal size of the WORK array,
+* returns this value as the first entry of the IWORK array, and
+* no error message related to LIWORK is issued by PXERBLA.
+*
+* INFO (global output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value.
+* If the i-th argument is an array and the j-entry had
+* an illegal value, then INFO = -(i*100+j), if the i-th
+* argument is a scalar and had an illegal value, then INFO = -i.
+*
+* Additional requirements
+* =======================
+*
+* The following alignment requirements must hold:
+* (a) DESCX( MB_ ) = DESCY( MB_ ) and DESCX( NB_ ) = DESCY( NB_ )
+* (b) DESCX( RSRC_ ) = DESCY( RSRC_ )
+* (c) DESCX( CSRC_ ) = DESCY( CSRC_ )
+*
+* =====================================================================
+*
+* Written by Robert Granat, May 15, 2007.
+*
+* .. Parameters ..
+ INTEGER BLOCK_CYCLIC_2D, CSRC_, CTXT_, DLEN_, DTYPE_,
+ $ LLD_, MB_, M_, NB_, N_, RSRC_
+ PARAMETER ( BLOCK_CYCLIC_2D = 1, DLEN_ = 9, DTYPE_ = 1,
+ $ CTXT_ = 2, M_ = 3, N_ = 4, MB_ = 5, NB_ = 6,
+ $ RSRC_ = 7, CSRC_ = 8, LLD_ = 9 )
+* ..
+* .. Local Scalars ..
+ LOGICAL LQUERY, LEFT, RIGHT
+ INTEGER ICTXT, NPROW, NPCOL, MYROW, MYCOL, NPROCS,
+ $ MB, NB, XYROWS, XYCOLS, RSRC1, RSRC2, CSRC1,
+ $ CSRC2, ICOFFXY, IROFFXY, MNWRK, LLDX, LLDY,
+ $ INDX, JXX, XLOC1, XLOC2, RSRC, CSRC, YLOC1,
+ $ YLOC2, JYY, IXX, IYY
+* ..
+* .. External Functions ..
+ INTEGER NUMROC, INDXG2P, INDXG2L
+ EXTERNAL NUMROC, INDXG2P, INDXG2L
+* ..
+* .. External Subroutines ..
+ EXTERNAL SROT
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, MIN
+* ..
+* .. Local Functions ..
+ INTEGER ICEIL
+* ..
+* .. Executable Statements ..
+*
+* Get grid parameters
+*
+ ICTXT = DESCX( CTXT_ )
+ CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL )
+ NPROCS = NPROW*NPCOL
+*
+* Test and decode parameters
+*
+ LQUERY = LWORK.EQ.-1
+ INFO = 0
+ IF( N.LT.0 ) THEN
+ INFO = -1
+ ELSEIF( IX.LT.1 .OR. IX.GT.DESCX(M_) ) THEN
+ INFO = -3
+ ELSEIF( JX.LT.1 .OR. JX.GT.DESCX(N_) ) THEN
+ INFO = -4
+ ELSEIF( INCX.NE.1 .AND. INCX.NE.DESCX(M_) ) THEN
+ INFO = -6
+ ELSEIF( IY.LT.1 .OR. IY.GT.DESCY(M_) ) THEN
+ INFO = -8
+ ELSEIF( JY.LT.1 .OR. JY.GT.DESCY(N_) ) THEN
+ INFO = -9
+ ELSEIF( INCY.NE.1 .AND. INCY.NE.DESCY(M_) ) THEN
+ INFO = -11
+ ELSEIF( (INCX.EQ.DESCX(M_) .AND. INCY.NE.DESCY(M_)) .OR.
+ $ (INCX.EQ.1 .AND. INCY.NE.1 ) ) THEN
+ INFO = -11
+ ELSEIF( (INCX.EQ.1 .AND. INCY.EQ.1) .AND.
+ $ IX.NE.IY ) THEN
+ INFO = -8
+ ELSEIF( (INCX.EQ.DESCX(M_) .AND. INCY.EQ.DESCY(M_)) .AND.
+ $ JX.NE.JY ) THEN
+ INFO = -9
+ END IF
+*
+* Compute the direction of the planar rotation
+*
+ LEFT = INCX.EQ.DESCX(M_) .AND. INCY.EQ.DESCY(M_)
+ RIGHT = INCX.EQ.1 .AND. INCY.EQ.1
+*
+* Check blocking factors and root processor
+*
+ IF( INFO.EQ.0 ) THEN
+ IF( LEFT .AND. DESCX(NB_).NE.DESCY(NB_) ) THEN
+ INFO = -(100*5 + NB_)
+ END IF
+ IF( RIGHT .AND. DESCX(MB_).NE.DESCY(NB_) ) THEN
+ INFO = -(100*10 + MB_)
+ END IF
+ END IF
+ IF( INFO.EQ.0 ) THEN
+ IF( LEFT .AND. DESCX(CSRC_).NE.DESCY(CSRC_) ) THEN
+ INFO = -(100*5 + CSRC_)
+ END IF
+ IF( RIGHT .AND. DESCX(RSRC_).NE.DESCY(RSRC_) ) THEN
+ INFO = -(100*10 + RSRC_)
+ END IF
+ END IF
+*
+* Compute workspace
+*
+ MB = DESCX( MB_ )
+ NB = DESCX( NB_ )
+ IF( LEFT ) THEN
+ RSRC1 = INDXG2P( IX, MB, MYROW, DESCX(RSRC_), NPROW )
+ RSRC2 = INDXG2P( IY, MB, MYROW, DESCY(RSRC_), NPROW )
+ CSRC = INDXG2P( JX, NB, MYCOL, DESCX(CSRC_), NPCOL )
+ ICOFFXY = MOD( JX - 1, NB )
+ XYCOLS = NUMROC( N+ICOFFXY, NB, MYCOL, CSRC, NPCOL )
+ IF( ( MYROW.EQ.RSRC1 .OR. MYROW.EQ.RSRC2 ) .AND.
+ $ MYCOL.EQ.CSRC ) XYCOLS = XYCOLS - ICOFFXY
+ IF( RSRC1.NE.RSRC2 ) THEN
+ MNWRK = XYCOLS
+ ELSE
+ MNWRK = 0
+ END IF
+ ELSEIF( RIGHT ) THEN
+ CSRC1 = INDXG2P( JX, NB, MYCOL, DESCX(CSRC_), NPCOL )
+ CSRC2 = INDXG2P( JY, NB, MYCOL, DESCY(CSRC_), NPCOL )
+ RSRC = INDXG2P( IX, MB, MYROW, DESCX(RSRC_), NPROW )
+ IROFFXY = MOD( IX - 1, MB )
+ XYROWS = NUMROC( N+IROFFXY, MB, MYROW, RSRC, NPROW )
+ IF( ( MYCOL.EQ.CSRC1 .OR. MYCOL.EQ.CSRC2 ) .AND.
+ $ MYROW.EQ.RSRC ) XYROWS = XYROWS - IROFFXY
+ IF( CSRC1.NE.CSRC2 ) THEN
+ MNWRK = XYROWS
+ ELSE
+ MNWRK = 0
+ END IF
+ END IF
+ IF( INFO.EQ.0 ) THEN
+ IF( .NOT.LQUERY . AND. LWORK.LT.MNWRK ) INFO = -15
+ END IF
+*
+* Return if some argument is incorrect
+*
+ IF( INFO.NE.0 ) THEN
+ CALL PXERBLA( ICTXT, 'PSROT', -INFO )
+ RETURN
+ ELSEIF( LQUERY ) THEN
+ WORK( 1 ) = FLOAT(MNWRK)
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 ) THEN
+ RETURN
+ END IF
+*
+* Extract local leading dimensions
+*
+ LLDX = DESCX( LLD_ )
+ LLDY = DESCY( LLD_ )
+*
+* If we have only one process, use the corresponding LAPACK
+* routine and return
+*
+ IF( NPROCS.EQ.1 ) THEN
+ IF( LEFT ) THEN
+ CALL SROT( N, X((JX-1)*LLDX+IX), LLDX, Y((JY-1)*LLDY+IY),
+ $ LLDY, CS, SN )
+ ELSEIF( RIGHT ) THEN
+ CALL SROT( N, X((JX-1)*LLDX+IX), 1, Y((JY-1)*LLDY+IY),
+ $ 1, CS, SN )
+ END IF
+ RETURN
+ END IF
+*
+* Exchange data between processors if necessary and perform planar
+* rotation
+*
+ IF( LEFT ) THEN
+ DO 10 INDX = 1, NPCOL
+ IF( MYROW.EQ.RSRC1 .AND. XYCOLS.GT.0 ) THEN
+ IF( INDX.EQ.1 ) THEN
+ JXX = JX
+ ELSE
+ JXX = JX-ICOFFXY + (INDX-1)*NB
+ END IF
+ CALL INFOG2L( IX, JXX, DESCX, NPROW, NPCOL, MYROW,
+ $ MYCOL, XLOC1, XLOC2, RSRC, CSRC )
+ IF( MYROW.EQ.RSRC .AND. MYCOL.EQ.CSRC ) THEN
+ IF( RSRC1.NE.RSRC2 ) THEN
+ CALL SGESD2D( ICTXT, 1, XYCOLS,
+ $ X((XLOC2-1)*LLDX+XLOC1), LLDX,
+ $ RSRC2, CSRC )
+ CALL SGERV2D( ICTXT, 1, XYCOLS, WORK, 1,
+ $ RSRC2, CSRC )
+ CALL SROT( XYCOLS, X((XLOC2-1)*LLDX+XLOC1),
+ $ LLDX, WORK, 1, CS, SN )
+ ELSE
+ CALL INFOG2L( IY, JXX, DESCY, NPROW, NPCOL,
+ $ MYROW, MYCOL, YLOC1, YLOC2, RSRC,
+ $ CSRC )
+ CALL SROT( XYCOLS, X((XLOC2-1)*LLDX+XLOC1),
+ $ LLDX, Y((YLOC2-1)*LLDY+YLOC1), LLDY, CS,
+ $ SN )
+ END IF
+ END IF
+ END IF
+ IF( MYROW.EQ.RSRC2 .AND. RSRC1.NE.RSRC2 ) THEN
+ IF( INDX.EQ.1 ) THEN
+ JYY = JY
+ ELSE
+ JYY = JY-ICOFFXY + (INDX-1)*NB
+ END IF
+ CALL INFOG2L( IY, JYY, DESCY, NPROW, NPCOL, MYROW,
+ $ MYCOL, YLOC1, YLOC2, RSRC, CSRC )
+ IF( MYROW.EQ.RSRC .AND. MYCOL.EQ.CSRC ) THEN
+ CALL SGESD2D( ICTXT, 1, XYCOLS,
+ $ Y((YLOC2-1)*LLDY+YLOC1), LLDY,
+ $ RSRC1, CSRC )
+ CALL SGERV2D( ICTXT, 1, XYCOLS, WORK, 1,
+ $ RSRC1, CSRC )
+ CALL SROT( XYCOLS, WORK, 1, Y((YLOC2-1)*LLDY+YLOC1),
+ $ LLDY, CS, SN )
+ END IF
+ END IF
+ 10 CONTINUE
+ ELSEIF( RIGHT ) THEN
+ DO 20 INDX = 1, NPROW
+ IF( MYCOL.EQ.CSRC1 .AND. XYROWS.GT.0 ) THEN
+ IF( INDX.EQ.1 ) THEN
+ IXX = IX
+ ELSE
+ IXX = IX-IROFFXY + (INDX-1)*MB
+ END IF
+ CALL INFOG2L( IXX, JX, DESCX, NPROW, NPCOL, MYROW,
+ $ MYCOL, XLOC1, XLOC2, RSRC, CSRC )
+ IF( MYROW.EQ.RSRC .AND. MYCOL.EQ.CSRC ) THEN
+ IF( CSRC1.NE.CSRC2 ) THEN
+ CALL SGESD2D( ICTXT, XYROWS, 1,
+ $ X((XLOC2-1)*LLDX+XLOC1), LLDX,
+ $ RSRC, CSRC2 )
+ CALL SGERV2D( ICTXT, XYROWS, 1, WORK, XYROWS,
+ $ RSRC, CSRC2 )
+ CALL SROT( XYROWS, X((XLOC2-1)*LLDX+XLOC1),
+ $ 1, WORK, 1, CS, SN )
+ ELSE
+ CALL INFOG2L( IXX, JY, DESCY, NPROW, NPCOL,
+ $ MYROW, MYCOL, YLOC1, YLOC2, RSRC,
+ $ CSRC )
+ CALL SROT( XYROWS, X((XLOC2-1)*LLDX+XLOC1),
+ $ 1, Y((YLOC2-1)*LLDY+YLOC1), 1, CS,
+ $ SN )
+ END IF
+ END IF
+ END IF
+ IF( MYCOL.EQ.CSRC2 .AND. CSRC1.NE.CSRC2 ) THEN
+ IF( INDX.EQ.1 ) THEN
+ IYY = IY
+ ELSE
+ IYY = IY-IROFFXY + (INDX-1)*MB
+ END IF
+ CALL INFOG2L( IYY, JY, DESCY, NPROW, NPCOL, MYROW,
+ $ MYCOL, YLOC1, YLOC2, RSRC, CSRC )
+ IF( MYROW.EQ.RSRC .AND. MYCOL.EQ.CSRC ) THEN
+ CALL SGESD2D( ICTXT, XYROWS, 1,
+ $ Y((YLOC2-1)*LLDY+YLOC1), LLDY,
+ $ RSRC, CSRC1 )
+ CALL SGERV2D( ICTXT, XYROWS, 1, WORK, XYROWS,
+ $ RSRC, CSRC1 )
+ CALL SROT( XYROWS, WORK, 1, Y((YLOC2-1)*LLDY+YLOC1),
+ $ 1, CS, SN )
+ END IF
+ END IF
+ 20 CONTINUE
+ END IF
+*
+* Store minimum workspace requirements in WORK-array and return
+*
+ WORK( 1 ) = FLOAT(MNWRK)
+ RETURN
+*
+* End of PSROT
+*
+ END
diff --git a/SRC/pssyev.f b/SRC/pssyev.f
index fd8f4db..c709feb 100644
--- a/SRC/pssyev.f
+++ b/SRC/pssyev.f
@@ -125,8 +125,7 @@
* correct error reporting.
*
* W (global output) REAL array, dimension (N)
-* On normal exit, the first M entries contain the selected
-* eigenvalues in ascending order.
+* If INFO=0, the eigenvalues in ascending order.
*
* Z (local output) REAL array,
* global dimension (N, N),
@@ -342,6 +341,8 @@
$ NB_A ) + NB_A*NB_A
ELSE
SIZEMQRLEFT = 0
+ IROFFZ = 0
+ IZROW = 0
END IF
SIZESYTRD = MAX( NB * ( NP +1 ), 3 * NB )
*
diff --git a/SRC/pssyevr.f b/SRC/pssyevr.f
new file mode 100644
index 0000000..146df0f
--- /dev/null
+++ b/SRC/pssyevr.f
@@ -0,0 +1,1167 @@
+ SUBROUTINE PSSYEVR( JOBZ, RANGE, UPLO, N, A, IA, JA,
+ $ DESCA, VL, VU, IL, IU, M, NZ, W, Z, IZ,
+ $ JZ, DESCZ, WORK, LWORK, IWORK, LIWORK,
+ $ INFO )
+
+ IMPLICIT NONE
+*
+* -- ScaLAPACK routine (version 2.0.2) --
+* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver
+* May 1 2012
+*
+* .. Scalar Arguments ..
+ CHARACTER JOBZ, RANGE, UPLO
+ INTEGER IA, IL, INFO, IU, IZ, JA, JZ, LIWORK, LWORK, M,
+ $ N, NZ
+ REAL VL, VU
+* ..
+* .. Array Arguments ..
+ INTEGER DESCA( * ), DESCZ( * ), IWORK( * )
+ REAL A( * ), W( * ), WORK( * ), Z( * )
+* ..
+*
+* Purpose
+* =======
+*
+* PSSYEVR computes selected eigenvalues and, optionally, eigenvectors
+* of a real symmetric matrix A distributed in 2D blockcyclic format
+* by calling the recommended sequence of ScaLAPACK routines.
+*
+* First, the matrix A is reduced to real symmetric tridiagonal form.
+* Then, the eigenproblem is solved using the parallel MRRR algorithm.
+* Last, if eigenvectors have been computed, a backtransformation is done.
+*
+* Upon successful completion, each processor stores a copy of all computed
+* eigenvalues in W. The eigenvector matrix Z is stored in
+* 2D blockcyclic format distributed over all processors.
+*
+* Note that subsets of eigenvalues/vectors can be selected by
+* specifying a range of values or a range of indices for the desired
+* eigenvalues.
+*
+* For constructive feedback and comments, please contact cvoemel at lbl.gov
+* C. Voemel
+*
+* Arguments
+* =========
+*
+* JOBZ (global input) CHARACTER*1
+* Specifies whether or not to compute the eigenvectors:
+* = 'N': Compute eigenvalues only.
+* = 'V': Compute eigenvalues and eigenvectors.
+*
+* RANGE (global input) CHARACTER*1
+* = 'A': all eigenvalues will be found.
+* = 'V': all eigenvalues in the interval [VL,VU] will be found.
+* = 'I': the IL-th through IU-th eigenvalues will be found.
+*
+* UPLO (global input) CHARACTER*1
+* Specifies whether the upper or lower triangular part of the
+* symmetric matrix A is stored:
+* = 'U': Upper triangular
+* = 'L': Lower triangular
+*
+* N (global input) INTEGER
+* The number of rows and columns of the matrix A. N >= 0
+*
+* A (local input/workspace) 2D block cyclic REAL array,
+* global dimension (N, N),
+* local dimension ( LLD_A, LOCc(JA+N-1) ),
+* (see Notes below for more detailed explanation of 2d arrays)
+*
+* On entry, the symmetric matrix A. If UPLO = 'U', only the
+* upper triangular part of A is used to define the elements of
+* the symmetric matrix. If UPLO = 'L', only the lower
+* triangular part of A is used to define the elements of the
+* symmetric matrix.
+*
+* On exit, the lower triangle (if UPLO='L') or the upper
+* triangle (if UPLO='U') of A, including the diagonal, is
+* destroyed.
+*
+* IA (global input) INTEGER
+* A's global row index, which points to the beginning of the
+* submatrix which is to be operated on.
+* It should be set to 1 when operating on a full matrix.
+*
+* JA (global input) INTEGER
+* A's global column index, which points to the beginning of
+* the submatrix which is to be operated on.
+* It should be set to 1 when operating on a full matrix.
+*
+* DESCA (global and local input) INTEGER array of dimension DLEN=9.
+* The array descriptor for the distributed matrix A.
+* The descriptor stores details about the 2D block-cyclic
+* storage, see the notes below.
+* If DESCA is incorrect, PSSYEVR cannot guarantee
+* correct error reporting.
+* Also note the array alignment requirements specified below.
+*
+* VL (global input) REAL
+* If RANGE='V', the lower bound of the interval to be searched
+* for eigenvalues. Not referenced if RANGE = 'A' or 'I'.
+*
+* VU (global input) REAL
+* If RANGE='V', the upper bound of the interval to be searched
+* for eigenvalues. Not referenced if RANGE = 'A' or 'I'.
+*
+* IL (global input) INTEGER
+* If RANGE='I', the index (from smallest to largest) of the
+* smallest eigenvalue to be returned. IL >= 1.
+* Not referenced if RANGE = 'A'.
+*
+* IU (global input) INTEGER
+* If RANGE='I', the index (from smallest to largest) of the
+* largest eigenvalue to be returned. min(IL,N) <= IU <= N.
+* Not referenced if RANGE = 'A'.
+*
+* M (global output) INTEGER
+* Total number of eigenvalues found. 0 <= M <= N.
+*
+* NZ (global output) INTEGER
+* Total number of eigenvectors computed. 0 <= NZ <= M.
+* The number of columns of Z that are filled.
+* If JOBZ .NE. 'V', NZ is not referenced.
+* If JOBZ .EQ. 'V', NZ = M
+*
+* W (global output) REAL array, dimension (N)
+* Upon successful exit, the first M entries contain the selected
+* eigenvalues in ascending order.
+*
+* Z (local output) REAL array,
+* global dimension (N, N),
+* local dimension ( LLD_Z, LOCc(JZ+N-1) )
+* (see Notes below for more detailed explanation of 2d arrays)
+* If JOBZ = 'V', then on normal exit the first M columns of Z
+* contain the orthonormal eigenvectors of the matrix
+* corresponding to the selected eigenvalues.
+* If JOBZ = 'N', then Z is not referenced.
+*
+* IZ (global input) INTEGER
+* Z's global row index, which points to the beginning of the
+* submatrix which is to be operated on.
+* It should be set to 1 when operating on a full matrix.
+*
+* JZ (global input) INTEGER
+* Z's global column index, which points to the beginning of
+* the submatrix which is to be operated on.
+* It should be set to 1 when operating on a full matrix.
+*
+* DESCZ (global and local input) INTEGER array of dimension DLEN_.
+* The array descriptor for the distributed matrix Z.
+* The context DESCZ( CTXT_ ) must equal DESCA( CTXT_ ).
+* Also note the array alignment requirements specified below.
+*
+* WORK (local workspace/output) REAL array,
+* dimension (LWORK)
+* On return, WORK(1) contains the optimal amount of
+* workspace required for efficient execution.
+* if JOBZ='N' WORK(1) = optimal amount of workspace
+* required to compute the eigenvalues.
+* if JOBZ='V' WORK(1) = optimal amount of workspace
+* required to compute eigenvalues and eigenvectors.
+*
+* LWORK (local input) INTEGER
+* Size of WORK, must be at least 3.
+* See below for definitions of variables used to define LWORK.
+* If no eigenvectors are requested (JOBZ = 'N') then
+* LWORK >= 2 + 5*N + MAX( 12 * NN, NB * ( NP0 + 1 ) )
+* If eigenvectors are requested (JOBZ = 'V' ) then
+* the amount of workspace required is:
+* LWORK >= 2 + 5*N + MAX( 18*NN, NP0 * MQ0 + 2 * NB * NB ) +
+* (2 + ICEIL( NEIG, NPROW*NPCOL))*NN
+*
+* Variable definitions:
+* NEIG = number of eigenvectors requested
+* NB = DESCA( MB_ ) = DESCA( NB_ ) =
+* DESCZ( MB_ ) = DESCZ( NB_ )
+* NN = MAX( N, NB, 2 )
+* DESCA( RSRC_ ) = DESCA( NB_ ) = DESCZ( RSRC_ ) =
+* DESCZ( CSRC_ ) = 0
+* NP0 = NUMROC( NN, NB, 0, 0, NPROW )
+* MQ0 = NUMROC( MAX( NEIG, NB, 2 ), NB, 0, 0, NPCOL )
+* ICEIL( X, Y ) is a ScaLAPACK function returning
+* ceiling(X/Y)
+*
+* If LWORK = -1, then LWORK is global input and a workspace
+* query is assumed; the routine only calculates the size
+* required for optimal performance for all work arrays. Each of
+* these values is returned in the first entry of the
+* corresponding work arrays, and no error message is issued by
+* PXERBLA.
+* Note that in a workspace query, for performance the optimal
+* workspace LWOPT is returned rather than the minimum necessary
+* WORKSPACE LWMIN. For very small matrices, LWOPT >> LWMIN.
+*
+* IWORK (local workspace) INTEGER array
+* On return, IWORK(1) contains the amount of integer workspace
+* required.
+*
+* LIWORK (local input) INTEGER
+* size of IWORK
+*
+* Let NNP = MAX( N, NPROW*NPCOL + 1, 4 ). Then:
+* LIWORK >= 12*NNP + 2*N when the eigenvectors are desired
+* LIWORK >= 10*NNP + 2*N when only the eigenvalues have to be computed
+*
+* If LIWORK = -1, then LIWORK is global input and a workspace
+* query is assumed; the routine only calculates the minimum
+* and optimal size for all work arrays. Each of these
+* values is returned in the first entry of the corresponding
+* work array, and no error message is issued by PXERBLA.
+*
+* INFO (global output) INTEGER
+* = 0: successful exit
+* < 0: If the i-th argument is an array and the j-entry had
+* an illegal value, then INFO = -(i*100+j), if the i-th
+* argument is a scalar and had an illegal value, then
+* INFO = -i.
+*
+* Notes
+* =====
+*
+* Each global data object is described by an associated description
+* vector. This vector stores the information required to establish
+* the mapping between an object element and its corresponding process
+* and memory location.
+*
+* Let A be a generic term for any 2D block cyclicly distributed array.
+* Such a global array has an associated description vector DESCA,
+* or DESCZ for the descriptor of Z, etc.
+* The length of a ScaLAPACK descriptor is nine.
+* In the following comments, the character _ should be read as
+* "of the global array".
+*
+* NOTATION STORED IN EXPLANATION
+* --------------- -------------- --------------------------------------
+* DTYPE_A(global) DESCA( DTYPE_ )The descriptor type. In this case,
+* DTYPE_A = 1.
+* CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating
+* the BLACS process grid A is distribu-
+* ted over. The context itself is glo-
+* bal, but the handle (the integer
+* value) may vary.
+* M_A (global) DESCA( M_ ) The number of rows in the global
+* array A.
+* N_A (global) DESCA( N_ ) The number of columns in the global
+* array A.
+* MB_A (global) DESCA( MB_ ) The blocking factor used to distribute
+* the rows of the array.
+* NB_A (global) DESCA( NB_ ) The blocking factor used to distribute
+* the columns of the array.
+* RSRC_A (global) DESCA( RSRC_ ) The process row over which the first
+* row of the array A is distributed.
+* CSRC_A (global) DESCA( CSRC_ ) The process column over which the
+* first column of the array A is
+* distributed.
+* LLD_A (local) DESCA( LLD_ ) The leading dimension of the local
+* array. LLD_A >= MAX(1,LOCr(M_A)).
+*
+* Let K be the number of rows or columns of a distributed matrix,
+* and assume that its process grid has dimension p x q.
+* LOCr( K ) denotes the number of elements of K that a process
+* would receive if K were distributed over the p processes of its
+* process column.
+* Similarly, LOCc( K ) denotes the number of elements of K that a
+* process would receive if K were distributed over the q processes of
+* its process row.
+* The values of LOCr() and LOCc() may be determined via a call to the
+* ScaLAPACK tool function, NUMROC:
+* LOCr( M ) = NUMROC( M, MB_A, MYROW, RSRC_A, NPROW ),
+* LOCc( N ) = NUMROC( N, NB_A, MYCOL, CSRC_A, NPCOL ).
+* An upper bound for these quantities may be computed by:
+* LOCr( M ) <= ceil( ceil(M/MB_A)/NPROW )*MB_A
+* LOCc( N ) <= ceil( ceil(N/NB_A)/NPCOL )*NB_A
+*
+* PSSYEVR assumes IEEE 754 standard compliant arithmetic.
+*
+* Alignment requirements
+* ======================
+*
+* The distributed submatrices A(IA:*, JA:*) and Z(IZ:IZ+M-1,JZ:JZ+N-1)
+* must satisfy the following alignment properties:
+*
+* 1.Identical (quadratic) dimension:
+* DESCA(M_) = DESCZ(M_) = DESCA(N_) = DESCZ(N_)
+* 2.Quadratic conformal blocking:
+* DESCA(MB_) = DESCA(NB_) = DESCZ(MB_) = DESCZ(NB_)
+* DESCA(RSRC_) = DESCZ(RSRC_)
+* 3.MOD( IA-1, MB_A ) = MOD( IZ-1, MB_Z ) = 0
+* 4.IAROW = IZROW
+*
+*
+* .. Parameters ..
+ INTEGER CTXT_, M_, N_,
+ $ MB_, NB_, RSRC_, CSRC_
+ PARAMETER ( CTXT_ = 2, M_ = 3, N_ = 4, MB_ = 5, NB_ = 6,
+ $ RSRC_ = 7, CSRC_ = 8 )
+ REAL ZERO
+ PARAMETER ( ZERO = 0.0E0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL ALLEIG, COLBRT, DOBCST, FINISH, FIRST, INDEIG,
+ $ LOWER, LQUERY, VALEIG, VSTART, WANTZ
+ INTEGER ANB, DOL, DOU, DSTCOL, DSTROW, EIGCNT, FRSTCL,
+ $ I, IAROW, ICTXT, IIL, IINDERR, IINDWLC, IINFO,
+ $ IIU, IM, INDD, INDD2, INDE, INDE2, INDERR,
+ $ INDILU, INDRW, INDTAU, INDWLC, INDWORK, IPIL,
+ $ IPIU, IPROC, IZROW, LASTCL, LENGTHI, LENGTHI2,
+ $ LIWMIN, LLWORK, LWMIN, LWOPT, MAXCLS, MQ00,
+ $ MYCOL, MYIL, MYIU, MYPROC, MYROW, MZ, NB,
+ $ NDEPTH, NEEDIL, NEEDIU, NNP, NP00, NPCOL,
+ $ NPROCS, NPROW, NPS, NSPLIT, NSYTRD_LWOPT,
+ $ OFFSET, PARITY, RLENGTHI, RLENGTHI2, RSTARTI,
+ $ SIZE1, SIZE2, SQNPC, SRCCOL, SRCROW, STARTI,
+ $ ZOFFSET
+
+ REAL PIVMIN, SAFMIN, SCALE, VLL, VUU, WL,
+ $ WU
+*
+* .. Local Arrays ..
+ INTEGER IDUM1( 4 ), IDUM2( 4 )
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ INTEGER ICEIL, INDXG2P, NUMROC, PJLAENV
+ REAL PSLAMCH
+ EXTERNAL ICEIL, INDXG2P, LSAME, NUMROC, PJLAENV,
+ $ PSLAMCH
+* ..
+* .. External Subroutines ..
+ EXTERNAL BLACS_GRIDINFO, CHK1MAT, IGEBR2D, IGEBS2D,
+ $ IGERV2D, IGESD2D, IGSUM2D, PCHK1MAT, PCHK2MAT,
+ $ PSELGET, PSLAEVSWP, PSLARED1D, PSORMTR,
+ $ PSSYNTRD, PXERBLA, SCOPY, SGEBR2D, SGEBS2D,
+ $ SGERV2D, SGESD2D, SLARRC, SLASRT2,
+ $ SSTEGR2A, SSTEGR2B, SSTEGR2
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, REAL, ICHAR, INT, MAX, MIN, MOD, SQRT
+* ..
+* .. Executable Statements ..
+*
+
+
+ INFO = 0
+***********************************************************************
+*
+* Decode character arguments to find out what the code should do
+*
+***********************************************************************
+ WANTZ = LSAME( JOBZ, 'V' )
+ LOWER = LSAME( UPLO, 'L' )
+ ALLEIG = LSAME( RANGE, 'A' )
+ VALEIG = LSAME( RANGE, 'V' )
+ INDEIG = LSAME( RANGE, 'I' )
+ LQUERY = ( LWORK.EQ.-1 .OR. LIWORK.EQ.-1 )
+
+***********************************************************************
+*
+* GET MACHINE PARAMETERS
+*
+***********************************************************************
+ ICTXT = DESCA( CTXT_ )
+ SAFMIN = PSLAMCH( ICTXT, 'Safe minimum' )
+
+***********************************************************************
+*
+* Set up pointers into the WORK array
+*
+***********************************************************************
+ INDTAU = 1
+ INDD = INDTAU + N
+ INDE = INDD + N + 1
+ INDD2 = INDE + N + 1
+ INDE2 = INDD2 + N
+ INDWORK = INDE2 + N
+ LLWORK = LWORK - INDWORK + 1
+
+***********************************************************************
+*
+* BLACS PROCESSOR GRID SETUP
+*
+***********************************************************************
+ CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL )
+
+
+ NPROCS = NPROW * NPCOL
+ MYPROC = MYROW * NPCOL + MYCOL
+ IF( NPROW.EQ.-1 ) THEN
+ INFO = -( 800+CTXT_ )
+ ELSE IF( WANTZ ) THEN
+ IF( ICTXT.NE.DESCZ( CTXT_ ) ) THEN
+ INFO = -( 2100+CTXT_ )
+ END IF
+ END IF
+
+***********************************************************************
+*
+* COMPUTE REAL WORKSPACE
+*
+***********************************************************************
+ IF ( ALLEIG ) THEN
+ MZ = N
+ ELSE IF ( INDEIG ) THEN
+ MZ = IU - IL + 1
+ ELSE
+* Take upper bound for VALEIG case
+ MZ = N
+ END IF
+*
+ NB = DESCA( NB_ )
+ IF ( WANTZ ) THEN
+ NP00 = NUMROC( N, NB, 0, 0, NPROW )
+ MQ00 = NUMROC( MZ, NB, 0, 0, NPCOL )
+ INDRW = INDWORK + MAX(18*N, NP00*MQ00 + 2*NB*NB)
+ LWMIN = INDRW - 1 + (ICEIL(MZ, NPROCS) + 2)*N
+ ELSE
+ INDRW = INDWORK + 12*N
+ LWMIN = INDRW - 1
+ END IF
+* The code that validates the input requires 3 workspace entries
+ LWMIN = MAX(3, LWMIN)
+ LWOPT = LWMIN
+ ANB = PJLAENV( ICTXT, 3, 'PSSYTTRD', 'L', 0, 0, 0, 0 )
+ SQNPC = INT( SQRT( REAL( NPROCS ) ) )
+ NPS = MAX( NUMROC( N, 1, 0, 0, SQNPC ), 2*ANB )
+ NSYTRD_LWOPT = 2*( ANB+1 )*( 4*NPS+2 ) + ( NPS+4 )*NPS
+ LWOPT = MAX( LWOPT, 5*N+NSYTRD_LWOPT )
+*
+ SIZE1 = INDRW - INDWORK
+
+***********************************************************************
+*
+* COMPUTE INTEGER WORKSPACE
+*
+***********************************************************************
+ NNP = MAX( N, NPROCS+1, 4 )
+ IF ( WANTZ ) THEN
+ LIWMIN = 12*NNP + 2*N
+ ELSE
+ LIWMIN = 10*NNP + 2*N
+ END IF
+
+***********************************************************************
+*
+* Set up pointers into the IWORK array
+*
+***********************************************************************
+* Pointer to eigenpair distribution over processors
+ INDILU = LIWMIN - 2*NPROCS + 1
+ SIZE2 = INDILU - 2*N
+
+
+***********************************************************************
+*
+* Test the input arguments.
+*
+***********************************************************************
+ IF( INFO.EQ.0 ) THEN
+ CALL CHK1MAT( N, 4, N, 4, IA, JA, DESCA, 8, INFO )
+ IF( WANTZ )
+ $ CALL CHK1MAT( N, 4, N, 4, IZ, JZ, DESCZ, 21, INFO )
+*
+ IF( INFO.EQ.0 ) THEN
+ 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( MOD( IA-1, DESCA( MB_ ) ).NE.0 ) THEN
+ INFO = -6
+ ELSE IF( VALEIG .AND. N.GT.0 .AND. VU.LE.VL ) THEN
+ INFO = -10
+ ELSE IF( INDEIG .AND. ( IL.LT.1 .OR. IL.GT.MAX( 1, N ) ) )
+ $ THEN
+ INFO = -11
+ ELSE IF( INDEIG .AND. ( IU.LT.MIN( N, IL ) .OR. IU.GT.N ) )
+ $ THEN
+ INFO = -12
+ ELSE IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN
+ INFO = -21
+ ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN
+ INFO = -23
+ ELSE IF( DESCA( MB_ ).NE.DESCA( NB_ ) ) THEN
+ INFO = -( 800+NB_ )
+ END IF
+ IF( WANTZ ) THEN
+ IAROW = INDXG2P( 1, DESCA( NB_ ), MYROW,
+ $ DESCA( RSRC_ ), NPROW )
+ IZROW = INDXG2P( 1, DESCA( NB_ ), MYROW,
+ $ DESCZ( RSRC_ ), NPROW )
+ IF( IAROW.NE.IZROW ) THEN
+ INFO = -19
+ ELSE IF( MOD( IA-1, DESCA( MB_ ) ).NE.
+ $ MOD( IZ-1, DESCZ( MB_ ) ) ) THEN
+ INFO = -19
+ ELSE IF( DESCA( M_ ).NE.DESCZ( M_ ) ) THEN
+ INFO = -( 2100+M_ )
+ ELSE IF( DESCA( N_ ).NE.DESCZ( N_ ) ) THEN
+ INFO = -( 2100+N_ )
+ ELSE IF( DESCA( MB_ ).NE.DESCZ( MB_ ) ) THEN
+ INFO = -( 2100+MB_ )
+ ELSE IF( DESCA( NB_ ).NE.DESCZ( NB_ ) ) THEN
+ INFO = -( 2100+NB_ )
+ ELSE IF( DESCA( RSRC_ ).NE.DESCZ( RSRC_ ) ) THEN
+ INFO = -( 2100+RSRC_ )
+ ELSE IF( DESCA( CSRC_ ).NE.DESCZ( CSRC_ ) ) THEN
+ INFO = -( 2100+CSRC_ )
+ ELSE IF( ICTXT.NE.DESCZ( CTXT_ ) ) THEN
+ INFO = -( 2100+CTXT_ )
+ END IF
+ END IF
+ END IF
+ IDUM2( 1 ) = 1
+ IF( LOWER ) THEN
+ IDUM1( 2 ) = ICHAR( 'L' )
+ ELSE
+ IDUM1( 2 ) = ICHAR( 'U' )
+ END IF
+ IDUM2( 2 ) = 2
+ IF( ALLEIG ) THEN
+ IDUM1( 3 ) = ICHAR( 'A' )
+ ELSE IF( INDEIG ) THEN
+ IDUM1( 3 ) = ICHAR( 'I' )
+ ELSE
+ IDUM1( 3 ) = ICHAR( 'V' )
+ END IF
+ IDUM2( 3 ) = 3
+ IF( LQUERY ) THEN
+ IDUM1( 4 ) = -1
+ ELSE
+ IDUM1( 4 ) = 1
+ END IF
+ IDUM2( 4 ) = 4
+ IF( WANTZ ) THEN
+ IDUM1( 1 ) = ICHAR( 'V' )
+ CALL PCHK2MAT( N, 4, N, 4, IA, JA, DESCA, 8, N, 4, N, 4, IZ,
+ $ JZ, DESCZ, 21, 4, IDUM1, IDUM2, INFO )
+ ELSE
+ IDUM1( 1 ) = ICHAR( 'N' )
+ CALL PCHK1MAT( N, 4, N, 4, IA, JA, DESCA, 8, 4, IDUM1,
+ $ IDUM2, INFO )
+ END IF
+ WORK( 1 ) = REAL( LWOPT )
+ IWORK( 1 ) = LIWMIN
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL PXERBLA( ICTXT, 'PSSYEVR', -INFO )
+ RETURN
+ ELSE IF( LQUERY ) THEN
+ RETURN
+ END IF
+
+***********************************************************************
+*
+* Quick return if possible
+*
+***********************************************************************
+ IF( N.EQ.0 ) THEN
+ IF( WANTZ ) THEN
+ NZ = 0
+ END IF
+ M = 0
+ WORK( 1 ) = REAL( LWOPT )
+ IWORK( 1 ) = LIWMIN
+ RETURN
+ END IF
+
+ IF( VALEIG ) THEN
+ VLL = VL
+ VUU = VU
+ ELSE
+ VLL = ZERO
+ VUU = ZERO
+ END IF
+*
+* No scaling done here, leave this to MRRR kernel.
+* Scale tridiagonal rather than full matrix.
+*
+***********************************************************************
+*
+* REDUCE SYMMETRIC MATRIX TO TRIDIAGONAL FORM.
+*
+***********************************************************************
+
+
+ CALL PSSYNTRD( UPLO, N, A, IA, JA, DESCA, WORK( INDD ),
+ $ WORK( INDE ), WORK( INDTAU ), WORK( INDWORK ),
+ $ LLWORK, IINFO )
+
+
+ IF (IINFO .NE. 0) THEN
+ CALL PXERBLA( ICTXT, 'PSSYNTRD', -IINFO )
+ RETURN
+ END IF
+
+***********************************************************************
+*
+* DISTRIBUTE TRIDIAGONAL TO ALL PROCESSORS
+*
+***********************************************************************
+ OFFSET = 0
+ IF( IA.EQ.1 .AND. JA.EQ.1 .AND.
+ $ DESCA( RSRC_ ).EQ.0 .AND. DESCA( CSRC_ ).EQ.0 )
+ $ THEN
+ CALL PSLARED1D( N, IA, JA, DESCA, WORK( INDD ), WORK( INDD2 ),
+ $ WORK( INDWORK ), LLWORK )
+*
+ CALL PSLARED1D( N, IA, JA, DESCA, WORK( INDE ), WORK( INDE2 ),
+ $ WORK( INDWORK ), LLWORK )
+ IF( .NOT.LOWER )
+ $ OFFSET = 1
+ ELSE
+ DO 10 I = 1, N
+ CALL PSELGET( 'A', ' ', WORK( INDD2+I-1 ), A, I+IA-1,
+ $ I+JA-1, DESCA )
+ 10 CONTINUE
+ IF( LSAME( UPLO, 'U' ) ) THEN
+ DO 20 I = 1, N - 1
+ CALL PSELGET( 'A', ' ', WORK( INDE2+I-1 ), A, I+IA-1,
+ $ I+JA, DESCA )
+ 20 CONTINUE
+ ELSE
+ DO 30 I = 1, N - 1
+ CALL PSELGET( 'A', ' ', WORK( INDE2+I-1 ), A, I+IA,
+ $ I+JA-1, DESCA )
+ 30 CONTINUE
+ END IF
+ END IF
+
+
+
+
+***********************************************************************
+*
+* SET IIL, IIU
+*
+***********************************************************************
+ IF ( ALLEIG ) THEN
+ IIL = 1
+ IIU = N
+ ELSE IF ( INDEIG ) THEN
+ IIL = IL
+ IIU = IU
+ ELSE IF ( VALEIG ) THEN
+ CALL SLARRC('T', N, VLL, VUU, WORK( INDD2 ),
+ $ WORK( INDE2 + OFFSET ), SAFMIN, EIGCNT, IIL, IIU, INFO)
+* Refine upper bound N that was taken
+ MZ = EIGCNT
+ IIL = IIL + 1
+ ENDIF
+
+ IF(MZ.EQ.0) THEN
+ M = 0
+ IF( WANTZ ) THEN
+ NZ = 0
+ END IF
+ WORK( 1 ) = REAL( LWOPT )
+ IWORK( 1 ) = LIWMIN
+ RETURN
+ END IF
+
+ MYIL = 0
+ MYIU = 0
+ M = 0
+ IM = 0
+
+***********************************************************************
+*
+* COMPUTE WORK ASSIGNMENTS
+*
+***********************************************************************
+*
+* Each processor computes the work assignments for all processors
+*
+ CALL PMPIM2( IIL, IIU, NPROCS,
+ $ IWORK(INDILU), IWORK(INDILU+NPROCS) )
+*
+* Find local work assignment
+*
+ MYIL = IWORK(INDILU+MYPROC)
+ MYIU = IWORK(INDILU+NPROCS+MYPROC)
+
+
+ ZOFFSET = MAX(0, MYIL - IIL - 1)
+ FIRST = ( MYIL .EQ. IIL )
+
+
+***********************************************************************
+*
+* CALLS TO MRRR KERNEL
+*
+***********************************************************************
+ IF(.NOT.WANTZ) THEN
+*
+* Compute eigenvalues only.
+*
+ IINFO = 0
+ IF ( MYIL.GT.0 ) THEN
+ DOL = 1
+ DOU = MYIU - MYIL + 1
+ CALL SSTEGR2( JOBZ, 'I', N, WORK( INDD2 ),
+ $ WORK( INDE2+OFFSET ), VLL, VUU, MYIL, MYIU,
+ $ IM, W( 1 ), WORK( INDRW ), N,
+ $ MYIU - MYIL + 1,
+ $ IWORK( 1 ), WORK( INDWORK ), SIZE1,
+ $ IWORK( 2*N+1 ), SIZE2,
+ $ DOL, DOU, ZOFFSET, IINFO )
+* SSTEGR2 zeroes out the entire W array, so we can't just give
+* it the part of W we need. So here we copy the W entries into
+* their correct location
+ DO 49 I = 1, IM
+ W( MYIL-IIL+I ) = W( I )
+ 49 CONTINUE
+* W( MYIL ) is at W( MYIL - IIL + 1 )
+* W( X ) is at W(X - IIL + 1 )
+ END IF
+ IF (IINFO .NE. 0) THEN
+ CALL PXERBLA( ICTXT, 'SSTEGR2', -IINFO )
+ RETURN
+ END IF
+ ELSEIF ( WANTZ .AND. NPROCS.EQ.1 ) THEN
+*
+* Compute eigenvalues and -vectors, but only on one processor
+*
+ IINFO = 0
+ IF ( MYIL.GT.0 ) THEN
+ DOL = MYIL - IIL + 1
+ DOU = MYIU - IIL + 1
+ CALL SSTEGR2( JOBZ, 'I', N, WORK( INDD2 ),
+ $ WORK( INDE2+OFFSET ), VLL, VUU, IIL, IIU,
+ $ IM, W( 1 ), WORK( INDRW ), N,
+ $ N,
+ $ IWORK( 1 ), WORK( INDWORK ), SIZE1,
+ $ IWORK( 2*N+1 ), SIZE2, DOL, DOU,
+ $ ZOFFSET, IINFO )
+ ENDIF
+ IF (IINFO .NE. 0) THEN
+ CALL PXERBLA( ICTXT, 'SSTEGR2', -IINFO )
+ RETURN
+ END IF
+ ELSEIF ( WANTZ ) THEN
+*
+* Compute representations in parallel.
+* Share eigenvalue computation for root between all processors
+* Then compute the eigenvectors.
+*
+ IINFO = 0
+* Part 1. compute root representations and root eigenvalues
+ IF ( MYIL.GT.0 ) THEN
+ DOL = MYIL - IIL + 1
+ DOU = MYIU - IIL + 1
+ CALL SSTEGR2A( JOBZ, 'I', N, WORK( INDD2 ),
+ $ WORK( INDE2+OFFSET ), VLL, VUU, IIL, IIU,
+ $ IM, W( 1 ), WORK( INDRW ), N,
+ $ N, WORK( INDWORK ), SIZE1,
+ $ IWORK( 2*N+1 ), SIZE2, DOL,
+ $ DOU, NEEDIL, NEEDIU,
+ $ INDERR, NSPLIT, PIVMIN, SCALE, WL, WU,
+ $ IINFO )
+ ENDIF
+ IF (IINFO .NE. 0) THEN
+ CALL PXERBLA( ICTXT, 'SSTEGR2A', -IINFO )
+ RETURN
+ END IF
+*
+* The second part of parallel MRRR, the representation tree
+* construction begins. Upon successful completion, the
+* eigenvectors have been computed. This is indicated by
+* the flag FINISH.
+*
+ VSTART = .TRUE.
+ FINISH = (MYIL.LE.0)
+C Part 2. Share eigenvalues and uncertainties between all processors
+ IINDERR = INDWORK + INDERR - 1
+
+*
+*
+* There are currently two ways to communicate eigenvalue information
+* using the BLACS.
+* 1.) BROADCAST
+* 2.) POINT2POINT between collaborators (those processors working
+* jointly on a cluster.
+* For efficiency, BROADCAST has been disabled.
+* At a later stage, other more efficient communication algorithms
+* might be implemented, e. g. group or tree-based communication.
+*
+ DOBCST = .FALSE.
+ IF(DOBCST) THEN
+* First gather everything on the first processor.
+* Then use BROADCAST-based communication
+ DO 45 I = 2, NPROCS
+ IF (MYPROC .EQ. (I - 1)) THEN
+ DSTROW = 0
+ DSTCOL = 0
+ STARTI = DOL
+ IWORK(1) = STARTI
+ IF(MYIL.GT.0) THEN
+ LENGTHI = MYIU - MYIL + 1
+ ELSE
+ LENGTHI = 0
+ ENDIF
+ IWORK(2) = LENGTHI
+ CALL IGESD2D( ICTXT, 2, 1, IWORK, 2,
+ $ DSTROW, DSTCOL )
+ IF (( STARTI.GE.1 ) .AND. ( LENGTHI.GE.1 )) THEN
+ LENGTHI2 = 2*LENGTHI
+* Copy eigenvalues into communication buffer
+ CALL SCOPY(LENGTHI,W( STARTI ),1,
+ $ WORK( INDD ), 1)
+* Copy uncertainties into communication buffer
+ CALL SCOPY(LENGTHI,WORK( IINDERR+STARTI-1 ),1,
+ $ WORK( INDD+LENGTHI ), 1)
+* send buffer
+ CALL SGESD2D( ICTXT, LENGTHI2,
+ $ 1, WORK( INDD ), LENGTHI2,
+ $ DSTROW, DSTCOL )
+ END IF
+ ELSE IF (MYPROC .EQ. 0) THEN
+ SRCROW = (I-1) / NPCOL
+ SRCCOL = MOD(I-1, NPCOL)
+ CALL IGERV2D( ICTXT, 2, 1, IWORK, 2,
+ $ SRCROW, SRCCOL )
+ STARTI = IWORK(1)
+ LENGTHI = IWORK(2)
+ IF (( STARTI.GE.1 ) .AND. ( LENGTHI.GE.1 )) THEN
+ LENGTHI2 = 2*LENGTHI
+* receive buffer
+ CALL SGERV2D( ICTXT, LENGTHI2, 1,
+ $ WORK(INDD), LENGTHI2, SRCROW, SRCCOL )
+* copy eigenvalues from communication buffer
+ CALL SCOPY( LENGTHI, WORK(INDD), 1,
+ $ W( STARTI ), 1)
+* copy uncertainties (errors) from communication buffer
+ CALL SCOPY(LENGTHI,WORK(INDD+LENGTHI),1,
+ $ WORK( IINDERR+STARTI-1 ), 1)
+ END IF
+ END IF
+ 45 CONTINUE
+ LENGTHI = IIU - IIL + 1
+ LENGTHI2 = LENGTHI * 2
+ IF (MYPROC .EQ. 0) THEN
+* Broadcast eigenvalues and errors to all processors
+ CALL SCOPY(LENGTHI,W ,1, WORK( INDD ), 1)
+ CALL SCOPY(LENGTHI,WORK( IINDERR ),1,
+ $ WORK( INDD+LENGTHI ), 1)
+ CALL SGEBS2D( ICTXT, 'A', ' ', LENGTHI2, 1,
+ $ WORK(INDD), LENGTHI2 )
+ ELSE
+ SRCROW = 0
+ SRCCOL = 0
+ CALL SGEBR2D( ICTXT, 'A', ' ', LENGTHI2, 1,
+ $ WORK(INDD), LENGTHI2, SRCROW, SRCCOL )
+ CALL SCOPY( LENGTHI, WORK(INDD), 1, W, 1)
+ CALL SCOPY(LENGTHI,WORK(INDD+LENGTHI),1,
+ $ WORK( IINDERR ), 1)
+ END IF
+ ELSE
+*
+* Enable point2point communication between collaborators
+*
+* Find collaborators of MYPROC
+ IF( (NPROCS.GT.1).AND.(MYIL.GT.0) ) THEN
+ CALL PMPCOL( MYPROC, NPROCS, IIL, NEEDIL, NEEDIU,
+ $ IWORK(INDILU), IWORK(INDILU+NPROCS),
+ $ COLBRT, FRSTCL, LASTCL )
+ ELSE
+ COLBRT = .FALSE.
+ ENDIF
+
+ IF(COLBRT) THEN
+* If the processor collaborates with others,
+* communicate information.
+ DO 47 IPROC = FRSTCL, LASTCL
+ IF (MYPROC .EQ. IPROC) THEN
+ STARTI = DOL
+ IWORK(1) = STARTI
+ LENGTHI = MYIU - MYIL + 1
+ IWORK(2) = LENGTHI
+
+ IF ((STARTI.GE.1) .AND. (LENGTHI.GE.1)) THEN
+* Copy eigenvalues into communication buffer
+ CALL SCOPY(LENGTHI,W( STARTI ),1,
+ $ WORK(INDD), 1)
+* Copy uncertainties into communication buffer
+ CALL SCOPY(LENGTHI,
+ $ WORK( IINDERR+STARTI-1 ),1,
+ $ WORK(INDD+LENGTHI), 1)
+ ENDIF
+
+ DO 46 I = FRSTCL, LASTCL
+ IF(I.EQ.MYPROC) GOTO 46
+ DSTROW = I/ NPCOL
+ DSTCOL = MOD(I, NPCOL)
+ CALL IGESD2D( ICTXT, 2, 1, IWORK, 2,
+ $ DSTROW, DSTCOL )
+ IF ((STARTI.GE.1) .AND. (LENGTHI.GE.1)) THEN
+ LENGTHI2 = 2*LENGTHI
+* send buffer
+ CALL SGESD2D( ICTXT, LENGTHI2,
+ $ 1, WORK(INDD), LENGTHI2,
+ $ DSTROW, DSTCOL )
+ END IF
+ 46 CONTINUE
+ ELSE
+ SRCROW = IPROC / NPCOL
+ SRCCOL = MOD(IPROC, NPCOL)
+ CALL IGERV2D( ICTXT, 2, 1, IWORK, 2,
+ $ SRCROW, SRCCOL )
+ RSTARTI = IWORK(1)
+ RLENGTHI = IWORK(2)
+ IF ((RSTARTI.GE.1 ) .AND. (RLENGTHI.GE.1 )) THEN
+ RLENGTHI2 = 2*RLENGTHI
+ CALL SGERV2D( ICTXT, RLENGTHI2, 1,
+ $ WORK(INDE), RLENGTHI2,
+ $ SRCROW, SRCCOL )
+* copy eigenvalues from communication buffer
+ CALL SCOPY( RLENGTHI, WORK(INDE), 1,
+ $ W( RSTARTI ), 1)
+* copy uncertainties (errors) from communication buffer
+ CALL SCOPY(RLENGTHI,WORK(INDE+RLENGTHI),1,
+ $ WORK( IINDERR+RSTARTI-1 ), 1)
+ END IF
+ END IF
+ 47 CONTINUE
+ ENDIF
+ ENDIF
+
+*
+* Part 3. Compute representation tree and eigenvectors.
+* What follows is a loop in which the tree
+* is constructed in parallel from top to bottom,
+* on level at a time, until all eigenvectors
+* have been computed.
+*
+ 100 CONTINUE
+ IF ( MYIL.GT.0 ) THEN
+ CALL SSTEGR2B( JOBZ, N, WORK( INDD2 ),
+ $ WORK( INDE2+OFFSET ),
+ $ IM, W( 1 ), WORK( INDRW ), N, N,
+ $ IWORK( 1 ), WORK( INDWORK ), SIZE1,
+ $ IWORK( 2*N+1 ), SIZE2, DOL,
+ $ DOU, NEEDIL, NEEDIU, INDWLC,
+ $ PIVMIN, SCALE, WL, WU,
+ $ VSTART, FINISH,
+ $ MAXCLS, NDEPTH, PARITY, ZOFFSET, IINFO )
+ IINDWLC = INDWORK + INDWLC - 1
+ IF(.NOT.FINISH) THEN
+ IF((NEEDIL.LT.DOL).OR.(NEEDIU.GT.DOU)) THEN
+ CALL PMPCOL( MYPROC, NPROCS, IIL, NEEDIL, NEEDIU,
+ $ IWORK(INDILU), IWORK(INDILU+NPROCS),
+ $ COLBRT, FRSTCL, LASTCL )
+ ELSE
+ COLBRT = .FALSE.
+ FRSTCL = MYPROC
+ LASTCL = MYPROC
+ ENDIF
+*
+* Check if this processor collaborates, i.e.
+* communication is needed.
+*
+ IF(COLBRT) THEN
+ DO 147 IPROC = FRSTCL, LASTCL
+ IF (MYPROC .EQ. IPROC) THEN
+ STARTI = DOL
+ IWORK(1) = STARTI
+ IF(MYIL.GT.0) THEN
+ LENGTHI = MYIU - MYIL + 1
+ ELSE
+ LENGTHI = 0
+ ENDIF
+ IWORK(2) = LENGTHI
+ IF ((STARTI.GE.1).AND.(LENGTHI.GE.1)) THEN
+* Copy eigenvalues into communication buffer
+ CALL SCOPY(LENGTHI,
+ $ WORK( IINDWLC+STARTI-1 ),1,
+ $ WORK(INDD), 1)
+* Copy uncertainties into communication buffer
+ CALL SCOPY(LENGTHI,
+ $ WORK( IINDERR+STARTI-1 ),1,
+ $ WORK(INDD+LENGTHI), 1)
+ ENDIF
+
+ DO 146 I = FRSTCL, LASTCL
+ IF(I.EQ.MYPROC) GOTO 146
+ DSTROW = I/ NPCOL
+ DSTCOL = MOD(I, NPCOL)
+ CALL IGESD2D( ICTXT, 2, 1, IWORK, 2,
+ $ DSTROW, DSTCOL )
+ IF ((STARTI.GE.1).AND.(LENGTHI.GE.1)) THEN
+ LENGTHI2 = 2*LENGTHI
+* send buffer
+ CALL SGESD2D( ICTXT, LENGTHI2,
+ $ 1, WORK(INDD), LENGTHI2,
+ $ DSTROW, DSTCOL )
+ END IF
+ 146 CONTINUE
+ ELSE
+ SRCROW = IPROC / NPCOL
+ SRCCOL = MOD(IPROC, NPCOL)
+ CALL IGERV2D( ICTXT, 2, 1, IWORK, 2,
+ $ SRCROW, SRCCOL )
+ RSTARTI = IWORK(1)
+ RLENGTHI = IWORK(2)
+ IF ((RSTARTI.GE.1).AND.(RLENGTHI.GE.1)) THEN
+ RLENGTHI2 = 2*RLENGTHI
+ CALL SGERV2D( ICTXT,RLENGTHI2, 1,
+ $ WORK(INDE),RLENGTHI2,
+ $ SRCROW, SRCCOL )
+* copy eigenvalues from communication buffer
+ CALL SCOPY(RLENGTHI, WORK(INDE), 1,
+ $ WORK( IINDWLC+RSTARTI-1 ), 1)
+* copy uncertainties (errors) from communication buffer
+ CALL SCOPY(RLENGTHI,WORK(INDE+RLENGTHI),1,
+ $ WORK( IINDERR+RSTARTI-1 ), 1)
+ END IF
+ END IF
+ 147 CONTINUE
+ ENDIF
+ GOTO 100
+ ENDIF
+ ENDIF
+ IF (IINFO .NE. 0) THEN
+ CALL PXERBLA( ICTXT, 'SSTEGR2B', -IINFO )
+ RETURN
+ END IF
+*
+ ENDIF
+
+*
+***********************************************************************
+*
+* MAIN PART ENDS HERE
+*
+***********************************************************************
+*
+***********************************************************************
+*
+* ALLGATHER: EACH PROCESSOR SENDS ITS EIGENVALUES TO THE FIRST ONE,
+* THEN THE FIRST PROCESSOR BROADCASTS ALL EIGENVALUES
+*
+***********************************************************************
+*
+ DO 50 I = 2, NPROCS
+ IF (MYPROC .EQ. (I - 1)) THEN
+ DSTROW = 0
+ DSTCOL = 0
+ STARTI = MYIL - IIL + 1
+ IWORK(1) = STARTI
+ IF(MYIL.GT.0) THEN
+ LENGTHI = MYIU - MYIL + 1
+ ELSE
+ LENGTHI = 0
+ ENDIF
+ IWORK(2) = LENGTHI
+ CALL IGESD2D( ICTXT, 2, 1, IWORK, 2,
+ $ DSTROW, DSTCOL )
+ IF ((STARTI.GE.1).AND.(LENGTHI.GE.1)) THEN
+ CALL SGESD2D( ICTXT, LENGTHI,
+ $ 1, W( STARTI ), LENGTHI,
+ $ DSTROW, DSTCOL )
+ ENDIF
+ ELSE IF (MYPROC .EQ. 0) THEN
+ SRCROW = (I-1) / NPCOL
+ SRCCOL = MOD(I-1, NPCOL)
+ CALL IGERV2D( ICTXT, 2, 1, IWORK, 2,
+ $ SRCROW, SRCCOL )
+ STARTI = IWORK(1)
+ LENGTHI = IWORK(2)
+ IF ((STARTI.GE.1).AND.(LENGTHI.GE.1)) THEN
+ CALL SGERV2D( ICTXT, LENGTHI, 1,
+ $ W( STARTI ), LENGTHI, SRCROW, SRCCOL )
+ ENDIF
+ ENDIF
+ 50 CONTINUE
+
+* Accumulate M from all processors
+ M = IM
+ CALL IGSUM2D( ICTXT, 'A', ' ', 1, 1, M, 1, -1, -1 )
+
+* Broadcast eigenvalues to all processors
+ IF (MYPROC .EQ. 0) THEN
+* Send eigenvalues
+ CALL SGEBS2D( ICTXT, 'A', ' ', M, 1, W, M )
+ ELSE
+ SRCROW = 0
+ SRCCOL = 0
+ CALL SGEBR2D( ICTXT, 'A', ' ', M, 1,
+ $ W, M, SRCROW, SRCCOL )
+ END IF
+*
+* Sort the eigenvalues and keep permutation in IWORK to
+* sort the eigenvectors accordingly
+*
+ DO 160 I = 1, M
+ IWORK( NPROCS+1+I ) = I
+ 160 CONTINUE
+ CALL SLASRT2( 'I', M, W, IWORK( NPROCS+2 ), IINFO )
+ IF (IINFO.NE.0) THEN
+ CALL PXERBLA( ICTXT, 'SLASRT2', -IINFO )
+ RETURN
+ END IF
+
+***********************************************************************
+*
+* TRANSFORM Z FROM 1D WORKSPACE INTO 2D BLOCKCYCLIC STORAGE
+*
+***********************************************************************
+ IF ( WANTZ ) THEN
+ DO 170 I = 1, M
+ IWORK( M+NPROCS+1+IWORK( NPROCS+1+I ) ) = I
+ 170 CONTINUE
+* Store NVS in IWORK(1:NPROCS+1) for PSLAEVSWP
+ IWORK( 1 ) = 0
+ DO 180 I = 1, NPROCS
+* Find IL and IU for processor i-1
+* Has already been computed by PMPIM2 and stored
+ IPIL = IWORK(INDILU+I-1)
+ IPIU = IWORK(INDILU+NPROCS+I-1)
+ IF (IPIL .EQ. 0) THEN
+ IWORK( I + 1 ) = IWORK( I )
+ ELSE
+ IWORK( I + 1 ) = IWORK( I ) + IPIU - IPIL + 1
+ ENDIF
+ 180 CONTINUE
+
+ IF ( FIRST ) THEN
+ CALL PSLAEVSWP(N, WORK( INDRW ), N, Z, IZ, JZ,
+ $ DESCZ, IWORK( 1 ), IWORK( NPROCS+M+2 ), WORK( INDWORK ),
+ $ INDRW - INDWORK )
+ ELSE
+ CALL PSLAEVSWP(N, WORK( INDRW + N ), N, Z, IZ, JZ,
+ $ DESCZ, IWORK( 1 ), IWORK( NPROCS+M+2 ), WORK( INDWORK ),
+ $ INDRW - INDWORK )
+ END IF
+*
+ NZ = M
+*
+
+***********************************************************************
+*
+* Compute eigenvectors of A from eigenvectors of T
+*
+***********************************************************************
+ IF( NZ.GT.0 ) THEN
+ CALL PSORMTR( 'L', UPLO, 'N', N, NZ, A, IA, JA, DESCA,
+ $ WORK( INDTAU ), Z, IZ, JZ, DESCZ,
+ $ WORK( INDWORK ), SIZE1, IINFO )
+ END IF
+ IF (IINFO.NE.0) THEN
+ CALL PXERBLA( ICTXT, 'PSORMTR', -IINFO )
+ RETURN
+ END IF
+*
+
+ END IF
+*
+ WORK( 1 ) = REAL( LWOPT )
+ IWORK( 1 ) = LIWMIN
+
+ RETURN
+*
+* End of PSSYEVR
+*
+ END
diff --git a/SRC/pssyevx.f b/SRC/pssyevx.f
index 1e56d83..4e99fae 100644
--- a/SRC/pssyevx.f
+++ b/SRC/pssyevx.f
@@ -595,6 +595,9 @@
RSRC_Z = DESCZ( RSRC_ )
IROFFZ = MOD( IZ-1, MB_A )
IZROW = INDXG2P( 1, NB_A, MYROW, RSRC_Z, NPROW )
+ ELSE
+ IROFFZ = 0
+ IZROW = 0
END IF
*
IF( ( .NOT.WANTZ ) .OR. ( VALEIG .AND. ( .NOT.LQUERY ) ) )
diff --git a/SRC/pssyttrd.f b/SRC/pssyttrd.f
index b214979..bd214ca 100644
--- a/SRC/pssyttrd.f
+++ b/SRC/pssyttrd.f
@@ -1,10 +1,9 @@
SUBROUTINE PSSYTTRD( UPLO, N, A, IA, JA, DESCA, D, E, TAU, WORK,
$ LWORK, INFO )
*
-* -- ScaLAPACK routine (version 1.7) --
-* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
-* and University of California, Berkeley.
-* October 15, 1999
+* -- ScaLAPACK routine (version 2.0.2) --
+* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver
+* May 1 2012
*
* .. Scalar Arguments ..
CHARACTER UPLO
@@ -441,7 +440,7 @@
* .. External Subroutines ..
EXTERNAL BLACS_GRIDINFO, CHK1MAT, PCHK1MAT, PSTREECOMB,
$ PXERBLA, SCOMBNRM2, SGEBR2D, SGEBS2D, SGEMM,
- $ SGEMV, SGERV2D, SGESD2D, SGSUM2D, SLACPY,
+ $ SGEMV, SGERV2D, SGESD2D, SGSUM2D, SLAMOV,
$ SSCAL, STRMVT
* ..
* .. External Functions ..
@@ -1127,10 +1126,10 @@
IF( INTERLEAVE ) THEN
LDZG = LDV / 2
ELSE
- CALL SLACPY( 'A', LTNM1, ANB, WORK( INHT+LIJP1-1 ),
+ CALL SLAMOV( 'A', LTNM1, ANB, WORK( INHT+LIJP1-1 ),
$ LDV, WORK( INVT+LIJP1-1+ANB*LDV ), LDV )
*
- CALL SLACPY( 'A', LTNM1, ANB, WORK( INV+LTLIP1-1 ),
+ CALL SLAMOV( 'A', LTNM1, ANB, WORK( INV+LTLIP1-1 ),
$ LDV, WORK( INH+LTLIP1-1+ANB*LDV ), LDV )
LDZG = LDV
END IF
diff --git a/SRC/pstrord.f b/SRC/pstrord.f
new file mode 100644
index 0000000..3562242
--- /dev/null
+++ b/SRC/pstrord.f
@@ -0,0 +1,3454 @@
+ SUBROUTINE PSTRORD( COMPQ, SELECT, PARA, N, T, IT, JT,
+ $ DESCT, Q, IQ, JQ, DESCQ, WR, WI, M, WORK, LWORK,
+ $ IWORK, LIWORK, INFO )
+*
+* Contribution from the Department of Computing Science and HPC2N,
+* Umea University, Sweden
+*
+* -- ScaLAPACK computational routine (version 2.0.2) --
+* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver
+* May 1 2012
+*
+ IMPLICIT NONE
+*
+* .. Scalar Arguments ..
+ CHARACTER COMPQ
+ INTEGER INFO, LIWORK, LWORK, M, N,
+ $ IT, JT, IQ, JQ
+* ..
+* .. Array Arguments ..
+ INTEGER SELECT( * )
+ INTEGER PARA( 6 ), DESCT( * ), DESCQ( * ), IWORK( * )
+ REAL Q( * ), T( * ), WI( * ), WORK( * ), WR( * )
+* ..
+*
+* Purpose
+* =======
+*
+* PSTRORD 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.
+*
+* T must be in Schur form (as returned by PSLAHQR), that is, block
+* upper triangular with 1-by-1 and 2-by-2 diagonal blocks.
+*
+* This subroutine uses a delay and accumulate procedure for performing
+* the off-diagonal updates (see references for details).
+*
+* Notes
+* =====
+*
+* Each global data object is described by an associated description
+* vector. This vector stores the information required to establish
+* the mapping between an object element and its corresponding process
+* and memory location.
+*
+* Let A be a generic term for any 2D block cyclicly distributed array.
+* Such a global array has an associated description vector DESCA.
+* In the following comments, the character _ should be read as
+* "of the global array".
+*
+* NOTATION STORED IN EXPLANATION
+* --------------- -------------- --------------------------------------
+* DTYPE_A(global) DESCA( DTYPE_ )The descriptor type. In this case,
+* DTYPE_A = 1.
+* CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating
+* the BLACS process grid A is distribu-
+* ted over. The context itself is glo-
+* bal, but the handle (the integer
+* value) may vary.
+* M_A (global) DESCA( M_ ) The number of rows in the global
+* array A.
+* N_A (global) DESCA( N_ ) The number of columns in the global
+* array A.
+* MB_A (global) DESCA( MB_ ) The blocking factor used to distribute
+* the rows of the array.
+* NB_A (global) DESCA( NB_ ) The blocking factor used to distribute
+* the columns of the array.
+* RSRC_A (global) DESCA( RSRC_ ) The process row over which the first
+* row of the array A is distributed.
+* CSRC_A (global) DESCA( CSRC_ ) The process column over which the
+* first column of the array A is
+* distributed.
+* LLD_A (local) DESCA( LLD_ ) The leading dimension of the local
+* array. LLD_A >= MAX(1,LOCr(M_A)).
+*
+* Let K be the number of rows or columns of a distributed matrix,
+* and assume that its process grid has dimension p x q.
+* LOCr( K ) denotes the number of elements of K that a process
+* would receive if K were distributed over the p processes of its
+* process column.
+* Similarly, LOCc( K ) denotes the number of elements of K that a
+* process would receive if K were distributed over the q processes of
+* its process row.
+* The values of LOCr() and LOCc() may be determined via a call to the
+* ScaLAPACK tool function, NUMROC:
+* LOCr( M ) = NUMROC( M, MB_A, MYROW, RSRC_A, NPROW ),
+* LOCc( N ) = NUMROC( N, NB_A, MYCOL, CSRC_A, NPCOL ).
+* An upper bound for these quantities may be computed by:
+* LOCr( M ) <= ceil( ceil(M/MB_A)/NPROW )*MB_A
+* LOCc( N ) <= ceil( ceil(N/NB_A)/NPCOL )*NB_A
+*
+* Arguments
+* =========
+*
+*
+* COMPQ (global input) CHARACTER*1
+* = 'V': update the matrix Q of Schur vectors;
+* = 'N': do not update Q.
+*
+* SELECT (global input/output) INTEGER array, dimension (N)
+* SELECT specifies the eigenvalues in the selected cluster. To
+* select a real eigenvalue w(j), SELECT(j) must be set to 1.
+* 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 1;
+* a complex conjugate pair of eigenvalues must be
+* either both included in the cluster or both excluded.
+* On output, the (partial) reordering is displayed.
+*
+* PARA (global input) INTEGER*6
+* Block parameters (some should be replaced by calls to
+* PILAENV and others by meaningful default values):
+* PARA(1) = maximum number of concurrent computational windows
+* allowed in the algorithm;
+* 0 < PARA(1) <= min(NPROW,NPCOL) must hold;
+* PARA(2) = number of eigenvalues in each window;
+* 0 < PARA(2) < PARA(3) must hold;
+* PARA(3) = window size; PARA(2) < PARA(3) < DESCT(MB_)
+* must hold;
+* PARA(4) = minimal percentage of flops required for
+* performing matrix-matrix multiplications instead
+* of pipelined orthogonal transformations;
+* 0 <= PARA(4) <= 100 must hold;
+* PARA(5) = width of block column slabs for row-wise
+* application of pipelined orthogonal
+* transformations in their factorized form;
+* 0 < PARA(5) <= DESCT(MB_) must hold.
+* PARA(6) = the maximum number of eigenvalues moved together
+* over a process border; in practice, this will be
+* approximately half of the cross border window size
+* 0 < PARA(6) <= PARA(2) must hold;
+*
+* N (global input) INTEGER
+* The order of the globally distributed matrix T. N >= 0.
+*
+* T (local input/output) REAL array,
+* dimension (LLD_T,LOCc(N)).
+* On entry, the local pieces of the global distributed
+* upper quasi-triangular matrix T, in Schur form. On exit, T is
+* overwritten by the local pieces of the reordered matrix T,
+* again in Schur form, with the selected eigenvalues in the
+* globally leading diagonal blocks.
+*
+* IT (global input) INTEGER
+* JT (global input) INTEGER
+* The row and column index in the global array T indicating the
+* first column of sub( T ). IT = JT = 1 must hold.
+*
+* DESCT (global and local input) INTEGER array of dimension DLEN_.
+* The array descriptor for the global distributed matrix T.
+*
+* Q (local input/output) REAL array,
+* dimension (LLD_Q,LOCc(N)).
+* On entry, if COMPQ = 'V', the local pieces of the global
+* distributed matrix Q of Schur vectors.
+* On exit, if COMPQ = 'V', Q has been postmultiplied by the
+* global 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.
+*
+* IQ (global input) INTEGER
+* JQ (global input) INTEGER
+* The column index in the global array Q indicating the
+* first column of sub( Q ). IQ = JQ = 1 must hold.
+*
+* DESCQ (global and local input) INTEGER array of dimension DLEN_.
+* The array descriptor for the global distributed matrix Q.
+*
+* WR (global output) REAL array, dimension (N)
+* WI (global output) REAL array, dimension (N)
+* The real and imaginary parts, respectively, of the reordered
+* eigenvalues of T. The eigenvalues are in principle 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 also that if a complex eigenvalue is sufficiently
+* ill-conditioned, then its value may differ significantly
+* from its value before reordering.
+*
+* M (global output) INTEGER
+* The dimension of the specified invariant subspace.
+* 0 <= M <= N.
+*
+* WORK (local workspace/output) REAL array,
+* dimension (LWORK)
+* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*
+* LWORK (local input) 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 PXERBLA.
+*
+* IWORK (local workspace/output) INTEGER array, dimension (LIWORK)
+*
+* LIWORK (local input) INTEGER
+* The dimension of the array IWORK.
+*
+* 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 PXERBLA.
+*
+* INFO (global output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value.
+* If the i-th argument is an array and the j-entry had
+* an illegal value, then INFO = -(i*1000+j), if the i-th
+* argument is a scalar and had an illegal value, then INFO = -i.
+* > 0: here we have several possibilites
+* *) 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.
+* On exit, INFO = {the index of T where the swap failed}.
+* *) A 2-by-2 block to be reordered split into two 1-by-1
+* blocks and the second block failed to swap with an
+* adjacent block.
+* On exit, INFO = {the index of T where the swap failed}.
+* *) If INFO = N+1, there is no valid BLACS context (see the
+* BLACS documentation for details).
+* In a future release this subroutine may distinguish between
+* the case 1 and 2 above.
+*
+* Additional requirements
+* =======================
+*
+* The following alignment requirements must hold:
+* (a) DESCT( MB_ ) = DESCT( NB_ ) = DESCQ( MB_ ) = DESCQ( NB_ )
+* (b) DESCT( RSRC_ ) = DESCQ( RSRC_ )
+* (c) DESCT( CSRC_ ) = DESCQ( CSRC_ )
+*
+* All matrices must be blocked by a block factor larger than or
+* equal to two (3). This is to simplify reordering across processor
+* borders in the presence of 2-by-2 blocks.
+*
+* Limitations
+* ===========
+*
+* This algorithm cannot work on submatrices of T and Q, i.e.,
+* IT = JT = IQ = JQ = 1 must hold. This is however no limitation
+* since PDLAHQR does not compute Schur forms of submatrices anyway.
+*
+* References
+* ==========
+*
+* [1] Z. Bai and J. W. Demmel; On swapping diagonal blocks in real
+* Schur form, Linear Algebra Appl., 186:73--95, 1993. Also as
+* LAPACK Working Note 54.
+*
+* [2] D. Kressner; Block algorithms for reordering standard and
+* generalized Schur forms, ACM TOMS, 32(4):521-532, 2006.
+* Also LAPACK Working Note 171.
+*
+* [3] R. Granat, B. Kagstrom, and D. Kressner; Parallel eigenvalue
+* reordering in real Schur form, Concurrency and Computations:
+* Practice and Experience, 21(9):1225-1250, 2009. Also as
+* LAPACK Working Note 192.
+*
+* Parallel execution recommendations
+* ==================================
+*
+* Use a square grid, if possible, for maximum performance. The block
+* parameters in PARA should be kept well below the data distribution
+* block size. In particular, see [3] for recommended settings for
+* these parameters.
+*
+* In general, the parallel algorithm strives to perform as much work
+* as possible without crossing the block borders on the main block
+* diagonal.
+*
+* Contributors
+* ============
+*
+* Implemented by Robert Granat, Dept. of Computing Science and HPC2N,
+* Umea University, Sweden, March 2007,
+* in collaboration with Bo Kagstrom and Daniel Kressner.
+* Modified by Meiyue Shao, October 2011.
+*
+* Revisions
+* =========
+*
+* Please send bug-reports to granat at cs.umu.se
+*
+* Keywords
+* ========
+*
+* Real Schur form, eigenvalue reordering
+*
+* =====================================================================
+* ..
+* .. Parameters ..
+ CHARACTER TOP
+ INTEGER BLOCK_CYCLIC_2D, CSRC_, CTXT_, DLEN_, DTYPE_,
+ $ LLD_, MB_, M_, NB_, N_, RSRC_
+ REAL ZERO, ONE
+ PARAMETER ( TOP = '1-Tree',
+ $ BLOCK_CYCLIC_2D = 1, DLEN_ = 9, DTYPE_ = 1,
+ $ CTXT_ = 2, M_ = 3, N_ = 4, MB_ = 5, NB_ = 6,
+ $ RSRC_ = 7, CSRC_ = 8, LLD_ = 9,
+ $ ZERO = 0.0, ONE = 1.0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL LQUERY, PAIR, SWAP, WANTQ,
+ $ ISHH, FIRST, SKIP1CR, BORDER, LASTWAIT
+ INTEGER NPROW, NPCOL, MYROW, MYCOL, NB, NPROCS,
+ $ IERR, DIM1, INDX, LLDT, TRSRC, TCSRC, ILOC1,
+ $ JLOC1, MYIERR, ICTXT,
+ $ RSRC1, CSRC1, ILOC3, JLOC3, TRSRC3,
+ $ TCSRC3, ILOC, JLOC, TRSRC4, TCSRC4,
+ $ FLOPS, I, ILO, IHI, J, K, KK, KKS,
+ $ KS, LIWMIN, LWMIN, MMULT, N1, N2,
+ $ NCB, NDTRAF, NITRAF, NWIN, NUMWIN, PDTRAF,
+ $ PITRAF, PDW, WINEIG, WINSIZ, LLDQ,
+ $ RSRC, CSRC, ILILO, ILIHI, ILSEL, IRSRC,
+ $ ICSRC, IPIW, IPW1, IPW2, IPW3, TIHI, TILO,
+ $ LIHI, WINDOW, LILO, LSEL, BUFFER,
+ $ NMWIN2, BUFFLEN, LROWS, LCOLS, ILOC2, JLOC2,
+ $ WNEICR, WINDOW0, RSRC4, CSRC4, LIHI4, RSRC3,
+ $ CSRC3, RSRC2, CSRC2, LIHIC, LIHI1, ILEN4,
+ $ SELI4, ILEN1, DIM4, IPW4, QROWS, TROWS,
+ $ TCOLS, IPW5, IPW6, IPW7, IPW8, JLOC4,
+ $ EAST, WEST, ILOC4, SOUTH, NORTH, INDXS,
+ $ ITT, JTT, ILEN, DLEN, INDXE, TRSRC1, TCSRC1,
+ $ TRSRC2, TCSRC2, ILOS, DIR, TLIHI, TLILO, TLSEL,
+ $ ROUND, LAST, WIN0S, WIN0E, WINE, MMAX, MMIN
+ REAL ELEM, ELEM1, ELEM2, ELEM3, ELEM4, SN, CS, TMP,
+ $ ELEM5
+* ..
+* .. Local Arrays ..
+ INTEGER IBUFF( 8 ), IDUM1( 1 ), IDUM2( 1 )
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ INTEGER NUMROC, INDXG2P, INDXG2L
+ EXTERNAL LSAME, NUMROC, INDXG2P, INDXG2L
+* ..
+* .. External Subroutines ..
+ EXTERNAL PSLACPY, PXERBLA, PCHK1MAT, PCHK2MAT,
+ $ SGEMM, SLAMOV, ILACPY, CHK1MAT,
+ $ INFOG2L, DGSUM2D, SGESD2D, SGERV2D, SGEBS2D,
+ $ SGEBR2D, IGSUM2D, BLACS_GRIDINFO, IGEBS2D,
+ $ IGEBR2D, IGAMX2D, IGAMN2D, BSLAAPP, BDTREXC
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX, SQRT, MIN
+* ..
+* .. Local Functions ..
+ INTEGER ICEIL
+* ..
+* .. Executable Statements ..
+*
+* Get grid parameters.
+*
+ ICTXT = DESCT( CTXT_ )
+ CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL )
+ NPROCS = NPROW*NPCOL
+*
+* Test if grid is O.K., i.e., the context is valid.
+*
+ INFO = 0
+ IF( NPROW.EQ.-1 ) THEN
+ INFO = N+1
+ END IF
+*
+* Check if workspace query.
+*
+ LQUERY = LWORK.EQ.-1 .OR. LIWORK.EQ.-1
+*
+* Test dimensions for local sanity.
+*
+ IF( INFO.EQ.0 ) THEN
+ CALL CHK1MAT( N, 5, N, 5, IT, JT, DESCT, 9, INFO )
+ END IF
+ IF( INFO.EQ.0 ) THEN
+ CALL CHK1MAT( N, 5, N, 5, IQ, JQ, DESCQ, 13, INFO )
+ END IF
+*
+* Check the blocking sizes for alignment requirements.
+*
+ IF( INFO.EQ.0 ) THEN
+ IF( DESCT( MB_ ).NE.DESCT( NB_ ) ) INFO = -(1000*9 + MB_)
+ END IF
+ IF( INFO.EQ.0 ) THEN
+ IF( DESCQ( MB_ ).NE.DESCQ( NB_ ) ) INFO = -(1000*13 + MB_)
+ END IF
+ IF( INFO.EQ.0 ) THEN
+ IF( DESCT( MB_ ).NE.DESCQ( MB_ ) ) INFO = -(1000*9 + MB_)
+ END IF
+*
+* Check the blocking sizes for minimum sizes.
+*
+ IF( INFO.EQ.0 ) THEN
+ IF( N.NE.DESCT( MB_ ) .AND. DESCT( MB_ ).LT.3 )
+ $ INFO = -(1000*9 + MB_)
+ IF( N.NE.DESCQ( MB_ ) .AND. DESCQ( MB_ ).LT.3 )
+ $ INFO = -(1000*13 + MB_)
+ END IF
+*
+* Check parameters in PARA.
+*
+ NB = DESCT( MB_ )
+ IF( INFO.EQ.0 ) THEN
+ IF( PARA(1).LT.1 .OR. PARA(1).GT.MIN(NPROW,NPCOL) )
+ $ INFO = -(1000 * 4 + 1)
+ IF( PARA(2).LT.1 .OR. PARA(2).GE.PARA(3) )
+ $ INFO = -(1000 * 4 + 2)
+ IF( PARA(3).LT.1 .OR. PARA(3).GT.NB )
+ $ INFO = -(1000 * 4 + 3)
+ IF( PARA(4).LT.0 .OR. PARA(4).GT.100 )
+ $ INFO = -(1000 * 4 + 4)
+ IF( PARA(5).LT.1 .OR. PARA(5).GT.NB )
+ $ INFO = -(1000 * 4 + 5)
+ IF( PARA(6).LT.1 .OR. PARA(6).GT.PARA(2) )
+ $ INFO = -(1000 * 4 + 6)
+ END IF
+*
+* Check requirements on IT, JT, IQ and JQ.
+*
+ IF( INFO.EQ.0 ) THEN
+ IF( IT.NE.1 ) INFO = -6
+ IF( JT.NE.IT ) INFO = -7
+ IF( IQ.NE.1 ) INFO = -10
+ IF( JQ.NE.IQ ) INFO = -11
+ END IF
+*
+* Test input parameters for global sanity.
+*
+ IF( INFO.EQ.0 ) THEN
+ CALL PCHK1MAT( N, 5, N, 5, IT, JT, DESCT, 9, 0, IDUM1,
+ $ IDUM2, INFO )
+ END IF
+ IF( INFO.EQ.0 ) THEN
+ CALL PCHK1MAT( N, 5, N, 5, IQ, JQ, DESCQ, 13, 0, IDUM1,
+ $ IDUM2, INFO )
+ END IF
+ IF( INFO.EQ.0 ) THEN
+ CALL PCHK2MAT( N, 5, N, 5, IT, JT, DESCT, 9, N, 5, N, 5,
+ $ IQ, JQ, DESCQ, 13, 0, IDUM1, IDUM2, INFO )
+ END IF
+*
+* Decode and test the input parameters.
+*
+ IF( INFO.EQ.0 .OR. LQUERY ) THEN
+*
+ WANTQ = LSAME( COMPQ, 'V' )
+ IF( N.LT.0 ) THEN
+ INFO = -4
+ ELSE
+*
+* Extract local leading dimension.
+*
+ LLDT = DESCT( LLD_ )
+ LLDQ = DESCQ( LLD_ )
+*
+* Check the SELECT vector for consistency and set M to the
+* dimension of the specified invariant subspace.
+*
+ M = 0
+ DO 10 K = 1, N
+ IF( K.LT.N ) THEN
+ CALL INFOG2L( K+1, K, DESCT, NPROW, NPCOL,
+ $ MYROW, MYCOL, ITT, JTT, TRSRC, TCSRC )
+ IF( MYROW.EQ.TRSRC .AND. MYCOL.EQ.TCSRC ) THEN
+ ELEM = T( (JTT-1)*LLDT + ITT )
+ IF( ELEM.NE.ZERO ) THEN
+ IF( SELECT(K).NE.0 .AND.
+ $ SELECT(K+1).EQ.0 ) THEN
+* INFO = -2
+ SELECT(K+1) = 1
+ ELSEIF( SELECT(K).EQ.0 .AND.
+ $ SELECT(K+1).NE.0 ) THEN
+* INFO = -2
+ SELECT(K) = 1
+ END IF
+ END IF
+ END IF
+ END IF
+ IF( SELECT(K).NE.0 ) M = M + 1
+ 10 CONTINUE
+ MMAX = M
+ MMIN = M
+ IF( NPROCS.GT.1 )
+ $ CALL IGAMX2D( ICTXT, 'All', TOP, 1, 1, MMAX, 1, -1,
+ $ -1, -1, -1, -1 )
+ IF( NPROCS.GT.1 )
+ $ CALL IGAMN2D( ICTXT, 'All', TOP, 1, 1, MMIN, 1, -1,
+ $ -1, -1, -1, -1 )
+ IF( MMAX.GT.MMIN ) THEN
+ M = MMAX
+ IF( NPROCS.GT.1 )
+ $ CALL IGAMX2D( ICTXT, 'All', TOP, N, 1, SELECT, N,
+ $ -1, -1, -1, -1, -1 )
+ END IF
+*
+* Compute needed workspace.
+*
+ N1 = M
+ N2 = N - M
+*
+ TROWS = NUMROC( N, NB, MYROW, DESCT(RSRC_), NPROW )
+ TCOLS = NUMROC( N, NB, MYCOL, DESCT(CSRC_), NPCOL )
+ LWMIN = N + 7*NB**2 + 2*TROWS*PARA( 3 ) + TCOLS*PARA( 3 ) +
+ $ MAX( TROWS*PARA( 3 ), TCOLS*PARA( 3 ) )
+ LIWMIN = 5*PARA( 1 ) + PARA( 2 )*PARA( 3 ) -
+ $ PARA( 2 ) * ( PARA( 2 ) + 1 ) / 2
+*
+ 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
+ END IF
+*
+* Global maximum on info.
+*
+ IF( NPROCS.GT.1 )
+ $ CALL IGAMX2D( ICTXT, 'All', TOP, 1, 1, INFO, 1, -1, -1, -1,
+ $ -1, -1 )
+*
+* Return if some argument is incorrect.
+*
+ IF( INFO.NE.0 .AND. .NOT.LQUERY ) THEN
+ M = 0
+ CALL PXERBLA( ICTXT, 'PSTRORD', -INFO )
+ RETURN
+ ELSEIF( LQUERY ) THEN
+ WORK( 1 ) = FLOAT(LWMIN)
+ IWORK( 1 ) = LIWMIN
+ RETURN
+ END IF
+*
+* Quick return if possible.
+*
+ IF( M.EQ.N .OR. M.EQ.0 ) GO TO 545
+*
+* Set parameters.
+*
+ NUMWIN = PARA( 1 )
+ WINEIG = MAX( PARA( 2 ), 2 )
+ WINSIZ = MIN( MAX( PARA( 3 ), PARA( 2 )*2 ), NB )
+ MMULT = PARA( 4 )
+ NCB = PARA( 5 )
+ WNEICR = PARA( 6 )
+*
+* Insert some pointers into INTEGER workspace.
+*
+* Information about all the active windows is stored
+* in IWORK( 1:5*NUMWIN ). Each processor has a copy.
+* LILO: start position
+* LIHI: stop position
+* LSEL: number of selected eigenvalues
+* RSRC: processor id (row)
+* CSRC: processor id (col)
+* IWORK( IPIW+ ) contain information of orthogonal transformations.
+*
+ ILILO = 1
+ ILIHI = ILILO + NUMWIN
+ ILSEL = ILIHI + NUMWIN
+ IRSRC = ILSEL + NUMWIN
+ ICSRC = IRSRC + NUMWIN
+ IPIW = ICSRC + NUMWIN
+*
+* Insert some pointers into REAL workspace - for now we
+* only need two pointers.
+*
+ IPW1 = 1
+ IPW2 = IPW1 + NB
+*
+* Collect the selected blocks at the top-left corner of T.
+*
+* Globally: ignore eigenvalues that are already in order.
+* ILO is a global variable and is kept updated to be consistent
+* throughout the process mesh.
+*
+ ILO = 0
+ 40 CONTINUE
+ ILO = ILO + 1
+ IF( ILO.LE.N ) THEN
+ IF( SELECT(ILO).NE.0 ) GO TO 40
+ END IF
+*
+* Globally: start the collection at the top of the matrix. Here,
+* IHI is a global variable and is kept updated to be consistent
+* throughout the process mesh.
+*
+ IHI = N
+*
+* Globally: While ( ILO <= M ) do
+ 50 CONTINUE
+*
+ IF( ILO.LE.M ) THEN
+*
+* Depending on the value of ILO, find the diagonal block index J,
+* such that T(1+(J-1)*NB:1+J*NB,1+(J-1)*NB:1+J*NB) contains the
+* first unsorted eigenvalue. Check that J does not point to a
+* block with only one selected eigenvalue in the last position
+* which belongs to a splitted 2-by-2 block.
+*
+ ILOS = ILO - 1
+ 52 CONTINUE
+ ILOS = ILOS + 1
+ IF( SELECT(ILOS).EQ.0 ) GO TO 52
+ IF( ILOS.LT.N ) THEN
+ IF( SELECT(ILOS+1).NE.0 .AND. MOD(ILOS,NB).EQ.0 ) THEN
+ CALL PSELGET( 'All', TOP, ELEM, T, ILOS+1, ILOS, DESCT )
+ IF( ELEM.NE.ZERO ) GO TO 52
+ END IF
+ END IF
+ J = ICEIL(ILOS,NB)
+*
+* Globally: Set start values of LILO and LIHI for all processes.
+* Choose also the number of selected eigenvalues at top of each
+* diagonal block such that the number of eigenvalues which remain
+* to be reordered is an integer multiple of WINEIG.
+*
+* All the information is saved into the INTEGER workspace such
+* that all processors are aware of each others operations.
+*
+* Compute the number of concurrent windows.
+*
+ NMWIN2 = (ICEIL(IHI,NB)*NB - (ILO-MOD(ILO,NB)+1)+1) / NB
+ NMWIN2 = MIN( MIN( NUMWIN, NMWIN2 ), ICEIL(N,NB) - J + 1 )
+*
+* For all windows, set LSEL = 0 and find a proper start value of
+* LILO such that LILO points at the first non-selected entry in
+* the corresponding diagonal block of T.
+*
+ DO 80 K = 1, NMWIN2
+ IWORK( ILSEL+K-1) = 0
+ IWORK( ILILO+K-1) = MAX( ILO, (J-1)*NB+(K-1)*NB+1 )
+ LILO = IWORK( ILILO+K-1 )
+ 82 CONTINUE
+ IF( SELECT(LILO).NE.0 .AND. LILO.LT.(J+K-1)*NB ) THEN
+ LILO = LILO + 1
+ IF( LILO.LE.N ) GO TO 82
+ END IF
+ IWORK( ILILO+K-1 ) = LILO
+*
+* Fix each LILO to ensure that no 2-by-2 block is cut in top
+* of the submatrix (LILO:LIHI,LILO:LIHI).
+*
+ LILO = IWORK(ILILO+K-1)
+ IF( LILO.GT.NB ) THEN
+ CALL PSELGET( 'All', TOP, ELEM, T, LILO, LILO-1, DESCT )
+ IF( ELEM.NE.ZERO ) THEN
+ IF( LILO.LT.(J+K-1)*NB ) THEN
+ IWORK(ILILO+K-1) = IWORK(ILILO+K-1) + 1
+ ELSE
+ IWORK(ILILO+K-1) = IWORK(ILILO+K-1) - 1
+ END IF
+ END IF
+ END IF
+*
+* Set a proper LIHI value for each window. Also find the
+* processors corresponding to the corresponding windows.
+*
+ IWORK( ILIHI+K-1 ) = IWORK( ILILO+K-1 )
+ IWORK( IRSRC+K-1 ) = INDXG2P( IWORK(ILILO+K-1), NB, MYROW,
+ $ DESCT( RSRC_ ), NPROW )
+ IWORK( ICSRC+K-1 ) = INDXG2P( IWORK(ILILO+K-1), NB, MYCOL,
+ $ DESCT( CSRC_ ), NPCOL )
+ TILO = IWORK(ILILO+K-1)
+ TIHI = MIN( N, ICEIL( TILO, NB ) * NB )
+ DO 90 KK = TIHI, TILO, -1
+ IF( SELECT(KK).NE.0 ) THEN
+ IWORK(ILIHI+K-1) = MAX(IWORK(ILIHI+K-1) , KK )
+ IWORK(ILSEL+K-1) = IWORK(ILSEL+K-1) + 1
+ IF( IWORK(ILSEL+K-1).GT.WINEIG ) THEN
+ IWORK(ILIHI+K-1) = KK
+ IWORK(ILSEL+K-1) = 1
+ END IF
+ END IF
+ 90 CONTINUE
+*
+* Fix each LIHI to avoid that bottom of window cuts 2-by-2
+* block. We exclude such a block if located on block (process)
+* border and on window border or if an inclusion would cause
+* violation on the maximum number of eigenvalues to reorder
+* inside each window. If only on window border, we include it.
+* The excluded block is included automatically later when a
+* subcluster is reordered into the block from South-East.
+*
+ LIHI = IWORK(ILIHI+K-1)
+ IF( LIHI.LT.N ) THEN
+ CALL PSELGET( 'All', TOP, ELEM, T, LIHI+1, LIHI, DESCT )
+ IF( ELEM.NE.ZERO ) THEN
+ IF( ICEIL( LIHI, NB ) .NE. ICEIL( LIHI+1, NB ) .OR.
+ $ IWORK( ILSEL+K-1 ).EQ.WINEIG ) THEN
+ IWORK( ILIHI+K-1 ) = IWORK( ILIHI+K-1 ) - 1
+ IF( IWORK( ILSEL+K-1 ).GT.2 )
+ $ IWORK( ILSEL+K-1 ) = IWORK( ILSEL+K-1 ) - 1
+ ELSE
+ IWORK( ILIHI+K-1 ) = IWORK( ILIHI+K-1 ) + 1
+ IF( SELECT(LIHI+1).NE.0 )
+ $ IWORK( ILSEL+K-1 ) = IWORK( ILSEL+K-1 ) + 1
+ END IF
+ END IF
+ END IF
+ 80 CONTINUE
+*
+* Fix the special cases of LSEL = 0 and LILO = LIHI for each
+* window by assuring that the stop-condition for local reordering
+* is fulfilled directly. Do this by setting LIHI = startposition
+* for the corresponding block and LILO = LIHI + 1.
+*
+ DO 85 K = 1, NMWIN2
+ LILO = IWORK( ILILO + K - 1 )
+ LIHI = IWORK( ILIHI + K - 1 )
+ LSEL = IWORK( ILSEL + K - 1 )
+ IF( LSEL.EQ.0 .OR. LILO.EQ.LIHI ) THEN
+ LIHI = IWORK( ILIHI + K - 1 )
+ IWORK( ILIHI + K - 1 ) = (ICEIL(LIHI,NB)-1)*NB + 1
+ IWORK( ILILO + K - 1 ) = IWORK( ILIHI + K - 1 ) + 1
+ END IF
+ 85 CONTINUE
+*
+* Associate all processors with the first computational window
+* that should be activated, if possible.
+*
+ LILO = IHI
+ LIHI = ILO
+ LSEL = M
+ FIRST = .TRUE.
+ DO 95 WINDOW = 1, NMWIN2
+ RSRC = IWORK(IRSRC+WINDOW-1)
+ CSRC = IWORK(ICSRC+WINDOW-1)
+ IF( MYROW.EQ.RSRC .OR. MYCOL.EQ.CSRC ) THEN
+ TLILO = IWORK( ILILO + WINDOW - 1 )
+ TLIHI = IWORK( ILIHI + WINDOW - 1 )
+ TLSEL = IWORK( ILSEL + WINDOW - 1 )
+ IF( (.NOT. ( LIHI .GE. LILO + LSEL ) ) .AND.
+ $ ( (TLIHI .GE. TLILO + TLSEL) .OR. FIRST ) ) THEN
+ IF( FIRST ) FIRST = .FALSE.
+ LILO = TLILO
+ LIHI = TLIHI
+ LSEL = TLSEL
+ GO TO 97
+ END IF
+ END IF
+ 95 CONTINUE
+ 97 CONTINUE
+*
+* Exclude all processors that are not involved in any
+* computational window right now.
+*
+ IERR = 0
+ IF( LILO.EQ.IHI .AND. LIHI.EQ.ILO .AND. LSEL.EQ.M )
+ $ GO TO 114
+*
+* Make sure all processors associated with a compuational window
+* enter the local reordering the first time.
+*
+ FIRST = .TRUE.
+*
+* Globally for all computational windows:
+* While ( LIHI >= LILO + LSEL ) do
+ ROUND = 1
+ 130 CONTINUE
+ IF( FIRST .OR. ( LIHI .GE. LILO + LSEL ) ) THEN
+*
+* Perform computations in parallel: loop through all
+* compuational windows, do local reordering and accumulate
+* transformations, broadcast them in the corresponding block
+* row and columns and compute the corresponding updates.
+*
+ DO 110 WINDOW = 1, NMWIN2
+ RSRC = IWORK(IRSRC+WINDOW-1)
+ CSRC = IWORK(ICSRC+WINDOW-1)
+*
+* The process on the block diagonal computes the
+* reordering.
+*
+ IF( MYROW.EQ.RSRC .AND. MYCOL.EQ.CSRC ) THEN
+ LILO = IWORK(ILILO+WINDOW-1)
+ LIHI = IWORK(ILIHI+WINDOW-1)
+ LSEL = IWORK(ILSEL+WINDOW-1)
+*
+* Compute the local value of I -- start position.
+*
+ I = MAX( LILO, LIHI - WINSIZ + 1 )
+*
+* Fix my I to avoid that top of window cuts a 2-by-2
+* block.
+*
+ IF( I.GT.LILO ) THEN
+ CALL INFOG2L( I, I-1, DESCT, NPROW, NPCOL, MYROW,
+ $ MYCOL, ILOC, JLOC, RSRC, CSRC )
+ IF( T( LLDT*(JLOC-1) + ILOC ).NE.ZERO )
+ $ I = I + 1
+ END IF
+*
+* Compute local indicies for submatrix to operate on.
+*
+ CALL INFOG2L( I, I, DESCT, NPROW, NPCOL,
+ $ MYROW, MYCOL, ILOC1, JLOC1, RSRC, CSRC )
+*
+* The active window is ( I:LIHI, I:LIHI ). Reorder
+* eigenvalues within this window and pipeline
+* transformations.
+*
+ NWIN = LIHI - I + 1
+ KS = 0
+ PITRAF = IPIW
+ PDTRAF = IPW2
+*
+ PAIR = .FALSE.
+ DO 140 K = I, LIHI
+ IF( PAIR ) THEN
+ PAIR = .FALSE.
+ ELSE
+ SWAP = SELECT( K ).NE.0
+ IF( K.LT.LIHI ) THEN
+ CALL INFOG2L( K+1, K, DESCT, NPROW, NPCOL,
+ $ MYROW, MYCOL, ILOC, JLOC, RSRC, CSRC )
+ IF( T( LLDT*(JLOC-1) + ILOC ).NE.ZERO )
+ $ PAIR = .TRUE.
+ END IF
+ IF( SWAP ) THEN
+ KS = KS + 1
+*
+* Swap the K-th block to position I+KS-1.
+*
+ IERR = 0
+ KK = K - I + 1
+ KKS = KS
+ IF( KK.NE.KS ) THEN
+ NITRAF = LIWORK - PITRAF + 1
+ NDTRAF = LWORK - PDTRAF + 1
+ CALL BSTREXC( NWIN,
+ $ T(LLDT*(JLOC1-1) + ILOC1), LLDT, KK,
+ $ KKS, NITRAF, IWORK( PITRAF ), NDTRAF,
+ $ WORK( PDTRAF ), WORK(IPW1), IERR )
+ PITRAF = PITRAF + NITRAF
+ PDTRAF = PDTRAF + NDTRAF
+*
+* Update array SELECT.
+*
+ IF ( PAIR ) THEN
+ DO 150 J = I+KK-1, I+KKS, -1
+ SELECT(J+1) = SELECT(J-1)
+ 150 CONTINUE
+ SELECT(I+KKS-1) = 1
+ SELECT(I+KKS) = 1
+ ELSE
+ DO 160 J = I+KK-1, I+KKS, -1
+ SELECT(J) = SELECT(J-1)
+ 160 CONTINUE
+ SELECT(I+KKS-1) = 1
+ END IF
+*
+ IF ( IERR.EQ.1 .OR. IERR.EQ.2 ) THEN
+*
+* Some blocks are too close to swap:
+* prepare to leave in a clean fashion. If
+* IERR.EQ.2, we must update SELECT to
+* account for the fact that the 2 by 2
+* block to be reordered did split and the
+* first part of this block is already
+* reordered.
+*
+ IF ( IERR.EQ.2 ) THEN
+ SELECT( I+KKS-3 ) = 1
+ SELECT( I+KKS-1 ) = 0
+ KKS = KKS + 1
+ END IF
+*
+* Update off-diagonal blocks immediately.
+*
+ GO TO 170
+ END IF
+ KS = KKS
+ END IF
+ IF( PAIR )
+ $ KS = KS + 1
+ END IF
+ END IF
+ 140 CONTINUE
+ END IF
+ 110 CONTINUE
+ 170 CONTINUE
+*
+* The on-diagonal processes save their information from the
+* local reordering in the integer buffer. This buffer is
+* broadcasted to updating processors, see below.
+*
+ DO 175 WINDOW = 1, NMWIN2
+ RSRC = IWORK(IRSRC+WINDOW-1)
+ CSRC = IWORK(ICSRC+WINDOW-1)
+ IF( MYROW.EQ.RSRC .AND. MYCOL.EQ.CSRC ) THEN
+ IBUFF( 1 ) = I
+ IBUFF( 2 ) = NWIN
+ IBUFF( 3 ) = PITRAF
+ IBUFF( 4 ) = KS
+ IBUFF( 5 ) = PDTRAF
+ IBUFF( 6 ) = NDTRAF
+ ILEN = PITRAF - IPIW
+ DLEN = PDTRAF - IPW2
+ IBUFF( 7 ) = ILEN
+ IBUFF( 8 ) = DLEN
+ END IF
+ 175 CONTINUE
+*
+* For the updates with respect to the local reordering, we
+* organize the updates in two phases where the update
+* "direction" (controlled by the DIR variable below) is first
+* chosen to be the corresponding rows, then the corresponding
+* columns.
+*
+ DO 1111 DIR = 1, 2
+*
+* Broadcast information about the reordering and the
+* accumulated transformations: I, NWIN, PITRAF, NITRAF,
+* PDTRAF, NDTRAF. If no broadcast is performed, use an
+* artificial value of KS to prevent updating indicies for
+* windows already finished (use KS = -1).
+*
+ DO 111 WINDOW = 1, NMWIN2
+ RSRC = IWORK(IRSRC+WINDOW-1)
+ CSRC = IWORK(ICSRC+WINDOW-1)
+ IF( MYROW.EQ.RSRC .OR. MYCOL.EQ.CSRC ) THEN
+ LILO = IWORK(ILILO+WINDOW-1)
+ LIHI = IWORK(ILIHI+WINDOW-1)
+ LSEL = IWORK(ILSEL+WINDOW-1)
+ END IF
+ IF( MYROW.EQ.RSRC .AND. MYCOL.EQ.CSRC ) THEN
+ IF( NPCOL.GT.1 .AND. DIR.EQ.1 )
+ $ CALL IGEBS2D( ICTXT, 'Row', TOP, 8, 1, IBUFF, 8 )
+ IF( NPROW.GT.1 .AND. DIR.EQ.2 )
+ $ CALL IGEBS2D( ICTXT, 'Col', TOP, 8, 1, IBUFF, 8 )
+ ELSEIF( MYROW.EQ.RSRC .OR. MYCOL.EQ.CSRC ) THEN
+ IF( NPCOL.GT.1 .AND. DIR.EQ.1 .AND. MYROW.EQ.RSRC )
+ $ THEN
+ IF( FIRST .OR. (LIHI .GE. LILO + LSEL) ) THEN
+ CALL IGEBR2D( ICTXT, 'Row', TOP, 8, 1, IBUFF, 8,
+ $ RSRC, CSRC )
+ I = IBUFF( 1 )
+ NWIN = IBUFF( 2 )
+ PITRAF = IBUFF( 3 )
+ KS = IBUFF( 4 )
+ PDTRAF = IBUFF( 5 )
+ NDTRAF = IBUFF( 6 )
+ ILEN = IBUFF( 7 )
+ DLEN = IBUFF( 8 )
+ ELSE
+ ILEN = 0
+ DLEN = 0
+ KS = -1
+ END IF
+ END IF
+ IF( NPROW.GT.1 .AND. DIR.EQ.2 .AND. MYCOL.EQ.CSRC )
+ $ THEN
+ IF( FIRST .OR. (LIHI .GE. LILO + LSEL) ) THEN
+ CALL IGEBR2D( ICTXT, 'Col', TOP, 8, 1, IBUFF, 8,
+ $ RSRC, CSRC )
+ I = IBUFF( 1 )
+ NWIN = IBUFF( 2 )
+ PITRAF = IBUFF( 3 )
+ KS = IBUFF( 4 )
+ PDTRAF = IBUFF( 5 )
+ NDTRAF = IBUFF( 6 )
+ ILEN = IBUFF( 7 )
+ DLEN = IBUFF( 8 )
+ ELSE
+ ILEN = 0
+ DLEN = 0
+ KS = -1
+ END IF
+ END IF
+ END IF
+*
+* Broadcast the accumulated transformations - copy all
+* information from IWORK(IPIW:PITRAF-1) and
+* WORK(IPW2:PDTRAF-1) to a buffer and broadcast this
+* buffer in the corresponding block row and column. On
+* arrival, copy the information back to the correct part of
+* the workspace. This step is avoided if no computations
+* were performed at the diagonal processor, i.e.,
+* BUFFLEN = 0.
+*
+ IF( MYROW.EQ.RSRC .AND. MYCOL.EQ.CSRC ) THEN
+ BUFFER = PDTRAF
+ BUFFLEN = DLEN + ILEN
+ IF( BUFFLEN.NE.0 ) THEN
+ DO 180 INDX = 1, ILEN
+ WORK( BUFFER+INDX-1 ) =
+ $ FLOAT( IWORK(IPIW+INDX-1) )
+ 180 CONTINUE
+ CALL SLAMOV( 'All', DLEN, 1, WORK( IPW2 ),
+ $ DLEN, WORK(BUFFER+ILEN), DLEN )
+ IF( NPCOL.GT.1 .AND. DIR.EQ.1 ) THEN
+ CALL SGEBS2D( ICTXT, 'Row', TOP, BUFFLEN, 1,
+ $ WORK(BUFFER), BUFFLEN )
+ END IF
+ IF( NPROW.GT.1 .AND. DIR.EQ.2 ) THEN
+ CALL SGEBS2D( ICTXT, 'Col', TOP, BUFFLEN, 1,
+ $ WORK(BUFFER), BUFFLEN )
+ END IF
+ END IF
+ ELSEIF( MYROW.EQ.RSRC .OR. MYCOL.EQ.CSRC ) THEN
+ IF( NPCOL.GT.1 .AND. DIR.EQ.1 .AND. MYROW.EQ.RSRC )
+ $ THEN
+ BUFFER = PDTRAF
+ BUFFLEN = DLEN + ILEN
+ IF( BUFFLEN.NE.0 ) THEN
+ CALL SGEBR2D( ICTXT, 'Row', TOP, BUFFLEN, 1,
+ $ WORK(BUFFER), BUFFLEN, RSRC, CSRC )
+ END IF
+ END IF
+ IF( NPROW.GT.1 .AND. DIR.EQ.2 .AND. MYCOL.EQ.CSRC )
+ $ THEN
+ BUFFER = PDTRAF
+ BUFFLEN = DLEN + ILEN
+ IF( BUFFLEN.NE.0 ) THEN
+ CALL SGEBR2D( ICTXT, 'Col', TOP, BUFFLEN, 1,
+ $ WORK(BUFFER), BUFFLEN, RSRC, CSRC )
+ END IF
+ END IF
+ IF((NPCOL.GT.1.AND.DIR.EQ.1.AND.MYROW.EQ.RSRC).OR.
+ $ (NPROW.GT.1.AND.DIR.EQ.2.AND.MYCOL.EQ.CSRC ) )
+ $ THEN
+ IF( BUFFLEN.NE.0 ) THEN
+ DO 190 INDX = 1, ILEN
+ IWORK(IPIW+INDX-1) =
+ $ INT(WORK( BUFFER+INDX-1 ))
+ 190 CONTINUE
+ CALL SLAMOV( 'All', DLEN, 1,
+ $ WORK( BUFFER+ILEN ), DLEN,
+ $ WORK( IPW2 ), DLEN )
+ END IF
+ END IF
+ END IF
+ 111 CONTINUE
+*
+* Now really perform the updates by applying the orthogonal
+* transformations to the out-of-window parts of T and Q. This
+* step is avoided if no reordering was performed by the on-
+* diagonal processor from the beginning, i.e., BUFFLEN = 0.
+*
+* Count number of operations to decide whether to use
+* matrix-matrix multiplications for updating off-diagonal
+* parts or not.
+*
+ DO 112 WINDOW = 1, NMWIN2
+ RSRC = IWORK(IRSRC+WINDOW-1)
+ CSRC = IWORK(ICSRC+WINDOW-1)
+*
+ IF( (MYROW.EQ.RSRC .AND. DIR.EQ.1 ).OR.
+ $ (MYCOL.EQ.CSRC .AND. DIR.EQ.2 ) ) THEN
+ LILO = IWORK(ILILO+WINDOW-1)
+ LIHI = IWORK(ILIHI+WINDOW-1)
+ LSEL = IWORK(ILSEL+WINDOW-1)
+*
+* Skip update part for current WINDOW if BUFFLEN = 0.
+*
+ IF( BUFFLEN.EQ.0 ) GO TO 295
+*
+ NITRAF = PITRAF - IPIW
+ ISHH = .FALSE.
+ FLOPS = 0
+ DO 200 K = 1, NITRAF
+ IF( IWORK( IPIW + K - 1 ).LE.NWIN ) THEN
+ FLOPS = FLOPS + 6
+ ELSE
+ FLOPS = FLOPS + 11
+ ISHH = .TRUE.
+ END IF
+ 200 CONTINUE
+*
+* Compute amount of work space necessary for performing
+* matrix-matrix multiplications.
+*
+ PDW = BUFFER
+ IPW3 = PDW + NWIN*NWIN
+ ELSE
+ FLOPS = 0
+ END IF
+*
+ IF( FLOPS.NE.0 .AND.
+ $ ( FLOPS*100 ) / ( 2*NWIN*NWIN ) .GE. MMULT ) THEN
+*
+* Update off-diagonal blocks and Q using matrix-matrix
+* multiplications; if there are no Householder
+* reflectors it is preferable to take the triangular
+* block structure of the transformation matrix into
+* account.
+*
+ CALL SLASET( 'All', NWIN, NWIN, ZERO, ONE,
+ $ WORK( PDW ), NWIN )
+ CALL BSLAAPP( 1, NWIN, NWIN, NCB, WORK( PDW ), NWIN,
+ $ NITRAF, IWORK(IPIW), WORK( IPW2 ), WORK(IPW3) )
+*
+ IF( ISHH ) THEN
+*
+* Loop through the local blocks of the distributed
+* matrices T and Q and update them according to the
+* performed reordering.
+*
+* Update the columns of T and Q affected by the
+* reordering.
+*
+ IF( DIR.EQ.2 ) THEN
+ DO 210 INDX = 1, I-1, NB
+ CALL INFOG2L( INDX, I, DESCT, NPROW, NPCOL,
+ $ MYROW, MYCOL, ILOC, JLOC, RSRC1, CSRC1 )
+ IF( MYROW.EQ.RSRC1 .AND. MYCOL.EQ.CSRC1 )
+ $ THEN
+ LROWS = MIN(NB,I-INDX)
+ CALL SGEMM( 'No transpose',
+ $ 'No transpose', LROWS, NWIN, NWIN,
+ $ ONE, T((JLOC-1)*LLDT+ILOC), LLDT,
+ $ WORK( PDW ), NWIN, ZERO,
+ $ WORK(IPW3), LROWS )
+ CALL SLAMOV( 'All', LROWS, NWIN,
+ $ WORK(IPW3), LROWS,
+ $ T((JLOC-1)*LLDT+ILOC), LLDT )
+ END IF
+ 210 CONTINUE
+ IF( WANTQ ) THEN
+ DO 220 INDX = 1, N, NB
+ CALL INFOG2L( INDX, I, DESCQ, NPROW,
+ $ NPCOL, MYROW, MYCOL, ILOC, JLOC,
+ $ RSRC1, CSRC1 )
+ IF( MYROW.EQ.RSRC1.AND.MYCOL.EQ.CSRC1 )
+ $ THEN
+ LROWS = MIN(NB,N-INDX+1)
+ CALL SGEMM( 'No transpose',
+ $ 'No transpose', LROWS, NWIN, NWIN,
+ $ ONE, Q((JLOC-1)*LLDQ+ILOC), LLDQ,
+ $ WORK( PDW ), NWIN, ZERO,
+ $ WORK(IPW3), LROWS )
+ CALL SLAMOV( 'All', LROWS, NWIN,
+ $ WORK(IPW3), LROWS,
+ $ Q((JLOC-1)*LLDQ+ILOC), LLDQ )
+ END IF
+ 220 CONTINUE
+ END IF
+ END IF
+*
+* Update the rows of T affected by the reordering
+*
+ IF( DIR.EQ.1 ) THEN
+ IF( LIHI.LT.N ) THEN
+ IF( MOD(LIHI,NB).GT.0 ) THEN
+ INDX = LIHI + 1
+ CALL INFOG2L( I, INDX, DESCT, NPROW,
+ $ NPCOL, MYROW, MYCOL, ILOC, JLOC,
+ $ RSRC1, CSRC1 )
+ IF( MYROW.EQ.RSRC1.AND.MYCOL.EQ.CSRC1 )
+ $ THEN
+ LCOLS = MOD( MIN( NB-MOD(LIHI,NB),
+ $ N-LIHI ), NB )
+ CALL SGEMM( 'Transpose',
+ $ 'No Transpose', NWIN, LCOLS, NWIN,
+ $ ONE, WORK( PDW ), NWIN,
+ $ T((JLOC-1)*LLDT+ILOC), LLDT, ZERO,
+ $ WORK(IPW3), NWIN )
+ CALL SLAMOV( 'All', NWIN, LCOLS,
+ $ WORK(IPW3), NWIN,
+ $ T((JLOC-1)*LLDT+ILOC), LLDT )
+ END IF
+ END IF
+ INDXS = ICEIL(LIHI,NB)*NB + 1
+ DO 230 INDX = INDXS, N, NB
+ CALL INFOG2L( I, INDX, DESCT, NPROW,
+ $ NPCOL, MYROW, MYCOL, ILOC, JLOC,
+ $ RSRC1, CSRC1 )
+ IF( MYROW.EQ.RSRC1.AND.MYCOL.EQ.CSRC1 )
+ $ THEN
+ LCOLS = MIN( NB, N-INDX+1 )
+ CALL SGEMM( 'Transpose',
+ $ 'No Transpose', NWIN, LCOLS, NWIN,
+ $ ONE, WORK( PDW ), NWIN,
+ $ T((JLOC-1)*LLDT+ILOC), LLDT, ZERO,
+ $ WORK(IPW3), NWIN )
+ CALL SLAMOV( 'All', NWIN, LCOLS,
+ $ WORK(IPW3), NWIN,
+ $ T((JLOC-1)*LLDT+ILOC), LLDT )
+ END IF
+ 230 CONTINUE
+ END IF
+ END IF
+ ELSE
+*
+* The NWIN-by-NWIN matrix U containing the
+* accumulated orthogonal transformations has the
+* following structure:
+*
+* [ U11 U12 ]
+* U = [ ],
+* [ U21 U22 ]
+*
+* where U21 is KS-by-KS upper triangular and U12 is
+* (NWIN-KS)-by-(NWIN-KS) lower triangular.
+*
+* Update the columns of T and Q affected by the
+* reordering.
+*
+* Compute T2*U21 + T1*U11 in workspace.
+*
+ IF( DIR.EQ.2 ) THEN
+ DO 240 INDX = 1, I-1, NB
+ CALL INFOG2L( INDX, I, DESCT, NPROW, NPCOL,
+ $ MYROW, MYCOL, ILOC, JLOC, RSRC1, CSRC1 )
+ IF( MYROW.EQ.RSRC1 .AND. MYCOL.EQ.CSRC1 )
+ $ THEN
+ JLOC1 = INDXG2L( I+NWIN-KS, NB, MYCOL,
+ $ DESCT( CSRC_ ), NPCOL )
+ LROWS = MIN(NB,I-INDX)
+ CALL SLAMOV( 'All', LROWS, KS,
+ $ T((JLOC1-1)*LLDT+ILOC ), LLDT,
+ $ WORK(IPW3), LROWS )
+ CALL STRMM( 'Right', 'Upper',
+ $ 'No transpose',
+ $ 'Non-unit', LROWS, KS, ONE,
+ $ WORK( PDW+NWIN-KS ), NWIN,
+ $ WORK(IPW3), LROWS )
+ CALL SGEMM( 'No transpose',
+ $ 'No transpose', LROWS, KS, NWIN-KS,
+ $ ONE, T((JLOC-1)*LLDT+ILOC), LLDT,
+ $ WORK( PDW ), NWIN, ONE, WORK(IPW3),
+ $ LROWS )
+*
+* Compute T1*U12 + T2*U22 in workspace.
+*
+ CALL SLAMOV( 'All', LROWS, NWIN-KS,
+ $ T((JLOC-1)*LLDT+ILOC), LLDT,
+ $ WORK( IPW3+KS*LROWS ), LROWS )
+ CALL STRMM( 'Right', 'Lower',
+ $ 'No transpose', 'Non-unit',
+ $ LROWS, NWIN-KS, ONE,
+ $ WORK( PDW+NWIN*KS ), NWIN,
+ $ WORK( IPW3+KS*LROWS ), LROWS )
+ CALL SGEMM( 'No transpose',
+ $ 'No transpose', LROWS, NWIN-KS, KS,
+ $ ONE, T((JLOC1-1)*LLDT+ILOC), LLDT,
+ $ WORK( PDW+NWIN*KS+NWIN-KS ), NWIN,
+ $ ONE, WORK( IPW3+KS*LROWS ), LROWS )
+*
+* Copy workspace to T.
+*
+ CALL SLAMOV( 'All', LROWS, NWIN,
+ $ WORK(IPW3), LROWS,
+ $ T((JLOC-1)*LLDT+ILOC), LLDT )
+ END IF
+ 240 CONTINUE
+ IF( WANTQ ) THEN
+*
+* Compute Q2*U21 + Q1*U11 in workspace.
+*
+ DO 250 INDX = 1, N, NB
+ CALL INFOG2L( INDX, I, DESCQ, NPROW,
+ $ NPCOL, MYROW, MYCOL, ILOC, JLOC,
+ $ RSRC1, CSRC1 )
+ IF( MYROW.EQ.RSRC1.AND.MYCOL.EQ.CSRC1 )
+ $ THEN
+ JLOC1 = INDXG2L( I+NWIN-KS, NB,
+ $ MYCOL, DESCQ( CSRC_ ), NPCOL )
+ LROWS = MIN(NB,N-INDX+1)
+ CALL SLAMOV( 'All', LROWS, KS,
+ $ Q((JLOC1-1)*LLDQ+ILOC ), LLDQ,
+ $ WORK(IPW3), LROWS )
+ CALL STRMM( 'Right', 'Upper',
+ $ 'No transpose', 'Non-unit',
+ $ LROWS, KS, ONE,
+ $ WORK( PDW+NWIN-KS ), NWIN,
+ $ WORK(IPW3), LROWS )
+ CALL SGEMM( 'No transpose',
+ $ 'No transpose', LROWS, KS,
+ $ NWIN-KS, ONE,
+ $ Q((JLOC-1)*LLDQ+ILOC), LLDQ,
+ $ WORK( PDW ), NWIN, ONE,
+ $ WORK(IPW3), LROWS )
+*
+* Compute Q1*U12 + Q2*U22 in workspace.
+*
+ CALL SLAMOV( 'All', LROWS, NWIN-KS,
+ $ Q((JLOC-1)*LLDQ+ILOC), LLDQ,
+ $ WORK( IPW3+KS*LROWS ), LROWS)
+ CALL STRMM( 'Right', 'Lower',
+ $ 'No transpose', 'Non-unit',
+ $ LROWS, NWIN-KS, ONE,
+ $ WORK( PDW+NWIN*KS ), NWIN,
+ $ WORK( IPW3+KS*LROWS ), LROWS)
+ CALL SGEMM( 'No transpose',
+ $ 'No transpose', LROWS, NWIN-KS,
+ $ KS, ONE, Q((JLOC1-1)*LLDQ+ILOC),
+ $ LLDQ, WORK(PDW+NWIN*KS+NWIN-KS),
+ $ NWIN, ONE, WORK( IPW3+KS*LROWS ),
+ $ LROWS )
+*
+* Copy workspace to Q.
+*
+ CALL SLAMOV( 'All', LROWS, NWIN,
+ $ WORK(IPW3), LROWS,
+ $ Q((JLOC-1)*LLDQ+ILOC), LLDQ )
+ END IF
+ 250 CONTINUE
+ END IF
+ END IF
+*
+ IF( DIR.EQ.1 ) THEN
+ IF ( LIHI.LT.N ) THEN
+*
+* Compute U21**T*T2 + U11**T*T1 in workspace.
+*
+ IF( MOD(LIHI,NB).GT.0 ) THEN
+ INDX = LIHI + 1
+ CALL INFOG2L( I, INDX, DESCT, NPROW,
+ $ NPCOL, MYROW, MYCOL, ILOC, JLOC,
+ $ RSRC1, CSRC1 )
+ IF( MYROW.EQ.RSRC1.AND.MYCOL.EQ.CSRC1 )
+ $ THEN
+ ILOC1 = INDXG2L( I+NWIN-KS, NB, MYROW,
+ $ DESCT( RSRC_ ), NPROW )
+ LCOLS = MOD( MIN( NB-MOD(LIHI,NB),
+ $ N-LIHI ), NB )
+ CALL SLAMOV( 'All', KS, LCOLS,
+ $ T((JLOC-1)*LLDT+ILOC1), LLDT,
+ $ WORK(IPW3), NWIN )
+ CALL STRMM( 'Left', 'Upper',
+ $ 'Transpose', 'Non-unit', KS,
+ $ LCOLS, ONE, WORK( PDW+NWIN-KS ),
+ $ NWIN, WORK(IPW3), NWIN )
+ CALL SGEMM( 'Transpose',
+ $ 'No transpose', KS, LCOLS,
+ $ NWIN-KS, ONE, WORK(PDW), NWIN,
+ $ T((JLOC-1)*LLDT+ILOC), LLDT, ONE,
+ $ WORK(IPW3), NWIN )
+*
+* Compute U12**T*T1 + U22**T*T2 in
+* workspace.
+*
+ CALL SLAMOV( 'All', NWIN-KS, LCOLS,
+ $ T((JLOC-1)*LLDT+ILOC), LLDT,
+ $ WORK( IPW3+KS ), NWIN )
+ CALL STRMM( 'Left', 'Lower',
+ $ 'Transpose', 'Non-unit',
+ $ NWIN-KS, LCOLS, ONE,
+ $ WORK( PDW+NWIN*KS ), NWIN,
+ $ WORK( IPW3+KS ), NWIN )
+ CALL SGEMM( 'Transpose',
+ $ 'No Transpose', NWIN-KS, LCOLS,
+ $ KS, ONE,
+ $ WORK( PDW+NWIN*KS+NWIN-KS ),
+ $ NWIN, T((JLOC-1)*LLDT+ILOC1),
+ $ LLDT, ONE, WORK( IPW3+KS ),
+ $ NWIN )
+*
+* Copy workspace to T.
+*
+ CALL SLAMOV( 'All', NWIN, LCOLS,
+ $ WORK(IPW3), NWIN,
+ $ T((JLOC-1)*LLDT+ILOC), LLDT )
+ END IF
+ END IF
+ INDXS = ICEIL(LIHI,NB)*NB + 1
+ DO 260 INDX = INDXS, N, NB
+ CALL INFOG2L( I, INDX, DESCT, NPROW,
+ $ NPCOL, MYROW, MYCOL, ILOC, JLOC,
+ $ RSRC1, CSRC1 )
+ IF( MYROW.EQ.RSRC1.AND.MYCOL.EQ.CSRC1 )
+ $ THEN
+*
+* Compute U21**T*T2 + U11**T*T1 in
+* workspace.
+*
+ ILOC1 = INDXG2L( I+NWIN-KS, NB,
+ $ MYROW, DESCT( RSRC_ ), NPROW )
+ LCOLS = MIN( NB, N-INDX+1 )
+ CALL SLAMOV( 'All', KS, LCOLS,
+ $ T((JLOC-1)*LLDT+ILOC1), LLDT,
+ $ WORK(IPW3), NWIN )
+ CALL STRMM( 'Left', 'Upper',
+ $ 'Transpose', 'Non-unit', KS,
+ $ LCOLS, ONE,
+ $ WORK( PDW+NWIN-KS ), NWIN,
+ $ WORK(IPW3), NWIN )
+ CALL SGEMM( 'Transpose',
+ $ 'No transpose', KS, LCOLS,
+ $ NWIN-KS, ONE, WORK(PDW), NWIN,
+ $ T((JLOC-1)*LLDT+ILOC), LLDT, ONE,
+ $ WORK(IPW3), NWIN )
+*
+* Compute U12**T*T1 + U22**T*T2 in
+* workspace.
+*
+ CALL SLAMOV( 'All', NWIN-KS, LCOLS,
+ $ T((JLOC-1)*LLDT+ILOC), LLDT,
+ $ WORK( IPW3+KS ), NWIN )
+ CALL STRMM( 'Left', 'Lower',
+ $ 'Transpose', 'Non-unit',
+ $ NWIN-KS, LCOLS, ONE,
+ $ WORK( PDW+NWIN*KS ), NWIN,
+ $ WORK( IPW3+KS ), NWIN )
+ CALL SGEMM( 'Transpose',
+ $ 'No Transpose', NWIN-KS, LCOLS,
+ $ KS, ONE,
+ $ WORK( PDW+NWIN*KS+NWIN-KS ),
+ $ NWIN, T((JLOC-1)*LLDT+ILOC1),
+ $ LLDT, ONE, WORK(IPW3+KS), NWIN )
+*
+* Copy workspace to T.
+*
+ CALL SLAMOV( 'All', NWIN, LCOLS,
+ $ WORK(IPW3), NWIN,
+ $ T((JLOC-1)*LLDT+ILOC), LLDT )
+ END IF
+ 260 CONTINUE
+ END IF
+ END IF
+ END IF
+ ELSEIF( FLOPS.NE.0 ) THEN
+*
+* Update off-diagonal blocks and Q using the pipelined
+* elementary transformations.
+*
+ IF( DIR.EQ.2 ) THEN
+ DO 270 INDX = 1, I-1, NB
+ CALL INFOG2L( INDX, I, DESCT, NPROW, NPCOL,
+ $ MYROW, MYCOL, ILOC, JLOC, RSRC1, CSRC1 )
+ IF( MYROW.EQ.RSRC1 .AND. MYCOL.EQ.CSRC1 ) THEN
+ LROWS = MIN(NB,I-INDX)
+ CALL BSLAAPP( 1, LROWS, NWIN, NCB,
+ $ T((JLOC-1)*LLDT+ILOC ), LLDT, NITRAF,
+ $ IWORK(IPIW), WORK( IPW2 ),
+ $ WORK(IPW3) )
+ END IF
+ 270 CONTINUE
+ IF( WANTQ ) THEN
+ DO 280 INDX = 1, N, NB
+ CALL INFOG2L( INDX, I, DESCQ, NPROW, NPCOL,
+ $ MYROW, MYCOL, ILOC, JLOC, RSRC1, CSRC1 )
+ IF( MYROW.EQ.RSRC1 .AND. MYCOL.EQ.CSRC1 )
+ $ THEN
+ LROWS = MIN(NB,N-INDX+1)
+ CALL BSLAAPP( 1, LROWS, NWIN, NCB,
+ $ Q((JLOC-1)*LLDQ+ILOC), LLDQ, NITRAF,
+ $ IWORK(IPIW), WORK( IPW2 ),
+ $ WORK(IPW3) )
+ END IF
+ 280 CONTINUE
+ END IF
+ END IF
+ IF( DIR.EQ.1 ) THEN
+ IF( LIHI.LT.N ) THEN
+ IF( MOD(LIHI,NB).GT.0 ) THEN
+ INDX = LIHI + 1
+ CALL INFOG2L( I, INDX, DESCT, NPROW, NPCOL,
+ $ MYROW, MYCOL, ILOC, JLOC, RSRC1, CSRC1 )
+ IF( MYROW.EQ.RSRC1 .AND. MYCOL.EQ.CSRC1 )
+ $ THEN
+ LCOLS = MOD( MIN( NB-MOD(LIHI,NB),
+ $ N-LIHI ), NB )
+ CALL BSLAAPP( 0, NWIN, LCOLS, NCB,
+ $ T((JLOC-1)*LLDT+ILOC), LLDT, NITRAF,
+ $ IWORK(IPIW), WORK( IPW2 ),
+ $ WORK(IPW3) )
+ END IF
+ END IF
+ INDXS = ICEIL(LIHI,NB)*NB + 1
+ DO 290 INDX = INDXS, N, NB
+ CALL INFOG2L( I, INDX, DESCT, NPROW, NPCOL,
+ $ MYROW, MYCOL, ILOC, JLOC, RSRC1, CSRC1 )
+ IF( MYROW.EQ.RSRC1 .AND. MYCOL.EQ.CSRC1 )
+ $ THEN
+ LCOLS = MIN( NB, N-INDX+1 )
+ CALL BSLAAPP( 0, NWIN, LCOLS, NCB,
+ $ T((JLOC-1)*LLDT+ILOC), LLDT, NITRAF,
+ $ IWORK(IPIW), WORK( IPW2 ),
+ $ WORK(IPW3) )
+ END IF
+ 290 CONTINUE
+ END IF
+ END IF
+ END IF
+*
+* If I was not involved in the updates for the current
+* window or the window was fully processed, I go here and
+* try again for the next window.
+*
+ 295 CONTINUE
+*
+* Update LIHI and LIHI depending on the number of
+* eigenvalues really moved - for on-diagonal processes we
+* do this update only once since each on-diagonal process
+* is only involved with one window at one time. The
+* indicies are updated in three cases:
+* 1) When some reordering was really performed
+* -- indicated by BUFFLEN > 0.
+* 2) When no selected eigenvalues was found in the
+* current window -- indicated by KS = 0.
+* 3) When some selected eigenvalues was found in the
+* current window but no one of them was moved
+* (KS > 0 and BUFFLEN = 0)
+* False index updating is avoided by sometimes setting
+* KS = -1. This will affect processors involved in more
+* than one window and where the first one ends up with
+* KS = 0 and for the second one is done already.
+*
+ IF( MYROW.EQ.RSRC.AND.MYCOL.EQ.CSRC ) THEN
+ IF( DIR.EQ.2 ) THEN
+ IF( BUFFLEN.NE.0 .OR. KS.EQ.0 .OR.
+ $ ( BUFFLEN.EQ.0 .AND. KS.GT.0 ) )
+ $ LIHI = I + KS - 1
+ IWORK( ILIHI+WINDOW-1 ) = LIHI
+ IF( .NOT. LIHI.GE.LILO+LSEL ) THEN
+ LILO = LILO + LSEL
+ IWORK( ILILO+WINDOW-1 ) = LILO
+ END IF
+ END IF
+ ELSEIF( MYROW.EQ.RSRC .AND. DIR.EQ.1 ) THEN
+ IF( BUFFLEN.NE.0 .OR. KS.EQ.0 .OR.
+ $ ( BUFFLEN.EQ.0 .AND. KS.GT.0 ) )
+ $ LIHI = I + KS - 1
+ IWORK( ILIHI+WINDOW-1 ) = LIHI
+ IF( .NOT. LIHI.GE.LILO+LSEL ) THEN
+ LILO = LILO + LSEL
+ IWORK( ILILO+WINDOW-1 ) = LILO
+ END IF
+ ELSEIF( MYCOL.EQ.CSRC .AND. DIR.EQ.2 ) THEN
+ IF( BUFFLEN.NE.0 .OR. KS.EQ.0 .OR.
+ $ ( BUFFLEN.EQ.0 .AND. KS.GT.0 ) )
+ $ LIHI = I + KS - 1
+ IWORK( ILIHI+WINDOW-1 ) = LIHI
+ IF( .NOT. LIHI.GE.LILO+LSEL ) THEN
+ LILO = LILO + LSEL
+ IWORK( ILILO+WINDOW-1 ) = LILO
+ END IF
+ END IF
+*
+ 112 CONTINUE
+*
+* End of direction loop for updates with respect to local
+* reordering.
+*
+ 1111 CONTINUE
+*
+* Associate each process with one of the corresponding
+* computational windows such that the test for another round
+* of local reordering is carried out properly. Since the
+* column updates were computed after the row updates, it is
+* sufficient to test for changing the association to the
+* window in the corresponding process row.
+*
+ DO 113 WINDOW = 1, NMWIN2
+ RSRC = IWORK( IRSRC + WINDOW - 1 )
+ IF( MYROW.EQ.RSRC .AND. (.NOT. LIHI.GE.LILO+LSEL ) ) THEN
+ LILO = IWORK( ILILO + WINDOW - 1 )
+ LIHI = IWORK( ILIHI + WINDOW - 1 )
+ LSEL = IWORK( ILSEL + WINDOW - 1 )
+ END IF
+ 113 CONTINUE
+*
+* End While ( LIHI >= LILO + LSEL )
+ ROUND = ROUND + 1
+ IF( FIRST ) FIRST = .FALSE.
+ GO TO 130
+ END IF
+*
+* All processors excluded from the local reordering go here.
+*
+ 114 CONTINUE
+*
+* Barrier to collect the processes before proceeding.
+*
+ CALL BLACS_BARRIER( ICTXT, 'All' )
+*
+* Compute global maximum of IERR so that we know if some process
+* experienced a failure in the reordering.
+*
+ MYIERR = IERR
+ IF( NPROCS.GT.1 )
+ $ CALL IGAMX2D( ICTXT, 'All', TOP, 1, 1, IERR, 1, -1,
+ $ -1, -1, -1, -1 )
+*
+ IF( IERR.NE.0 ) THEN
+*
+* When calling BDTREXC, the block at position I+KKS-1 failed
+* to swap.
+*
+ IF( MYIERR.NE.0 ) INFO = MAX(1,I+KKS-1)
+ IF( NPROCS.GT.1 )
+ $ CALL IGAMX2D( ICTXT, 'All', TOP, 1, 1, INFO, 1, -1,
+ $ -1, -1, -1, -1 )
+ GO TO 300
+ END IF
+*
+* Now, for each compuational window, move the selected
+* eigenvalues across the process border. Do this by forming the
+* processors into groups of four working together to bring the
+* window over the border. The processes are numbered as follows
+*
+* 1 | 2
+* --+--
+* 3 | 4
+*
+* where '|' and '-' denotes the process (and block) borders.
+* This implies that the cluster to be reordered over the border
+* is held by process 4, process 1 will receive the cluster after
+* the reordering, process 3 holds the local (2,1)th element of a
+* 2-by-2 diagonal block located on the block border and process 2
+* holds the closest off-diagonal part of the window that is
+* affected by the cross-border reordering.
+*
+* The active window is now ( I : LIHI[4], I : LIHI[4] ), where
+* I = MAX( ILO, LIHI - 2*MOD(LIHI,NB) ). If this active window is
+* too large compared to the value of PARA( 6 ), it will be
+* truncated in both ends such that a maximum of PARA( 6 )
+* eigenvalues is reordered across the border this time.
+*
+* The active window will be collected and built in workspace at
+* process 1 and 4, which both compute the reordering and return
+* the updated parts to the corresponding processes 2-3. Next, the
+* accumulated transformations are broadcasted for updates in the
+* block rows and column that corresponds to the process rows and
+* columns where process 1 and 4 reside.
+*
+* The off-diagonal blocks are updated by the processes receiving
+* from the broadcasts of the orthogonal transformations. Since
+* the active window is split over the process borders, the
+* updates of T and Q requires that stripes of block rows of
+* columns are exchanged between neighboring processes in the
+* corresponding process rows and columns.
+*
+* First, form each group of processors involved in the
+* crossborder reordering. Do this in two (or three) phases:
+* 1) Reorder each odd window over the border.
+* 2) Reorder each even window over the border.
+* 3) Reorder the last odd window over the border, if it was not
+* processed in the first phase.
+*
+* When reordering the odd windows over the border, we must make
+* sure that no process row or column is involved in both the
+* first and the last window at the same time. This happens when
+* the total number of windows is odd, greater than one and equal
+* to the minumum process mesh dimension. Therefore the last odd
+* window may be reordered over the border at last.
+*
+ LASTWAIT = NMWIN2.GT.1 .AND. MOD(NMWIN2,2).EQ.1 .AND.
+ $ NMWIN2.EQ.MIN(NPROW,NPCOL)
+*
+ LAST = 0
+ 308 CONTINUE
+ IF( LASTWAIT ) THEN
+ IF( LAST.EQ.0 ) THEN
+ WIN0S = 1
+ WIN0E = 2
+ WINE = NMWIN2 - 1
+ ELSE
+ WIN0S = NMWIN2
+ WIN0E = NMWIN2
+ WINE = NMWIN2
+ END IF
+ ELSE
+ WIN0S = 1
+ WIN0E = 2
+ WINE = NMWIN2
+ END IF
+ DO 310 WINDOW0 = WIN0S, WIN0E
+ DO 320 WINDOW = WINDOW0, WINE, 2
+*
+* Define the process holding the down-right part of the
+* window.
+*
+ RSRC4 = IWORK(IRSRC+WINDOW-1)
+ CSRC4 = IWORK(ICSRC+WINDOW-1)
+*
+* Define the other processes in the group of four.
+*
+ RSRC3 = RSRC4
+ CSRC3 = MOD( CSRC4 - 1 + NPCOL, NPCOL )
+ RSRC2 = MOD( RSRC4 - 1 + NPROW, NPROW )
+ CSRC2 = CSRC4
+ RSRC1 = RSRC2
+ CSRC1 = CSRC3
+ IF( ( MYROW.EQ.RSRC1 .AND. MYCOL.EQ.CSRC1 ) .OR.
+ $ ( MYROW.EQ.RSRC2 .AND. MYCOL.EQ.CSRC2 ) .OR.
+ $ ( MYROW.EQ.RSRC3 .AND. MYCOL.EQ.CSRC3 ) .OR.
+ $ ( MYROW.EQ.RSRC4 .AND. MYCOL.EQ.CSRC4 ) ) THEN
+*
+* Compute the correct active window - for reordering
+* into a block that has not been active at all before,
+* we try to reorder as many of our eigenvalues over the
+* border as possible without knowing of the situation on
+* the other side - this may cause very few eigenvalues
+* to be reordered over the border this time (perhaps not
+* any) but this should be an initial problem. Anyway,
+* the bottom-right position of the block will be at
+* position LIHIC.
+*
+ IF( MYROW.EQ.RSRC4 .AND. MYCOL.EQ.CSRC4 ) THEN
+ LIHI4 = ( IWORK( ILILO + WINDOW - 1 ) +
+ $ IWORK( ILIHI + WINDOW - 1 ) ) / 2
+ LIHIC = MIN(LIHI4,(ICEIL(LIHI4,NB)-1)*NB+WNEICR)
+*
+* Fix LIHIC to avoid that bottom of window cuts
+* 2-by-2 block and make sure all processors in the
+* group knows about the correct value.
+*
+ IF( (.NOT. LIHIC.LE.NB) .AND. LIHIC.LT.N ) THEN
+ ILOC = INDXG2L( LIHIC+1, NB, MYROW,
+ $ DESCT( RSRC_ ), NPROW )
+ JLOC = INDXG2L( LIHIC, NB, MYCOL,
+ $ DESCT( CSRC_ ), NPCOL )
+ IF( T( (JLOC-1)*LLDT+ILOC ).NE.ZERO ) THEN
+ IF( MOD( LIHIC, NB ).EQ.1 .OR.
+ $ ( MOD( LIHIC, NB ).EQ.2 .AND.
+ $ SELECT(LIHIC-2).EQ.0 ) )
+ $ THEN
+ LIHIC = LIHIC + 1
+ ELSE
+ LIHIC = LIHIC - 1
+ END IF
+ END IF
+ END IF
+ IF( RSRC4.NE.RSRC1 .OR. CSRC4.NE.CSRC1 )
+ $ CALL IGESD2D( ICTXT, 1, 1, LIHIC, 1, RSRC1,
+ $ CSRC1 )
+ IF( RSRC4.NE.RSRC2 .OR. CSRC4.NE.CSRC2 )
+ $ CALL IGESD2D( ICTXT, 1, 1, LIHIC, 1, RSRC2,
+ $ CSRC2 )
+ IF( RSRC4.NE.RSRC3 .OR. CSRC4.NE.CSRC3 )
+ $ CALL IGESD2D( ICTXT, 1, 1, LIHIC, 1, RSRC3,
+ $ CSRC3 )
+ END IF
+ IF( MYROW.EQ.RSRC1 .AND. MYCOL.EQ.CSRC1 ) THEN
+ IF( RSRC4.NE.RSRC1 .OR. CSRC4.NE.CSRC1 )
+ $ CALL IGERV2D( ICTXT, 1, 1, LIHIC, 1, RSRC4,
+ $ CSRC4 )
+ END IF
+ IF( MYROW.EQ.RSRC2 .AND. MYCOL.EQ.CSRC2 ) THEN
+ IF( RSRC4.NE.RSRC2 .OR. CSRC4.NE.CSRC2 )
+ $ CALL IGERV2D( ICTXT, 1, 1, LIHIC, 1, RSRC4,
+ $ CSRC4 )
+ END IF
+ IF( MYROW.EQ.RSRC3 .AND. MYCOL.EQ.CSRC3 ) THEN
+ IF( RSRC4.NE.RSRC3 .OR. CSRC4.NE.CSRC3 )
+ $ CALL IGERV2D( ICTXT, 1, 1, LIHIC, 1, RSRC4,
+ $ CSRC4 )
+ END IF
+*
+* Avoid going over the border with the first window if
+* it resides in the block where the last global position
+* T(ILO,ILO) is or ILO has been updated to point to a
+* position right of T(LIHIC,LIHIC).
+*
+ SKIP1CR = WINDOW.EQ.1 .AND.
+ $ ICEIL(LIHIC,NB).LE.ICEIL(ILO,NB)
+*
+* Decide I, where to put top of window, such that top of
+* window does not cut 2-by-2 block. Make sure that we do
+* not end up in a situation where a 2-by-2 block
+* splitted on the border is left in its original place
+* -- this can cause infinite loops.
+* Remedy: make sure that the part of the window that
+* resides left to the border is at least of dimension
+* two (2) in case we have 2-by-2 blocks in top of the
+* cross border window.
+*
+* Also make sure all processors in the group knows about
+* the correct value of I. When skipping the crossborder
+* reordering, just set I = LIHIC.
+*
+ IF( .NOT. SKIP1CR ) THEN
+ IF( MYROW.EQ.RSRC1 .AND. MYCOL.EQ.CSRC1 ) THEN
+ IF( WINDOW.EQ.1 ) THEN
+ LIHI1 = ILO
+ ELSE
+ LIHI1 = IWORK( ILIHI + WINDOW - 2 )
+ END IF
+ I = MAX( LIHI1,
+ $ MIN( LIHIC-2*MOD(LIHIC,NB) + 1,
+ $ (ICEIL(LIHIC,NB)-1)*NB - 1 ) )
+ ILOC = INDXG2L( I, NB, MYROW, DESCT( RSRC_ ),
+ $ NPROW )
+ JLOC = INDXG2L( I-1, NB, MYCOL, DESCT( CSRC_ ),
+ $ NPCOL )
+ IF( T( (JLOC-1)*LLDT+ILOC ).NE.ZERO )
+ $ I = I - 1
+ IF( RSRC1.NE.RSRC4 .OR. CSRC1.NE.CSRC4 )
+ $ CALL IGESD2D( ICTXT, 1, 1, I, 1, RSRC4,
+ $ CSRC4 )
+ IF( RSRC1.NE.RSRC2 .OR. CSRC1.NE.CSRC2 )
+ $ CALL IGESD2D( ICTXT, 1, 1, I, 1, RSRC2,
+ $ CSRC2 )
+ IF( RSRC1.NE.RSRC3 .OR. CSRC1.NE.CSRC3 )
+ $ CALL IGESD2D( ICTXT, 1, 1, I, 1, RSRC3,
+ $ CSRC3 )
+ END IF
+ IF( MYROW.EQ.RSRC2 .AND. MYCOL.EQ.CSRC2 ) THEN
+ IF( RSRC1.NE.RSRC2 .OR. CSRC1.NE.CSRC2 )
+ $ CALL IGERV2D( ICTXT, 1, 1, I, 1, RSRC1,
+ $ CSRC1 )
+ END IF
+ IF( MYROW.EQ.RSRC3 .AND. MYCOL.EQ.CSRC3 ) THEN
+ IF( RSRC1.NE.RSRC3 .OR. CSRC1.NE.CSRC3 )
+ $ CALL IGERV2D( ICTXT, 1, 1, I, 1, RSRC1,
+ $ CSRC1 )
+ END IF
+ IF( MYROW.EQ.RSRC4 .AND. MYCOL.EQ.CSRC4 ) THEN
+ IF( RSRC1.NE.RSRC4 .OR. CSRC1.NE.CSRC4 )
+ $ CALL IGERV2D( ICTXT, 1, 1, I, 1, RSRC1,
+ $ CSRC1 )
+ END IF
+ ELSE
+ I = LIHIC
+ END IF
+*
+* Finalize computation of window size: active window is
+* now (I:LIHIC,I:LIHIC).
+*
+ NWIN = LIHIC - I + 1
+ KS = 0
+*
+* Skip rest of this part if appropriate.
+*
+ IF( SKIP1CR ) GO TO 360
+*
+* Divide workspace -- put active window in
+* WORK(IPW2:IPW2+NWIN**2-1) and orthogonal
+* transformations in WORK(IPW3:...).
+*
+ CALL SLASET( 'All', NWIN, NWIN, ZERO, ZERO,
+ $ WORK( IPW2 ), NWIN )
+*
+ PITRAF = IPIW
+ IPW3 = IPW2 + NWIN*NWIN
+ PDTRAF = IPW3
+*
+* Exchange the current view of SELECT for the active
+* window between process 1 and 4 to make sure that
+* exactly the same job is performed for both processes.
+*
+ IF( RSRC1.NE.RSRC4 .OR. CSRC1.NE.CSRC4 ) THEN
+ ILEN4 = MOD(LIHIC,NB)
+ SELI4 = ICEIL(I,NB)*NB+1
+ ILEN1 = NWIN - ILEN4
+ IF( MYROW.EQ.RSRC1 .AND. MYCOL.EQ.CSRC1 ) THEN
+ CALL IGESD2D( ICTXT, ILEN1, 1, SELECT(I),
+ $ ILEN1, RSRC4, CSRC4 )
+ CALL IGERV2D( ICTXT, ILEN4, 1, SELECT(SELI4),
+ $ ILEN4, RSRC4, CSRC4 )
+ END IF
+ IF( MYROW.EQ.RSRC4 .AND. MYCOL.EQ.CSRC4 ) THEN
+ CALL IGESD2D( ICTXT, ILEN4, 1, SELECT(SELI4),
+ $ ILEN4, RSRC1, CSRC1 )
+ CALL IGERV2D( ICTXT, ILEN1, 1, SELECT(I),
+ $ ILEN1, RSRC1, CSRC1 )
+ END IF
+ END IF
+*
+* Form the active window by a series of point-to-point
+* sends and receives.
+*
+ DIM1 = NB - MOD(I-1,NB)
+ DIM4 = NWIN - DIM1
+ IF( MYROW.EQ.RSRC1 .AND. MYCOL.EQ.CSRC1 ) THEN
+ ILOC = INDXG2L( I, NB, MYROW, DESCT( RSRC_ ),
+ $ NPROW )
+ JLOC = INDXG2L( I, NB, MYCOL, DESCT( CSRC_ ),
+ $ NPCOL )
+ CALL SLAMOV( 'All', DIM1, DIM1,
+ $ T((JLOC-1)*LLDT+ILOC), LLDT, WORK(IPW2),
+ $ NWIN )
+ IF( RSRC1.NE.RSRC4 .OR. CSRC1.NE.CSRC4 ) THEN
+ CALL SGESD2D( ICTXT, DIM1, DIM1,
+ $ WORK(IPW2), NWIN, RSRC4, CSRC4 )
+ CALL SGERV2D( ICTXT, DIM4, DIM4,
+ $ WORK(IPW2+DIM1*NWIN+DIM1), NWIN, RSRC4,
+ $ CSRC4 )
+ END IF
+ END IF
+ IF( MYROW.EQ.RSRC4 .AND. MYCOL.EQ.CSRC4 ) THEN
+ ILOC = INDXG2L( I+DIM1, NB, MYROW, DESCT( RSRC_ ),
+ $ NPROW )
+ JLOC = INDXG2L( I+DIM1, NB, MYCOL, DESCT( CSRC_ ),
+ $ NPCOL )
+ CALL SLAMOV( 'All', DIM4, DIM4,
+ $ T((JLOC-1)*LLDT+ILOC), LLDT,
+ $ WORK(IPW2+DIM1*NWIN+DIM1), NWIN )
+ IF( RSRC4.NE.RSRC1 .OR. CSRC4.NE.CSRC1 ) THEN
+ CALL SGESD2D( ICTXT, DIM4, DIM4,
+ $ WORK(IPW2+DIM1*NWIN+DIM1), NWIN, RSRC1,
+ $ CSRC1 )
+ CALL SGERV2D( ICTXT, DIM1, DIM1,
+ $ WORK(IPW2), NWIN, RSRC1, CSRC1 )
+ END IF
+ END IF
+ IF( MYROW.EQ.RSRC2 .AND. MYCOL.EQ.CSRC2 ) THEN
+ ILOC = INDXG2L( I, NB, MYROW, DESCT( RSRC_ ),
+ $ NPROW )
+ JLOC = INDXG2L( I+DIM1, NB, MYCOL, DESCT( CSRC_ ),
+ $ NPCOL )
+ CALL SLAMOV( 'All', DIM1, DIM4,
+ $ T((JLOC-1)*LLDT+ILOC), LLDT,
+ $ WORK(IPW2+DIM1*NWIN), NWIN )
+ IF( RSRC2.NE.RSRC1 .OR. CSRC2.NE.CSRC1 ) THEN
+ CALL SGESD2D( ICTXT, DIM1, DIM4,
+ $ WORK(IPW2+DIM1*NWIN), NWIN, RSRC1, CSRC1 )
+ END IF
+ END IF
+ IF( MYROW.EQ.RSRC2 .AND. MYCOL.EQ.CSRC2 ) THEN
+ IF( RSRC2.NE.RSRC4 .OR. CSRC2.NE.CSRC4 ) THEN
+ CALL SGESD2D( ICTXT, DIM1, DIM4,
+ $ WORK(IPW2+DIM1*NWIN), NWIN, RSRC4, CSRC4 )
+ END IF
+ END IF
+ IF( MYROW.EQ.RSRC3 .AND. MYCOL.EQ.CSRC3 ) THEN
+ ILOC = INDXG2L( I+DIM1, NB, MYROW, DESCT( RSRC_ ),
+ $ NPROW )
+ JLOC = INDXG2L( I+DIM1-1, NB, MYCOL,
+ $ DESCT( CSRC_ ), NPCOL )
+ CALL SLAMOV( 'All', 1, 1,
+ $ T((JLOC-1)*LLDT+ILOC), LLDT,
+ $ WORK(IPW2+(DIM1-1)*NWIN+DIM1), NWIN )
+ IF( RSRC3.NE.RSRC1 .OR. CSRC3.NE.CSRC1 ) THEN
+ CALL SGESD2D( ICTXT, 1, 1,
+ $ WORK(IPW2+(DIM1-1)*NWIN+DIM1), NWIN,
+ $ RSRC1, CSRC1 )
+ END IF
+ END IF
+ IF( MYROW.EQ.RSRC3 .AND. MYCOL.EQ.CSRC3 ) THEN
+ IF( RSRC3.NE.RSRC4 .OR. CSRC3.NE.CSRC4 ) THEN
+ CALL SGESD2D( ICTXT, 1, 1,
+ $ WORK(IPW2+(DIM1-1)*NWIN+DIM1), NWIN,
+ $ RSRC4, CSRC4 )
+ END IF
+ END IF
+ IF( MYROW.EQ.RSRC1 .AND. MYCOL.EQ.CSRC1 ) THEN
+ IF( RSRC1.NE.RSRC2 .OR. CSRC1.NE.CSRC2 ) THEN
+ CALL SGERV2D( ICTXT, DIM1, DIM4,
+ $ WORK(IPW2+DIM1*NWIN), NWIN, RSRC2,
+ $ CSRC2 )
+ END IF
+ IF( RSRC1.NE.RSRC3 .OR. CSRC1.NE.CSRC3 ) THEN
+ CALL SGERV2D( ICTXT, 1, 1,
+ $ WORK(IPW2+(DIM1-1)*NWIN+DIM1), NWIN,
+ $ RSRC3, CSRC3 )
+ END IF
+ END IF
+ IF( MYROW.EQ.RSRC4 .AND. MYCOL.EQ.CSRC4 ) THEN
+ IF( RSRC4.NE.RSRC2 .OR. CSRC4.NE.CSRC2 ) THEN
+ CALL SGERV2D( ICTXT, DIM1, DIM4,
+ $ WORK(IPW2+DIM1*NWIN), NWIN, RSRC2,
+ $ CSRC2 )
+ END IF
+ IF( RSRC4.NE.RSRC3 .OR. CSRC4.NE.CSRC3 ) THEN
+ CALL SGERV2D( ICTXT, 1, 1,
+ $ WORK(IPW2+(DIM1-1)*NWIN+DIM1), NWIN,
+ $ RSRC3, CSRC3 )
+ END IF
+ END IF
+*
+* Compute the reordering (just as in the total local
+* case) and accumulate the transformations (ONLY
+* ON-DIAGONAL PROCESSES).
+*
+ IF( ( MYROW.EQ.RSRC1 .AND. MYCOL.EQ.CSRC1 ) .OR.
+ $ ( MYROW.EQ.RSRC4 .AND. MYCOL.EQ.CSRC4 ) ) THEN
+ PAIR = .FALSE.
+ DO 330 K = I, LIHIC
+ IF( PAIR ) THEN
+ PAIR = .FALSE.
+ ELSE
+ SWAP = SELECT( K ).NE.0
+ IF( K.LT.LIHIC ) THEN
+ ELEM = WORK(IPW2+(K-I)*NWIN+K-I+1)
+ IF( ELEM.NE.ZERO )
+ $ PAIR = .TRUE.
+ END IF
+ IF( SWAP ) THEN
+ KS = KS + 1
+*
+* Swap the K-th block to position I+KS-1.
+*
+ IERR = 0
+ KK = K - I + 1
+ KKS = KS
+ IF( KK.NE.KS ) THEN
+ NITRAF = LIWORK - PITRAF + 1
+ NDTRAF = LWORK - PDTRAF + 1
+ CALL BSTREXC( NWIN, WORK(IPW2), NWIN,
+ $ KK, KKS, NITRAF, IWORK( PITRAF ),
+ $ NDTRAF, WORK( PDTRAF ),
+ $ WORK(IPW1), IERR )
+ PITRAF = PITRAF + NITRAF
+ PDTRAF = PDTRAF + NDTRAF
+*
+* Update array SELECT.
+*
+ IF ( PAIR ) THEN
+ DO 340 J = I+KK-1, I+KKS, -1
+ SELECT(J+1) = SELECT(J-1)
+ 340 CONTINUE
+ SELECT(I+KKS-1) = 1
+ SELECT(I+KKS) = 1
+ ELSE
+ DO 350 J = I+KK-1, I+KKS, -1
+ SELECT(J) = SELECT(J-1)
+ 350 CONTINUE
+ SELECT(I+KKS-1) = 1
+ END IF
+*
+ IF ( IERR.EQ.1 .OR. IERR.EQ.2 ) THEN
+*
+ IF ( IERR.EQ.2 ) THEN
+ SELECT( I+KKS-3 ) = 1
+ SELECT( I+KKS-1 ) = 0
+ KKS = KKS + 1
+ END IF
+*
+ GO TO 360
+ END IF
+ KS = KKS
+ END IF
+ IF( PAIR )
+ $ KS = KS + 1
+ END IF
+ END IF
+ 330 CONTINUE
+ END IF
+ 360 CONTINUE
+*
+* Save information about the reordering.
+*
+ IF( ( MYROW.EQ.RSRC1 .AND. MYCOL.EQ.CSRC1 ) .OR.
+ $ ( MYROW.EQ.RSRC4 .AND. MYCOL.EQ.CSRC4 ) ) THEN
+ IBUFF( 1 ) = I
+ IBUFF( 2 ) = NWIN
+ IBUFF( 3 ) = PITRAF
+ IBUFF( 4 ) = KS
+ IBUFF( 5 ) = PDTRAF
+ IBUFF( 6 ) = NDTRAF
+ ILEN = PITRAF - IPIW + 1
+ DLEN = PDTRAF - IPW3 + 1
+ IBUFF( 7 ) = ILEN
+ IBUFF( 8 ) = DLEN
+*
+* Put reordered data back into global matrix if a
+* reordering took place.
+*
+ IF( .NOT. SKIP1CR ) THEN
+ IF( MYROW.EQ.RSRC1 .AND. MYCOL.EQ.CSRC1 ) THEN
+ ILOC = INDXG2L( I, NB, MYROW, DESCT( RSRC_ ),
+ $ NPROW )
+ JLOC = INDXG2L( I, NB, MYCOL, DESCT( CSRC_ ),
+ $ NPCOL )
+ CALL SLAMOV( 'All', DIM1, DIM1, WORK(IPW2),
+ $ NWIN, T((JLOC-1)*LLDT+ILOC), LLDT )
+ END IF
+ IF( MYROW.EQ.RSRC4 .AND. MYCOL.EQ.CSRC4 ) THEN
+ ILOC = INDXG2L( I+DIM1, NB, MYROW,
+ $ DESCT( RSRC_ ), NPROW )
+ JLOC = INDXG2L( I+DIM1, NB, MYCOL,
+ $ DESCT( CSRC_ ), NPCOL )
+ CALL SLAMOV( 'All', DIM4, DIM4,
+ $ WORK(IPW2+DIM1*NWIN+DIM1), NWIN,
+ $ T((JLOC-1)*LLDT+ILOC), LLDT )
+ END IF
+ END IF
+ END IF
+*
+* Break if appropriate -- IBUFF(3:8) may now contain
+* nonsens, but that's no problem. The processors outside
+* the cross border group only needs to know about I and
+* NWIN to get a correct value of SKIP1CR (see below) and
+* to skip the cross border updates if necessary.
+*
+ IF( WINDOW.EQ.1 .AND. SKIP1CR ) GO TO 325
+*
+* Return reordered data to process 2 and 3.
+*
+ IF( MYROW.EQ.RSRC1 .AND. MYCOL.EQ.CSRC1 ) THEN
+ IF( RSRC1.NE.RSRC3 .OR. CSRC1.NE.CSRC3 ) THEN
+ CALL SGESD2D( ICTXT, 1, 1,
+ $ WORK( IPW2+(DIM1-1)*NWIN+DIM1 ), NWIN,
+ $ RSRC3, CSRC3 )
+ END IF
+ END IF
+ IF( MYROW.EQ.RSRC4 .AND. MYCOL.EQ.CSRC4 ) THEN
+ IF( RSRC4.NE.RSRC2 .OR. CSRC4.NE.CSRC2 ) THEN
+ CALL SGESD2D( ICTXT, DIM1, DIM4,
+ $ WORK( IPW2+DIM1*NWIN), NWIN, RSRC2,
+ $ CSRC2 )
+ END IF
+ END IF
+ IF( MYROW.EQ.RSRC2 .AND. MYCOL.EQ.CSRC2 ) THEN
+ ILOC = INDXG2L( I, NB, MYROW, DESCT( RSRC_ ),
+ $ NPROW )
+ JLOC = INDXG2L( I+DIM1, NB, MYCOL,
+ $ DESCT( CSRC_ ), NPCOL )
+ IF( RSRC2.NE.RSRC4 .OR. CSRC2.NE.CSRC4 ) THEN
+ CALL SGERV2D( ICTXT, DIM1, DIM4,
+ $ WORK(IPW2+DIM1*NWIN), NWIN, RSRC4, CSRC4 )
+ END IF
+ CALL SLAMOV( 'All', DIM1, DIM4,
+ $ WORK( IPW2+DIM1*NWIN ), NWIN,
+ $ T((JLOC-1)*LLDT+ILOC), LLDT )
+ END IF
+ IF( MYROW.EQ.RSRC3 .AND. MYCOL.EQ.CSRC3 ) THEN
+ ILOC = INDXG2L( I+DIM1, NB, MYROW,
+ $ DESCT( RSRC_ ), NPROW )
+ JLOC = INDXG2L( I+DIM1-1, NB, MYCOL,
+ $ DESCT( CSRC_ ), NPCOL )
+ IF( RSRC3.NE.RSRC1 .OR. CSRC3.NE.CSRC1 ) THEN
+ CALL SGERV2D( ICTXT, 1, 1,
+ $ WORK( IPW2+(DIM1-1)*NWIN+DIM1 ), NWIN,
+ $ RSRC1, CSRC1 )
+ END IF
+ T((JLOC-1)*LLDT+ILOC) =
+ $ WORK( IPW2+(DIM1-1)*NWIN+DIM1 )
+ END IF
+ END IF
+*
+ 325 CONTINUE
+*
+ 320 CONTINUE
+*
+* For the crossborder updates, we use the same directions as
+* in the local reordering case above.
+*
+ DO 2222 DIR = 1, 2
+*
+* Broadcast information about the reordering.
+*
+ DO 321 WINDOW = WINDOW0, WINE, 2
+ RSRC4 = IWORK(IRSRC+WINDOW-1)
+ CSRC4 = IWORK(ICSRC+WINDOW-1)
+ RSRC1 = MOD( RSRC4 - 1 + NPROW, NPROW )
+ CSRC1 = MOD( CSRC4 - 1 + NPCOL, NPCOL )
+ IF( MYROW.EQ.RSRC1 .AND. MYCOL.EQ.CSRC1 ) THEN
+ IF( NPCOL.GT.1 .AND. DIR.EQ.1 )
+ $ CALL IGEBS2D( ICTXT, 'Row', TOP, 8, 1,
+ $ IBUFF, 8 )
+ IF( NPROW.GT.1 .AND. DIR.EQ.2 )
+ $ CALL IGEBS2D( ICTXT, 'Col', TOP, 8, 1,
+ $ IBUFF, 8 )
+ SKIP1CR = WINDOW.EQ.1 .AND.
+ $ ICEIL(LIHIC,NB).LE.ICEIL(ILO,NB)
+ ELSEIF( MYROW.EQ.RSRC1 .OR. MYCOL.EQ.CSRC1 ) THEN
+ IF( NPCOL.GT.1 .AND. DIR.EQ.1 .AND.
+ $ MYROW.EQ.RSRC1 ) THEN
+ CALL IGEBR2D( ICTXT, 'Row', TOP, 8, 1,
+ $ IBUFF, 8, RSRC1, CSRC1 )
+ I = IBUFF( 1 )
+ NWIN = IBUFF( 2 )
+ PITRAF = IBUFF( 3 )
+ KS = IBUFF( 4 )
+ PDTRAF = IBUFF( 5 )
+ NDTRAF = IBUFF( 6 )
+ ILEN = IBUFF( 7 )
+ DLEN = IBUFF( 8 )
+ BUFFLEN = ILEN + DLEN
+ IPW3 = IPW2 + NWIN*NWIN
+ DIM1 = NB - MOD(I-1,NB)
+ DIM4 = NWIN - DIM1
+ LIHIC = NWIN + I - 1
+ SKIP1CR = WINDOW.EQ.1 .AND.
+ $ ICEIL(LIHIC,NB).LE.ICEIL(ILO,NB)
+ END IF
+ IF( NPROW.GT.1 .AND. DIR.EQ.2 .AND.
+ $ MYCOL.EQ.CSRC1 ) THEN
+ CALL IGEBR2D( ICTXT, 'Col', TOP, 8, 1,
+ $ IBUFF, 8, RSRC1, CSRC1 )
+ I = IBUFF( 1 )
+ NWIN = IBUFF( 2 )
+ PITRAF = IBUFF( 3 )
+ KS = IBUFF( 4 )
+ PDTRAF = IBUFF( 5 )
+ NDTRAF = IBUFF( 6 )
+ ILEN = IBUFF( 7 )
+ DLEN = IBUFF( 8 )
+ BUFFLEN = ILEN + DLEN
+ IPW3 = IPW2 + NWIN*NWIN
+ DIM1 = NB - MOD(I-1,NB)
+ DIM4 = NWIN - DIM1
+ LIHIC = NWIN + I - 1
+ SKIP1CR = WINDOW.EQ.1 .AND.
+ $ ICEIL(LIHIC,NB).LE.ICEIL(ILO,NB)
+ END IF
+ END IF
+ IF( RSRC1.NE.RSRC4 ) THEN
+ IF( MYROW.EQ.RSRC4 .AND. MYCOL.EQ.CSRC4 ) THEN
+ IF( NPCOL.GT.1 .AND. DIR.EQ.1 )
+ $ CALL IGEBS2D( ICTXT, 'Row', TOP, 8, 1,
+ $ IBUFF, 8 )
+ SKIP1CR = WINDOW.EQ.1 .AND.
+ $ ICEIL(LIHIC,NB).LE.ICEIL(ILO,NB)
+ ELSEIF( MYROW.EQ.RSRC4 ) THEN
+ IF( NPCOL.GT.1 .AND. DIR.EQ.1 ) THEN
+ CALL IGEBR2D( ICTXT, 'Row', TOP, 8, 1,
+ $ IBUFF, 8, RSRC4, CSRC4 )
+ I = IBUFF( 1 )
+ NWIN = IBUFF( 2 )
+ PITRAF = IBUFF( 3 )
+ KS = IBUFF( 4 )
+ PDTRAF = IBUFF( 5 )
+ NDTRAF = IBUFF( 6 )
+ ILEN = IBUFF( 7 )
+ DLEN = IBUFF( 8 )
+ BUFFLEN = ILEN + DLEN
+ IPW3 = IPW2 + NWIN*NWIN
+ DIM1 = NB - MOD(I-1,NB)
+ DIM4 = NWIN - DIM1
+ LIHIC = NWIN + I - 1
+ SKIP1CR = WINDOW.EQ.1 .AND.
+ $ ICEIL(LIHIC,NB).LE.ICEIL(ILO,NB)
+ END IF
+ END IF
+ END IF
+ IF( CSRC1.NE.CSRC4 ) THEN
+ IF( MYROW.EQ.RSRC4 .AND. MYCOL.EQ.CSRC4 ) THEN
+ IF( NPROW.GT.1 .AND. DIR.EQ.2 )
+ $ CALL IGEBS2D( ICTXT, 'Col', TOP, 8, 1,
+ $ IBUFF, 8 )
+ SKIP1CR = WINDOW.EQ.1 .AND.
+ $ ICEIL(LIHIC,NB).LE.ICEIL(ILO,NB)
+ ELSEIF( MYCOL.EQ.CSRC4 ) THEN
+ IF( NPROW.GT.1 .AND. DIR.EQ.2 ) THEN
+ CALL IGEBR2D( ICTXT, 'Col', TOP, 8, 1,
+ $ IBUFF, 8, RSRC4, CSRC4 )
+ I = IBUFF( 1 )
+ NWIN = IBUFF( 2 )
+ PITRAF = IBUFF( 3 )
+ KS = IBUFF( 4 )
+ PDTRAF = IBUFF( 5 )
+ NDTRAF = IBUFF( 6 )
+ ILEN = IBUFF( 7 )
+ DLEN = IBUFF( 8 )
+ BUFFLEN = ILEN + DLEN
+ IPW3 = IPW2 + NWIN*NWIN
+ DIM1 = NB - MOD(I-1,NB)
+ DIM4 = NWIN - DIM1
+ LIHIC = NWIN + I - 1
+ SKIP1CR = WINDOW.EQ.1 .AND.
+ $ ICEIL(LIHIC,NB).LE.ICEIL(ILO,NB)
+ END IF
+ END IF
+ END IF
+*
+* Skip rest of broadcasts and updates if appropriate.
+*
+ IF( SKIP1CR ) GO TO 326
+*
+* Broadcast the orthogonal transformations.
+*
+ IF( MYROW.EQ.RSRC1 .AND. MYCOL.EQ.CSRC1 ) THEN
+ BUFFER = PDTRAF
+ BUFFLEN = DLEN + ILEN
+ IF( (NPROW.GT.1 .AND. DIR.EQ.2) .OR.
+ $ (NPCOL.GT.1 .AND. DIR.EQ.1) ) THEN
+ DO 370 INDX = 1, ILEN
+ WORK( BUFFER+INDX-1 ) =
+ $ FLOAT( IWORK(IPIW+INDX-1) )
+ 370 CONTINUE
+ CALL SLAMOV( 'All', DLEN, 1, WORK( IPW3 ),
+ $ DLEN, WORK(BUFFER+ILEN), DLEN )
+ END IF
+ IF( NPCOL.GT.1 .AND. DIR.EQ.1 ) THEN
+ CALL SGEBS2D( ICTXT, 'Row', TOP, BUFFLEN, 1,
+ $ WORK(BUFFER), BUFFLEN )
+ END IF
+ IF( NPROW.GT.1 .AND. DIR.EQ.2 ) THEN
+ CALL SGEBS2D( ICTXT, 'Col', TOP, BUFFLEN, 1,
+ $ WORK(BUFFER), BUFFLEN )
+ END IF
+ ELSEIF( MYROW.EQ.RSRC1 .OR. MYCOL.EQ.CSRC1 ) THEN
+ IF( NPCOL.GT.1 .AND. DIR.EQ.1 .AND.
+ $ MYROW.EQ.RSRC1 ) THEN
+ BUFFER = PDTRAF
+ BUFFLEN = DLEN + ILEN
+ CALL SGEBR2D( ICTXT, 'Row', TOP, BUFFLEN, 1,
+ $ WORK(BUFFER), BUFFLEN, RSRC1, CSRC1 )
+ END IF
+ IF( NPROW.GT.1 .AND. DIR.EQ.2 .AND.
+ $ MYCOL.EQ.CSRC1 ) THEN
+ BUFFER = PDTRAF
+ BUFFLEN = DLEN + ILEN
+ CALL SGEBR2D( ICTXT, 'Col', TOP, BUFFLEN, 1,
+ $ WORK(BUFFER), BUFFLEN, RSRC1, CSRC1 )
+ END IF
+ IF( (NPCOL.GT.1.AND.DIR.EQ.1.AND.MYROW.EQ.RSRC1)
+ $ .OR. (NPROW.GT.1.AND.DIR.EQ.2.AND.
+ $ MYCOL.EQ.CSRC1) ) THEN
+ DO 380 INDX = 1, ILEN
+ IWORK(IPIW+INDX-1) =
+ $ INT( WORK( BUFFER+INDX-1 ) )
+ 380 CONTINUE
+ CALL SLAMOV( 'All', DLEN, 1,
+ $ WORK( BUFFER+ILEN ), DLEN,
+ $ WORK( IPW3 ), DLEN )
+ END IF
+ END IF
+ IF( RSRC1.NE.RSRC4 ) THEN
+ IF( MYROW.EQ.RSRC4 .AND. MYCOL.EQ.CSRC4 ) THEN
+ BUFFER = PDTRAF
+ BUFFLEN = DLEN + ILEN
+ IF( NPCOL.GT.1 .AND. DIR.EQ.1 ) THEN
+ DO 390 INDX = 1, ILEN
+ WORK( BUFFER+INDX-1 ) =
+ $ FLOAT( IWORK(IPIW+INDX-1) )
+ 390 CONTINUE
+ CALL SLAMOV( 'All', DLEN, 1, WORK( IPW3 ),
+ $ DLEN, WORK(BUFFER+ILEN), DLEN )
+ CALL SGEBS2D( ICTXT, 'Row', TOP, BUFFLEN,
+ $ 1, WORK(BUFFER), BUFFLEN )
+ END IF
+ ELSEIF( MYROW.EQ.RSRC4 .AND. DIR.EQ.1 .AND.
+ $ NPCOL.GT.1 ) THEN
+ BUFFER = PDTRAF
+ BUFFLEN = DLEN + ILEN
+ CALL SGEBR2D( ICTXT, 'Row', TOP, BUFFLEN,
+ $ 1, WORK(BUFFER), BUFFLEN, RSRC4, CSRC4 )
+ DO 400 INDX = 1, ILEN
+ IWORK(IPIW+INDX-1) =
+ $ INT( WORK( BUFFER+INDX-1 ) )
+ 400 CONTINUE
+ CALL SLAMOV( 'All', DLEN, 1,
+ $ WORK( BUFFER+ILEN ), DLEN,
+ $ WORK( IPW3 ), DLEN )
+ END IF
+ END IF
+ IF( CSRC1.NE.CSRC4 ) THEN
+ IF( MYROW.EQ.RSRC4 .AND. MYCOL.EQ.CSRC4 ) THEN
+ BUFFER = PDTRAF
+ BUFFLEN = DLEN + ILEN
+ IF( NPROW.GT.1 .AND. DIR.EQ.2 ) THEN
+ DO 395 INDX = 1, ILEN
+ WORK( BUFFER+INDX-1 ) =
+ $ FLOAT( IWORK(IPIW+INDX-1) )
+ 395 CONTINUE
+ CALL SLAMOV( 'All', DLEN, 1, WORK( IPW3 ),
+ $ DLEN, WORK(BUFFER+ILEN), DLEN )
+ CALL SGEBS2D( ICTXT, 'Col', TOP, BUFFLEN,
+ $ 1, WORK(BUFFER), BUFFLEN )
+ END IF
+ ELSEIF( MYCOL.EQ.CSRC4 .AND. DIR.EQ.2 .AND.
+ $ NPROW.GT.1 ) THEN
+ BUFFER = PDTRAF
+ BUFFLEN = DLEN + ILEN
+ CALL SGEBR2D( ICTXT, 'Col', TOP, BUFFLEN, 1,
+ $ WORK(BUFFER), BUFFLEN, RSRC4, CSRC4 )
+ DO 402 INDX = 1, ILEN
+ IWORK(IPIW+INDX-1) =
+ $ INT( WORK( BUFFER+INDX-1 ) )
+ 402 CONTINUE
+ CALL SLAMOV( 'All', DLEN, 1,
+ $ WORK( BUFFER+ILEN ), DLEN,
+ $ WORK( IPW3 ), DLEN )
+ END IF
+ END IF
+*
+ 326 CONTINUE
+*
+ 321 CONTINUE
+*
+* Compute crossborder updates.
+*
+ DO 322 WINDOW = WINDOW0, WINE, 2
+ IF( WINDOW.EQ.1 .AND. SKIP1CR ) GO TO 327
+ RSRC4 = IWORK(IRSRC+WINDOW-1)
+ CSRC4 = IWORK(ICSRC+WINDOW-1)
+ RSRC1 = MOD( RSRC4 - 1 + NPROW, NPROW )
+ CSRC1 = MOD( CSRC4 - 1 + NPCOL, NPCOL )
+*
+* Prepare workspaces for updates:
+* IPW3 holds now the orthogonal transformations
+* IPW4 holds the explicit orthogonal matrix, if formed
+* IPW5 holds the crossborder block column of T
+* IPW6 holds the crossborder block row of T
+* IPW7 holds the crossborder block column of Q
+* (if WANTQ=.TRUE.)
+* IPW8 points to the leftover workspace used as lhs in
+* matrix multiplications
+*
+ IF( ((MYCOL.EQ.CSRC1.OR.MYCOL.EQ.CSRC4).AND.DIR.EQ.2)
+ $ .OR. ((MYROW.EQ.RSRC1.OR.MYROW.EQ.RSRC4).AND.
+ $ DIR.EQ.1)) THEN
+ IPW4 = BUFFER
+ IF( DIR.EQ.2 ) THEN
+ IF( WANTQ ) THEN
+ QROWS = NUMROC( N, NB, MYROW, DESCQ( RSRC_ ),
+ $ NPROW )
+ ELSE
+ QROWS = 0
+ END IF
+ TROWS = NUMROC( I-1, NB, MYROW, DESCT( RSRC_ ),
+ $ NPROW )
+ ELSE
+ QROWS = 0
+ TROWS = 0
+ END IF
+ IF( DIR.EQ.1 ) THEN
+ TCOLS = NUMROC( N - (I+DIM1-1), NB, MYCOL,
+ $ CSRC4, NPCOL )
+ IF( MYCOL.EQ.CSRC4 ) TCOLS = TCOLS - DIM4
+ ELSE
+ TCOLS = 0
+ END IF
+ IPW5 = IPW4 + NWIN*NWIN
+ IPW6 = IPW5 + TROWS * NWIN
+ IF( WANTQ ) THEN
+ IPW7 = IPW6 + NWIN * TCOLS
+ IPW8 = IPW7 + QROWS * NWIN
+ ELSE
+ IPW8 = IPW6 + NWIN * TCOLS
+ END IF
+ END IF
+*
+* Let each process row and column involved in the updates
+* exchange data in T and Q with their neighbours.
+*
+ IF( DIR.EQ.2 ) THEN
+ IF( MYCOL.EQ.CSRC1 .OR. MYCOL.EQ.CSRC4 ) THEN
+ DO 410 INDX = 1, NPROW
+ IF( MYCOL.EQ.CSRC1 ) THEN
+ CALL INFOG2L( 1+(INDX-1)*NB, I, DESCT,
+ $ NPROW, NPCOL, MYROW, MYCOL, ILOC,
+ $ JLOC1, RSRC, CSRC1 )
+ IF( MYROW.EQ.RSRC ) THEN
+ CALL SLAMOV( 'All', TROWS, DIM1,
+ $ T((JLOC1-1)*LLDT+ILOC), LLDT,
+ $ WORK(IPW5), TROWS )
+ IF( NPCOL.GT.1 ) THEN
+ EAST = MOD( MYCOL + 1, NPCOL )
+ CALL SGESD2D( ICTXT, TROWS, DIM1,
+ $ WORK(IPW5), TROWS, RSRC,
+ $ EAST )
+ CALL SGERV2D( ICTXT, TROWS, DIM4,
+ $ WORK(IPW5+TROWS*DIM1), TROWS,
+ $ RSRC, EAST )
+ END IF
+ END IF
+ END IF
+ IF( MYCOL.EQ.CSRC4 ) THEN
+ CALL INFOG2L( 1+(INDX-1)*NB, I+DIM1,
+ $ DESCT, NPROW, NPCOL, MYROW, MYCOL,
+ $ ILOC, JLOC4, RSRC, CSRC4 )
+ IF( MYROW.EQ.RSRC ) THEN
+ CALL SLAMOV( 'All', TROWS, DIM4,
+ $ T((JLOC4-1)*LLDT+ILOC), LLDT,
+ $ WORK(IPW5+TROWS*DIM1), TROWS )
+ IF( NPCOL.GT.1 ) THEN
+ WEST = MOD( MYCOL-1+NPCOL, NPCOL )
+ CALL SGESD2D( ICTXT, TROWS, DIM4,
+ $ WORK(IPW5+TROWS*DIM1), TROWS,
+ $ RSRC, WEST )
+ CALL SGERV2D( ICTXT, TROWS, DIM1,
+ $ WORK(IPW5), TROWS, RSRC,
+ $ WEST )
+ END IF
+ END IF
+ END IF
+ 410 CONTINUE
+ END IF
+ END IF
+*
+ IF( DIR.EQ.1 ) THEN
+ IF( MYROW.EQ.RSRC1 .OR. MYROW.EQ.RSRC4 ) THEN
+ DO 420 INDX = 1, NPCOL
+ IF( MYROW.EQ.RSRC1 ) THEN
+ IF( INDX.EQ.1 ) THEN
+ CALL INFOG2L( I, LIHIC+1, DESCT, NPROW,
+ $ NPCOL, MYROW, MYCOL, ILOC1, JLOC,
+ $ RSRC1, CSRC )
+ ELSE
+ CALL INFOG2L( I,
+ $ (ICEIL(LIHIC,NB)+(INDX-2))*NB+1,
+ $ DESCT, NPROW, NPCOL, MYROW, MYCOL,
+ $ ILOC1, JLOC, RSRC1, CSRC )
+ END IF
+ IF( MYCOL.EQ.CSRC ) THEN
+ CALL SLAMOV( 'All', DIM1, TCOLS,
+ $ T((JLOC-1)*LLDT+ILOC1), LLDT,
+ $ WORK(IPW6), NWIN )
+ IF( NPROW.GT.1 ) THEN
+ SOUTH = MOD( MYROW + 1, NPROW )
+ CALL SGESD2D( ICTXT, DIM1, TCOLS,
+ $ WORK(IPW6), NWIN, SOUTH,
+ $ CSRC )
+ CALL SGERV2D( ICTXT, DIM4, TCOLS,
+ $ WORK(IPW6+DIM1), NWIN, SOUTH,
+ $ CSRC )
+ END IF
+ END IF
+ END IF
+ IF( MYROW.EQ.RSRC4 ) THEN
+ IF( INDX.EQ.1 ) THEN
+ CALL INFOG2L( I+DIM1, LIHIC+1, DESCT,
+ $ NPROW, NPCOL, MYROW, MYCOL, ILOC4,
+ $ JLOC, RSRC4, CSRC )
+ ELSE
+ CALL INFOG2L( I+DIM1,
+ $ (ICEIL(LIHIC,NB)+(INDX-2))*NB+1,
+ $ DESCT, NPROW, NPCOL, MYROW, MYCOL,
+ $ ILOC4, JLOC, RSRC4, CSRC )
+ END IF
+ IF( MYCOL.EQ.CSRC ) THEN
+ CALL SLAMOV( 'All', DIM4, TCOLS,
+ $ T((JLOC-1)*LLDT+ILOC4), LLDT,
+ $ WORK(IPW6+DIM1), NWIN )
+ IF( NPROW.GT.1 ) THEN
+ NORTH = MOD( MYROW-1+NPROW, NPROW )
+ CALL SGESD2D( ICTXT, DIM4, TCOLS,
+ $ WORK(IPW6+DIM1), NWIN, NORTH,
+ $ CSRC )
+ CALL SGERV2D( ICTXT, DIM1, TCOLS,
+ $ WORK(IPW6), NWIN, NORTH,
+ $ CSRC )
+ END IF
+ END IF
+ END IF
+ 420 CONTINUE
+ END IF
+ END IF
+*
+ IF( DIR.EQ.2 ) THEN
+ IF( WANTQ ) THEN
+ IF( MYCOL.EQ.CSRC1 .OR. MYCOL.EQ.CSRC4 ) THEN
+ DO 430 INDX = 1, NPROW
+ IF( MYCOL.EQ.CSRC1 ) THEN
+ CALL INFOG2L( 1+(INDX-1)*NB, I, DESCQ,
+ $ NPROW, NPCOL, MYROW, MYCOL, ILOC,
+ $ JLOC1, RSRC, CSRC1 )
+ IF( MYROW.EQ.RSRC ) THEN
+ CALL SLAMOV( 'All', QROWS, DIM1,
+ $ Q((JLOC1-1)*LLDQ+ILOC), LLDQ,
+ $ WORK(IPW7), QROWS )
+ IF( NPCOL.GT.1 ) THEN
+ EAST = MOD( MYCOL + 1, NPCOL )
+ CALL SGESD2D( ICTXT, QROWS, DIM1,
+ $ WORK(IPW7), QROWS, RSRC,
+ $ EAST )
+ CALL SGERV2D( ICTXT, QROWS, DIM4,
+ $ WORK(IPW7+QROWS*DIM1),
+ $ QROWS, RSRC, EAST )
+ END IF
+ END IF
+ END IF
+ IF( MYCOL.EQ.CSRC4 ) THEN
+ CALL INFOG2L( 1+(INDX-1)*NB, I+DIM1,
+ $ DESCQ, NPROW, NPCOL, MYROW, MYCOL,
+ $ ILOC, JLOC4, RSRC, CSRC4 )
+ IF( MYROW.EQ.RSRC ) THEN
+ CALL SLAMOV( 'All', QROWS, DIM4,
+ $ Q((JLOC4-1)*LLDQ+ILOC), LLDQ,
+ $ WORK(IPW7+QROWS*DIM1), QROWS )
+ IF( NPCOL.GT.1 ) THEN
+ WEST = MOD( MYCOL-1+NPCOL,
+ $ NPCOL )
+ CALL SGESD2D( ICTXT, QROWS, DIM4,
+ $ WORK(IPW7+QROWS*DIM1),
+ $ QROWS, RSRC, WEST )
+ CALL SGERV2D( ICTXT, QROWS, DIM1,
+ $ WORK(IPW7), QROWS, RSRC,
+ $ WEST )
+ END IF
+ END IF
+ END IF
+ 430 CONTINUE
+ END IF
+ END IF
+ END IF
+*
+ 327 CONTINUE
+*
+ 322 CONTINUE
+*
+ DO 323 WINDOW = WINDOW0, WINE, 2
+ RSRC4 = IWORK(IRSRC+WINDOW-1)
+ CSRC4 = IWORK(ICSRC+WINDOW-1)
+ RSRC1 = MOD( RSRC4 - 1 + NPROW, NPROW )
+ CSRC1 = MOD( CSRC4 - 1 + NPCOL, NPCOL )
+ FLOPS = 0
+ IF( ((MYCOL.EQ.CSRC1.OR.MYCOL.EQ.CSRC4).AND.DIR.EQ.2)
+ $ .OR. ((MYROW.EQ.RSRC1.OR.MYROW.EQ.RSRC4).AND.
+ $ DIR.EQ.1) ) THEN
+*
+* Skip this part of the updates if appropriate.
+*
+ IF( WINDOW.EQ.1 .AND. SKIP1CR ) GO TO 328
+*
+* Count number of operations to decide whether to use
+* matrix-matrix multiplications for updating
+* off-diagonal parts or not.
+*
+ NITRAF = PITRAF - IPIW
+ ISHH = .FALSE.
+ DO 405 K = 1, NITRAF
+ IF( IWORK( IPIW + K - 1 ).LE.NWIN ) THEN
+ FLOPS = FLOPS + 6
+ ELSE
+ FLOPS = FLOPS + 11
+ ISHH = .TRUE.
+ END IF
+ 405 CONTINUE
+*
+* Perform updates in parallel.
+*
+ IF( FLOPS.NE.0 .AND.
+ $ ( 2*FLOPS*100 )/( 2*NWIN*NWIN ) .GE. MMULT )
+ $ THEN
+*
+ CALL SLASET( 'All', NWIN, NWIN, ZERO, ONE,
+ $ WORK( IPW4 ), NWIN )
+ WORK(IPW8) = FLOAT(MYROW)
+ WORK(IPW8+1) = FLOAT(MYCOL)
+ CALL BSLAAPP( 1, NWIN, NWIN, NCB, WORK( IPW4 ),
+ $ NWIN, NITRAF, IWORK(IPIW), WORK( IPW3 ),
+ $ WORK(IPW8) )
+*
+* Test if sparsity structure of orthogonal matrix
+* can be exploited (see below).
+*
+ IF( ISHH .OR. DIM1.NE.KS .OR. DIM4.NE.KS ) THEN
+*
+* Update the columns of T and Q affected by the
+* reordering.
+*
+ IF( DIR.EQ.2 ) THEN
+ DO 440 INDX = 1, MIN(I-1,1+(NPROW-1)*NB),
+ $ NB
+ IF( MYCOL.EQ.CSRC1 ) THEN
+ CALL INFOG2L( INDX, I, DESCT, NPROW,
+ $ NPCOL, MYROW, MYCOL, ILOC,
+ $ JLOC, RSRC, CSRC1 )
+ IF( MYROW.EQ.RSRC ) THEN
+ CALL SGEMM( 'No transpose',
+ $ 'No transpose', TROWS, DIM1,
+ $ NWIN, ONE, WORK( IPW5 ),
+ $ TROWS, WORK( IPW4 ), NWIN,
+ $ ZERO, WORK(IPW8), TROWS )
+ CALL SLAMOV( 'All', TROWS, DIM1,
+ $ WORK(IPW8), TROWS,
+ $ T((JLOC-1)*LLDT+ILOC),
+ $ LLDT )
+ END IF
+ END IF
+ IF( MYCOL.EQ.CSRC4 ) THEN
+ CALL INFOG2L( INDX, I+DIM1, DESCT,
+ $ NPROW, NPCOL, MYROW, MYCOL,
+ $ ILOC, JLOC, RSRC, CSRC4 )
+ IF( MYROW.EQ.RSRC ) THEN
+ CALL SGEMM( 'No transpose',
+ $ 'No transpose', TROWS, DIM4,
+ $ NWIN, ONE, WORK( IPW5 ),
+ $ TROWS,
+ $ WORK( IPW4+NWIN*DIM1 ),
+ $ NWIN, ZERO, WORK(IPW8),
+ $ TROWS )
+ CALL SLAMOV( 'All', TROWS, DIM4,
+ $ WORK(IPW8), TROWS,
+ $ T((JLOC-1)*LLDT+ILOC),
+ $ LLDT )
+ END IF
+ END IF
+ 440 CONTINUE
+*
+ IF( WANTQ ) THEN
+ DO 450 INDX = 1, MIN(N,1+(NPROW-1)*NB),
+ $ NB
+ IF( MYCOL.EQ.CSRC1 ) THEN
+ CALL INFOG2L( INDX, I, DESCQ,
+ $ NPROW, NPCOL, MYROW, MYCOL,
+ $ ILOC, JLOC, RSRC, CSRC1 )
+ IF( MYROW.EQ.RSRC ) THEN
+ CALL SGEMM( 'No transpose',
+ $ 'No transpose', QROWS,
+ $ DIM1, NWIN, ONE,
+ $ WORK( IPW7 ), QROWS,
+ $ WORK( IPW4 ), NWIN,
+ $ ZERO, WORK(IPW8),
+ $ QROWS )
+ CALL SLAMOV( 'All', QROWS,
+ $ DIM1, WORK(IPW8), QROWS,
+ $ Q((JLOC-1)*LLDQ+ILOC),
+ $ LLDQ )
+ END IF
+ END IF
+ IF( MYCOL.EQ.CSRC4 ) THEN
+ CALL INFOG2L( INDX, I+DIM1,
+ $ DESCQ, NPROW, NPCOL, MYROW,
+ $ MYCOL, ILOC, JLOC, RSRC,
+ $ CSRC4 )
+ IF( MYROW.EQ.RSRC ) THEN
+ CALL SGEMM( 'No transpose',
+ $ 'No transpose', QROWS,
+ $ DIM4, NWIN, ONE,
+ $ WORK( IPW7 ), QROWS,
+ $ WORK( IPW4+NWIN*DIM1 ),
+ $ NWIN, ZERO, WORK(IPW8),
+ $ QROWS )
+ CALL SLAMOV( 'All', QROWS,
+ $ DIM4, WORK(IPW8), QROWS,
+ $ Q((JLOC-1)*LLDQ+ILOC),
+ $ LLDQ )
+ END IF
+ END IF
+ 450 CONTINUE
+ END IF
+ END IF
+*
+* Update the rows of T affected by the
+* reordering.
+*
+ IF( DIR.EQ.1 ) THEN
+ IF ( LIHIC.LT.N ) THEN
+ IF( MYROW.EQ.RSRC1.AND.MYCOL.EQ.CSRC4
+ $ .AND.MOD(LIHIC,NB).NE.0 ) THEN
+ INDX = LIHIC + 1
+ CALL INFOG2L( I, INDX, DESCT, NPROW,
+ $ NPCOL, MYROW, MYCOL, ILOC,
+ $ JLOC, RSRC1, CSRC4 )
+ CALL SGEMM( 'Transpose',
+ $ 'No Transpose', DIM1, TCOLS,
+ $ NWIN, ONE, WORK(IPW4), NWIN,
+ $ WORK( IPW6 ), NWIN, ZERO,
+ $ WORK(IPW8), DIM1 )
+ CALL SLAMOV( 'All', DIM1, TCOLS,
+ $ WORK(IPW8), DIM1,
+ $ T((JLOC-1)*LLDT+ILOC), LLDT )
+ END IF
+ IF( MYROW.EQ.RSRC4.AND.MYCOL.EQ.CSRC4
+ $ .AND.MOD(LIHIC,NB).NE.0 ) THEN
+ INDX = LIHIC + 1
+ CALL INFOG2L( I+DIM1, INDX, DESCT,
+ $ NPROW, NPCOL, MYROW, MYCOL,
+ $ ILOC, JLOC, RSRC4, CSRC4 )
+ CALL SGEMM( 'Transpose',
+ $ 'No Transpose', DIM4, TCOLS,
+ $ NWIN, ONE,
+ $ WORK( IPW4+DIM1*NWIN ), NWIN,
+ $ WORK( IPW6), NWIN, ZERO,
+ $ WORK(IPW8), DIM4 )
+ CALL SLAMOV( 'All', DIM4, TCOLS,
+ $ WORK(IPW8), DIM4,
+ $ T((JLOC-1)*LLDT+ILOC), LLDT )
+ END IF
+ INDXS = ICEIL(LIHIC,NB)*NB + 1
+ INDXE = MIN(N,INDXS+(NPCOL-2)*NB)
+ DO 460 INDX = INDXS, INDXE, NB
+ IF( MYROW.EQ.RSRC1 ) THEN
+ CALL INFOG2L( I, INDX, DESCT,
+ $ NPROW, NPCOL, MYROW, MYCOL,
+ $ ILOC, JLOC, RSRC1, CSRC )
+ IF( MYCOL.EQ.CSRC ) THEN
+ CALL SGEMM( 'Transpose',
+ $ 'No Transpose', DIM1,
+ $ TCOLS, NWIN, ONE,
+ $ WORK( IPW4 ), NWIN,
+ $ WORK( IPW6 ), NWIN,
+ $ ZERO, WORK(IPW8), DIM1 )
+ CALL SLAMOV( 'All', DIM1,
+ $ TCOLS, WORK(IPW8), DIM1,
+ $ T((JLOC-1)*LLDT+ILOC),
+ $ LLDT )
+ END IF
+ END IF
+ IF( MYROW.EQ.RSRC4 ) THEN
+ CALL INFOG2L( I+DIM1, INDX,
+ $ DESCT, NPROW, NPCOL, MYROW,
+ $ MYCOL, ILOC, JLOC, RSRC4,
+ $ CSRC )
+ IF( MYCOL.EQ.CSRC ) THEN
+ CALL SGEMM( 'Transpose',
+ $ 'No Transpose', DIM4,
+ $ TCOLS, NWIN, ONE,
+ $ WORK( IPW4+NWIN*DIM1 ),
+ $ NWIN, WORK( IPW6 ),
+ $ NWIN, ZERO, WORK(IPW8),
+ $ DIM4 )
+ CALL SLAMOV( 'All', DIM4,
+ $ TCOLS, WORK(IPW8), DIM4,
+ $ T((JLOC-1)*LLDT+ILOC),
+ $ LLDT )
+ END IF
+ END IF
+ 460 CONTINUE
+ END IF
+ END IF
+ ELSE
+*
+* The NWIN-by-NWIN matrix U containing the
+* accumulated orthogonal transformations has
+* the following structure:
+*
+* [ U11 U12 ]
+* U = [ ],
+* [ U21 U22 ]
+*
+* where U21 is KS-by-KS upper triangular and
+* U12 is (NWIN-KS)-by-(NWIN-KS) lower
+* triangular. For reordering over the border
+* the structure is only exploited when the
+* border cuts the columns of U conformally with
+* the structure itself. This happens exactly
+* when all eigenvalues in the subcluster was
+* moved to the other side of the border and
+* fits perfectly in their new positions, i.e.,
+* the reordering stops when the last eigenvalue
+* to cross the border is reordered to the
+* position closest to the border. Tested by
+* checking is KS = DIM1 = DIM4 (see above).
+* This should hold quite often. But this branch
+* is entered only if all involved eigenvalues
+* are real.
+*
+* Update the columns of T and Q affected by the
+* reordering.
+*
+* Compute T2*U21 + T1*U11 on the left side of
+* the border.
+*
+ IF( DIR.EQ.2 ) THEN
+ INDXE = MIN(I-1,1+(NPROW-1)*NB)
+ DO 470 INDX = 1, INDXE, NB
+ IF( MYCOL.EQ.CSRC1 ) THEN
+ CALL INFOG2L( INDX, I, DESCT, NPROW,
+ $ NPCOL, MYROW, MYCOL, ILOC,
+ $ JLOC, RSRC, CSRC1 )
+ IF( MYROW.EQ.RSRC ) THEN
+ CALL SLAMOV( 'All', TROWS, KS,
+ $ WORK( IPW5+TROWS*DIM4),
+ $ TROWS, WORK(IPW8), TROWS )
+ CALL STRMM( 'Right', 'Upper',
+ $ 'No transpose',
+ $ 'Non-unit', TROWS, KS,
+ $ ONE, WORK( IPW4+DIM4 ),
+ $ NWIN, WORK(IPW8), TROWS )
+ CALL SGEMM( 'No transpose',
+ $ 'No transpose', TROWS, KS,
+ $ DIM4, ONE, WORK( IPW5 ),
+ $ TROWS, WORK( IPW4 ), NWIN,
+ $ ONE, WORK(IPW8), TROWS )
+ CALL SLAMOV( 'All', TROWS, KS,
+ $ WORK(IPW8), TROWS,
+ $ T((JLOC-1)*LLDT+ILOC),
+ $ LLDT )
+ END IF
+ END IF
+*
+* Compute T1*U12 + T2*U22 on the right
+* side of the border.
+*
+ IF( MYCOL.EQ.CSRC4 ) THEN
+ CALL INFOG2L( INDX, I+DIM1, DESCT,
+ $ NPROW, NPCOL, MYROW, MYCOL,
+ $ ILOC, JLOC, RSRC, CSRC4 )
+ IF( MYROW.EQ.RSRC ) THEN
+ CALL SLAMOV( 'All', TROWS, DIM4,
+ $ WORK(IPW5), TROWS,
+ $ WORK( IPW8 ), TROWS )
+ CALL STRMM( 'Right', 'Lower',
+ $ 'No transpose',
+ $ 'Non-unit', TROWS, DIM4,
+ $ ONE, WORK( IPW4+NWIN*KS ),
+ $ NWIN, WORK( IPW8 ), TROWS )
+ CALL SGEMM( 'No transpose',
+ $ 'No transpose', TROWS, DIM4,
+ $ KS, ONE,
+ $ WORK( IPW5+TROWS*DIM4),
+ $ TROWS,
+ $ WORK( IPW4+NWIN*KS+DIM4 ),
+ $ NWIN, ONE, WORK( IPW8 ),
+ $ TROWS )
+ CALL SLAMOV( 'All', TROWS, DIM4,
+ $ WORK(IPW8), TROWS,
+ $ T((JLOC-1)*LLDT+ILOC),
+ $ LLDT )
+ END IF
+ END IF
+ 470 CONTINUE
+ IF( WANTQ ) THEN
+*
+* Compute Q2*U21 + Q1*U11 on the left
+* side of border.
+*
+ INDXE = MIN(N,1+(NPROW-1)*NB)
+ DO 480 INDX = 1, INDXE, NB
+ IF( MYCOL.EQ.CSRC1 ) THEN
+ CALL INFOG2L( INDX, I, DESCQ,
+ $ NPROW, NPCOL, MYROW, MYCOL,
+ $ ILOC, JLOC, RSRC, CSRC1 )
+ IF( MYROW.EQ.RSRC ) THEN
+ CALL SLAMOV( 'All', QROWS, KS,
+ $ WORK( IPW7+QROWS*DIM4),
+ $ QROWS, WORK(IPW8),
+ $ QROWS )
+ CALL STRMM( 'Right', 'Upper',
+ $ 'No transpose',
+ $ 'Non-unit', QROWS,
+ $ KS, ONE,
+ $ WORK( IPW4+DIM4 ), NWIN,
+ $ WORK(IPW8), QROWS )
+ CALL SGEMM( 'No transpose',
+ $ 'No transpose', QROWS,
+ $ KS, DIM4, ONE,
+ $ WORK( IPW7 ), QROWS,
+ $ WORK( IPW4 ), NWIN, ONE,
+ $ WORK(IPW8), QROWS )
+ CALL SLAMOV( 'All', QROWS, KS,
+ $ WORK(IPW8), QROWS,
+ $ Q((JLOC-1)*LLDQ+ILOC),
+ $ LLDQ )
+ END IF
+ END IF
+*
+* Compute Q1*U12 + Q2*U22 on the right
+* side of border.
+*
+ IF( MYCOL.EQ.CSRC4 ) THEN
+ CALL INFOG2L( INDX, I+DIM1,
+ $ DESCQ, NPROW, NPCOL, MYROW,
+ $ MYCOL, ILOC, JLOC, RSRC,
+ $ CSRC4 )
+ IF( MYROW.EQ.RSRC ) THEN
+ CALL SLAMOV( 'All', QROWS,
+ $ DIM4, WORK(IPW7), QROWS,
+ $ WORK( IPW8 ), QROWS )
+ CALL STRMM( 'Right', 'Lower',
+ $ 'No transpose',
+ $ 'Non-unit', QROWS,
+ $ DIM4, ONE,
+ $ WORK( IPW4+NWIN*KS ),
+ $ NWIN, WORK( IPW8 ),
+ $ QROWS )
+ CALL SGEMM( 'No transpose',
+ $ 'No transpose', QROWS,
+ $ DIM4, KS, ONE,
+ $ WORK(IPW7+QROWS*(DIM4)),
+ $ QROWS,
+ $ WORK(IPW4+NWIN*KS+DIM4),
+ $ NWIN, ONE, WORK( IPW8 ),
+ $ QROWS )
+ CALL SLAMOV( 'All', QROWS,
+ $ DIM4, WORK(IPW8), QROWS,
+ $ Q((JLOC-1)*LLDQ+ILOC),
+ $ LLDQ )
+ END IF
+ END IF
+ 480 CONTINUE
+ END IF
+ END IF
+*
+ IF( DIR.EQ.1 ) THEN
+ IF ( LIHIC.LT.N ) THEN
+*
+* Compute U21**T*T2 + U11**T*T1 on the
+* upper side of the border.
+*
+ IF( MYROW.EQ.RSRC1.AND.MYCOL.EQ.CSRC4
+ $ .AND.MOD(LIHIC,NB).NE.0 ) THEN
+ INDX = LIHIC + 1
+ CALL INFOG2L( I, INDX, DESCT, NPROW,
+ $ NPCOL, MYROW, MYCOL, ILOC,
+ $ JLOC, RSRC1, CSRC4 )
+ CALL SLAMOV( 'All', KS, TCOLS,
+ $ WORK( IPW6+DIM4 ), NWIN,
+ $ WORK(IPW8), KS )
+ CALL STRMM( 'Left', 'Upper',
+ $ 'Transpose', 'Non-unit',
+ $ KS, TCOLS, ONE,
+ $ WORK( IPW4+DIM4 ), NWIN,
+ $ WORK(IPW8), KS )
+ CALL SGEMM( 'Transpose',
+ $ 'No transpose', KS, TCOLS,
+ $ DIM4, ONE, WORK(IPW4), NWIN,
+ $ WORK(IPW6), NWIN, ONE,
+ $ WORK(IPW8), KS )
+ CALL SLAMOV( 'All', KS, TCOLS,
+ $ WORK(IPW8), KS,
+ $ T((JLOC-1)*LLDT+ILOC), LLDT )
+ END IF
+*
+* Compute U12**T*T1 + U22**T*T2 on the
+* lower side of the border.
+*
+ IF( MYROW.EQ.RSRC4.AND.MYCOL.EQ.CSRC4
+ $ .AND.MOD(LIHIC,NB).NE.0 ) THEN
+ INDX = LIHIC + 1
+ CALL INFOG2L( I+DIM1, INDX, DESCT,
+ $ NPROW, NPCOL, MYROW, MYCOL,
+ $ ILOC, JLOC, RSRC4, CSRC4 )
+ CALL SLAMOV( 'All', DIM4, TCOLS,
+ $ WORK( IPW6 ), NWIN,
+ $ WORK( IPW8 ), DIM4 )
+ CALL STRMM( 'Left', 'Lower',
+ $ 'Transpose', 'Non-unit',
+ $ DIM4, TCOLS, ONE,
+ $ WORK( IPW4+NWIN*KS ), NWIN,
+ $ WORK( IPW8 ), DIM4 )
+ CALL SGEMM( 'Transpose',
+ $ 'No Transpose', DIM4, TCOLS,
+ $ KS, ONE,
+ $ WORK( IPW4+NWIN*KS+DIM4 ),
+ $ NWIN, WORK( IPW6+DIM1 ), NWIN,
+ $ ONE, WORK( IPW8), DIM4 )
+ CALL SLAMOV( 'All', DIM4, TCOLS,
+ $ WORK(IPW8), DIM4,
+ $ T((JLOC-1)*LLDT+ILOC), LLDT )
+ END IF
+*
+* Compute U21**T*T2 + U11**T*T1 on upper
+* side on border.
+*
+ INDXS = ICEIL(LIHIC,NB)*NB+1
+ INDXE = MIN(N,INDXS+(NPCOL-2)*NB)
+ DO 490 INDX = INDXS, INDXE, NB
+ IF( MYROW.EQ.RSRC1 ) THEN
+ CALL INFOG2L( I, INDX, DESCT,
+ $ NPROW, NPCOL, MYROW, MYCOL,
+ $ ILOC, JLOC, RSRC1, CSRC )
+ IF( MYCOL.EQ.CSRC ) THEN
+ CALL SLAMOV( 'All', KS, TCOLS,
+ $ WORK( IPW6+DIM4 ), NWIN,
+ $ WORK(IPW8), KS )
+ CALL STRMM( 'Left', 'Upper',
+ $ 'Transpose',
+ $ 'Non-unit', KS,
+ $ TCOLS, ONE,
+ $ WORK( IPW4+DIM4 ), NWIN,
+ $ WORK(IPW8), KS )
+ CALL SGEMM( 'Transpose',
+ $ 'No transpose', KS,
+ $ TCOLS, DIM4, ONE,
+ $ WORK(IPW4), NWIN,
+ $ WORK(IPW6), NWIN, ONE,
+ $ WORK(IPW8), KS )
+ CALL SLAMOV( 'All', KS, TCOLS,
+ $ WORK(IPW8), KS,
+ $ T((JLOC-1)*LLDT+ILOC),
+ $ LLDT )
+ END IF
+ END IF
+*
+* Compute U12**T*T1 + U22**T*T2 on
+* lower side of border.
+*
+ IF( MYROW.EQ.RSRC4 ) THEN
+ CALL INFOG2L( I+DIM1, INDX,
+ $ DESCT, NPROW, NPCOL, MYROW,
+ $ MYCOL, ILOC, JLOC, RSRC4,
+ $ CSRC )
+ IF( MYCOL.EQ.CSRC ) THEN
+ CALL SLAMOV( 'All', DIM4,
+ $ TCOLS, WORK( IPW6 ),
+ $ NWIN, WORK( IPW8 ),
+ $ DIM4 )
+ CALL STRMM( 'Left', 'Lower',
+ $ 'Transpose',
+ $ 'Non-unit', DIM4,
+ $ TCOLS, ONE,
+ $ WORK( IPW4+NWIN*KS ),
+ $ NWIN, WORK( IPW8 ),
+ $ DIM4 )
+ CALL SGEMM( 'Transpose',
+ $ 'No Transpose', DIM4,
+ $ TCOLS, KS, ONE,
+ $ WORK(IPW4+NWIN*KS+DIM4),
+ $ NWIN, WORK( IPW6+DIM1 ),
+ $ NWIN, ONE, WORK( IPW8),
+ $ DIM4 )
+ CALL SLAMOV( 'All', DIM4,
+ $ TCOLS, WORK(IPW8), DIM4,
+ $ T((JLOC-1)*LLDT+ILOC),
+ $ LLDT )
+ END IF
+ END IF
+ 490 CONTINUE
+ END IF
+ END IF
+ END IF
+ ELSEIF( FLOPS.NE.0 ) THEN
+*
+* Update off-diagonal blocks and Q using the
+* pipelined elementary transformations. Now we
+* have a delicate problem: how to do this without
+* redundant work? For now, we let the processes
+* involved compute the whole crossborder block
+* rows and column saving only the part belonging
+* to the corresponding side of the border. To make
+* this a realistic alternative, we have modified
+* the ratio r_flops (see Reference [2] above) to
+* give more favor to the ordinary matrix
+* multiplication.
+*
+ IF( DIR.EQ.2 ) THEN
+ INDXE = MIN(I-1,1+(NPROW-1)*NB)
+ DO 500 INDX = 1, INDXE, NB
+ CALL INFOG2L( INDX, I, DESCT, NPROW,
+ $ NPCOL, MYROW, MYCOL, ILOC, JLOC,
+ $ RSRC, CSRC )
+ IF( MYROW.EQ.RSRC .AND. MYCOL.EQ.CSRC )
+ $ THEN
+ CALL BSLAAPP( 1, TROWS, NWIN, NCB,
+ $ WORK(IPW5), TROWS, NITRAF,
+ $ IWORK(IPIW), WORK( IPW3 ),
+ $ WORK(IPW8) )
+ CALL SLAMOV( 'All', TROWS, DIM1,
+ $ WORK(IPW5), TROWS,
+ $ T((JLOC-1)*LLDT+ILOC ), LLDT )
+ END IF
+ CALL INFOG2L( INDX, I+DIM1, DESCT, NPROW,
+ $ NPCOL, MYROW, MYCOL, ILOC, JLOC,
+ $ RSRC, CSRC )
+ IF( MYROW.EQ.RSRC .AND. MYCOL.EQ.CSRC )
+ $ THEN
+ IF( NPCOL.GT.1 )
+ $ CALL BSLAAPP( 1, TROWS, NWIN, NCB,
+ $ WORK(IPW5), TROWS, NITRAF,
+ $ IWORK(IPIW), WORK( IPW3 ),
+ $ WORK(IPW8) )
+ CALL SLAMOV( 'All', TROWS, DIM4,
+ $ WORK(IPW5+TROWS*DIM1), TROWS,
+ $ T((JLOC-1)*LLDT+ILOC ), LLDT )
+ END IF
+ 500 CONTINUE
+ IF( WANTQ ) THEN
+ INDXE = MIN(N,1+(NPROW-1)*NB)
+ DO 510 INDX = 1, INDXE, NB
+ CALL INFOG2L( INDX, I, DESCQ, NPROW,
+ $ NPCOL, MYROW, MYCOL, ILOC, JLOC,
+ $ RSRC, CSRC )
+ IF( MYROW.EQ.RSRC .AND. MYCOL.EQ.CSRC )
+ $ THEN
+ CALL BSLAAPP( 1, QROWS, NWIN, NCB,
+ $ WORK(IPW7), QROWS, NITRAF,
+ $ IWORK(IPIW), WORK( IPW3 ),
+ $ WORK(IPW8) )
+ CALL SLAMOV( 'All', QROWS, DIM1,
+ $ WORK(IPW7), QROWS,
+ $ Q((JLOC-1)*LLDQ+ILOC ), LLDQ )
+ END IF
+ CALL INFOG2L( INDX, I+DIM1, DESCQ,
+ $ NPROW, NPCOL, MYROW, MYCOL, ILOC,
+ $ JLOC, RSRC, CSRC )
+ IF( MYROW.EQ.RSRC .AND. MYCOL.EQ.CSRC )
+ $ THEN
+ IF( NPCOL.GT.1 )
+ $ CALL BSLAAPP( 1, QROWS, NWIN,
+ $ NCB, WORK(IPW7), QROWS,
+ $ NITRAF, IWORK(IPIW),
+ $ WORK( IPW3 ), WORK(IPW8) )
+ CALL SLAMOV( 'All', QROWS, DIM4,
+ $ WORK(IPW7+QROWS*DIM1), QROWS,
+ $ Q((JLOC-1)*LLDQ+ILOC ), LLDQ )
+ END IF
+ 510 CONTINUE
+ END IF
+ END IF
+*
+ IF( DIR.EQ.1 ) THEN
+ IF( LIHIC.LT.N ) THEN
+ INDX = LIHIC + 1
+ CALL INFOG2L( I, INDX, DESCT, NPROW,
+ $ NPCOL, MYROW, MYCOL, ILOC, JLOC,
+ $ RSRC, CSRC )
+ IF( MYROW.EQ.RSRC .AND. MYCOL.EQ.CSRC.AND.
+ $ MOD(LIHIC,NB).NE.0 ) THEN
+ CALL BSLAAPP( 0, NWIN, TCOLS, NCB,
+ $ WORK( IPW6 ), NWIN, NITRAF,
+ $ IWORK(IPIW), WORK( IPW3 ),
+ $ WORK(IPW8) )
+ CALL SLAMOV( 'All', DIM1, TCOLS,
+ $ WORK( IPW6 ), NWIN,
+ $ T((JLOC-1)*LLDT+ILOC), LLDT )
+ END IF
+ CALL INFOG2L( I+DIM1, INDX, DESCT, NPROW,
+ $ NPCOL, MYROW, MYCOL, ILOC, JLOC,
+ $ RSRC, CSRC )
+ IF( MYROW.EQ.RSRC .AND. MYCOL.EQ.CSRC.AND.
+ $ MOD(LIHIC,NB).NE.0 ) THEN
+ IF( NPROW.GT.1 )
+ $ CALL BSLAAPP( 0, NWIN, TCOLS, NCB,
+ $ WORK( IPW6 ), NWIN, NITRAF,
+ $ IWORK(IPIW), WORK( IPW3 ),
+ $ WORK(IPW8) )
+ CALL SLAMOV( 'All', DIM4, TCOLS,
+ $ WORK( IPW6+DIM1 ), NWIN,
+ $ T((JLOC-1)*LLDT+ILOC), LLDT )
+ END IF
+ INDXS = ICEIL(LIHIC,NB)*NB + 1
+ INDXE = MIN(N,INDXS+(NPCOL-2)*NB)
+ DO 520 INDX = INDXS, INDXE, NB
+ CALL INFOG2L( I, INDX, DESCT, NPROW,
+ $ NPCOL, MYROW, MYCOL, ILOC, JLOC,
+ $ RSRC, CSRC )
+ IF( MYROW.EQ.RSRC .AND. MYCOL.EQ.CSRC )
+ $ THEN
+ CALL BSLAAPP( 0, NWIN, TCOLS, NCB,
+ $ WORK(IPW6), NWIN, NITRAF,
+ $ IWORK(IPIW), WORK( IPW3 ),
+ $ WORK(IPW8) )
+ CALL SLAMOV( 'All', DIM1, TCOLS,
+ $ WORK( IPW6 ), NWIN,
+ $ T((JLOC-1)*LLDT+ILOC), LLDT )
+ END IF
+ CALL INFOG2L( I+DIM1, INDX, DESCT,
+ $ NPROW, NPCOL, MYROW, MYCOL, ILOC,
+ $ JLOC, RSRC, CSRC )
+ IF( MYROW.EQ.RSRC .AND. MYCOL.EQ.CSRC )
+ $ THEN
+ IF( NPROW.GT.1 )
+ $ CALL BSLAAPP( 0, NWIN, TCOLS,
+ $ NCB, WORK(IPW6), NWIN, NITRAF,
+ $ IWORK(IPIW), WORK( IPW3 ),
+ $ WORK(IPW8) )
+ CALL SLAMOV( 'All', DIM4, TCOLS,
+ $ WORK( IPW6+DIM1 ), NWIN,
+ $ T((JLOC-1)*LLDT+ILOC), LLDT )
+ END IF
+ 520 CONTINUE
+ END IF
+ END IF
+ END IF
+ END IF
+*
+ 328 CONTINUE
+*
+ 323 CONTINUE
+*
+* End of loops over directions (DIR).
+*
+ 2222 CONTINUE
+*
+* End of loops over diagonal blocks for reordering over the
+* block diagonal.
+*
+ 310 CONTINUE
+ LAST = LAST + 1
+ IF( LASTWAIT .AND. LAST.LT.2 ) GO TO 308
+*
+* Barrier to collect the processes before proceeding.
+*
+ CALL BLACS_BARRIER( ICTXT, 'All' )
+*
+* Compute global maximum of IERR so that we know if some process
+* experienced a failure in the reordering.
+*
+ MYIERR = IERR
+ IF( NPROCS.GT.1 )
+ $ CALL IGAMX2D( ICTXT, 'All', TOP, 1, 1, IERR, 1, -1,
+ $ -1, -1, -1, -1 )
+*
+ IF( IERR.NE.0 ) THEN
+*
+* When calling BDTREXC, the block at position I+KKS-1 failed
+* to swap.
+*
+ IF( MYIERR.NE.0 ) INFO = MAX(1,I+KKS-1)
+ IF( NPROCS.GT.1 )
+ $ CALL IGAMX2D( ICTXT, 'All', TOP, 1, 1, INFO, 1, -1,
+ $ -1, -1, -1, -1 )
+ GO TO 300
+ END IF
+*
+* Do a global update of the SELECT vector.
+*
+ DO 530 K = 1, N
+ RSRC = INDXG2P( K, NB, MYROW, DESCT( RSRC_ ), NPROW )
+ CSRC = INDXG2P( K, NB, MYCOL, DESCT( CSRC_ ), NPCOL )
+ IF( MYROW.NE.RSRC .OR. MYCOL.NE.CSRC )
+ $ SELECT( K ) = 0
+ 530 CONTINUE
+ IF( NPROCS.GT.1 )
+ $ CALL IGSUM2D( ICTXT, 'All', TOP, N, 1, SELECT, N, -1, -1 )
+*
+* Find the global minumum of ILO and IHI.
+*
+ ILO = ILO - 1
+ 523 CONTINUE
+ ILO = ILO + 1
+ IF( ILO.LE.N ) THEN
+ IF( SELECT(ILO).NE.0 ) GO TO 523
+ END IF
+ IHI = IHI + 1
+ 527 CONTINUE
+ IHI = IHI - 1
+ IF( IHI.GE.1 ) THEN
+ IF( SELECT(IHI).EQ.0 ) GO TO 527
+ END IF
+*
+* End While ( ILO <= M )
+ GO TO 50
+ END IF
+*
+ 300 CONTINUE
+*
+* In case an error occured, do an additional global update of
+* SELECT.
+*
+ IF( INFO.NE.0 ) THEN
+ DO 540 K = 1, N
+ RSRC = INDXG2P( K, NB, MYROW, DESCT( RSRC_ ), NPROW )
+ CSRC = INDXG2P( K, NB, MYCOL, DESCT( CSRC_ ), NPCOL )
+ IF( MYROW.NE.RSRC .OR. MYCOL.NE.CSRC )
+ $ SELECT( K ) = 0
+ 540 CONTINUE
+ IF( NPROCS.GT.1 )
+ $ CALL IGSUM2D( ICTXT, 'All', TOP, N, 1, SELECT, N, -1, -1 )
+ END IF
+*
+ 545 CONTINUE
+*
+* Store the output eigenvalues in WR and WI: first let all the
+* processes compute the eigenvalue inside their diagonal blocks in
+* parallel, except for the eigenvalue located next to a block
+* border. After that, compute all eigenvalues located next to the
+* block borders. Finally, do a global summation over WR and WI so
+* that all processors receive the result. Notice: real eigenvalues
+* extracted from a non-canonical 2-by-2 block are not stored in
+* any particular order.
+*
+ DO 550 K = 1, N
+ WR( K ) = ZERO
+ WI( K ) = ZERO
+ 550 CONTINUE
+*
+* Loop 560: extract eigenvalues from the blocks which are not laid
+* out across a border of the processor mesh, except for those 1x1
+* blocks on the border.
+*
+ PAIR = .FALSE.
+ DO 560 K = 1, N
+ IF( .NOT. PAIR ) THEN
+ BORDER = ( K.NE.N .AND. MOD( K, NB ).EQ.0 ) .OR.
+ % ( K.NE.1 .AND. MOD( K, NB ).EQ.1 )
+ IF( .NOT. BORDER ) THEN
+ CALL INFOG2L( K, K, DESCT, NPROW, NPCOL, MYROW, MYCOL,
+ $ ILOC1, JLOC1, TRSRC1, TCSRC1 )
+ IF( MYROW.EQ.TRSRC1 .AND. MYCOL.EQ.TCSRC1 ) THEN
+ ELEM1 = T((JLOC1-1)*LLDT+ILOC1)
+ IF( K.LT.N ) THEN
+ ELEM3 = T((JLOC1-1)*LLDT+ILOC1+1)
+ ELSE
+ ELEM3 = ZERO
+ END IF
+ IF( ELEM3.NE.ZERO ) THEN
+ ELEM2 = T((JLOC1)*LLDT+ILOC1)
+ ELEM4 = T((JLOC1)*LLDT+ILOC1+1)
+ CALL SLANV2( ELEM1, ELEM2, ELEM3, ELEM4,
+ $ WR( K ), WI( K ), WR( K+1 ), WI( K+1 ), SN,
+ $ CS )
+ PAIR = .TRUE.
+ ELSE
+ IF( K.GT.1 ) THEN
+ TMP = T((JLOC1-2)*LLDT+ILOC1)
+ IF( TMP.NE.ZERO ) THEN
+ ELEM1 = T((JLOC1-2)*LLDT+ILOC1-1)
+ ELEM2 = T((JLOC1-1)*LLDT+ILOC1-1)
+ ELEM3 = T((JLOC1-2)*LLDT+ILOC1)
+ ELEM4 = T((JLOC1-1)*LLDT+ILOC1)
+ CALL SLANV2( ELEM1, ELEM2, ELEM3, ELEM4,
+ $ WR( K-1 ), WI( K-1 ), WR( K ),
+ $ WI( K ), SN, CS )
+ ELSE
+ WR( K ) = ELEM1
+ END IF
+ ELSE
+ WR( K ) = ELEM1
+ END IF
+ END IF
+ END IF
+ END IF
+ ELSE
+ PAIR = .FALSE.
+ END IF
+ 560 CONTINUE
+*
+* Loop 570: extract eigenvalues from the blocks which are laid
+* out across a border of the processor mesh. The processors are
+* numbered as below:
+*
+* 1 | 2
+* --+--
+* 3 | 4
+*
+ DO 570 K = NB, N-1, NB
+ CALL INFOG2L( K, K, DESCT, NPROW, NPCOL, MYROW, MYCOL,
+ $ ILOC1, JLOC1, TRSRC1, TCSRC1 )
+ CALL INFOG2L( K, K+1, DESCT, NPROW, NPCOL, MYROW, MYCOL,
+ $ ILOC2, JLOC2, TRSRC2, TCSRC2 )
+ CALL INFOG2L( K+1, K, DESCT, NPROW, NPCOL, MYROW, MYCOL,
+ $ ILOC3, JLOC3, TRSRC3, TCSRC3 )
+ CALL INFOG2L( K+1, K+1, DESCT, NPROW, NPCOL, MYROW, MYCOL,
+ $ ILOC4, JLOC4, TRSRC4, TCSRC4 )
+ IF( MYROW.EQ.TRSRC2 .AND. MYCOL.EQ.TCSRC2 ) THEN
+ ELEM2 = T((JLOC2-1)*LLDT+ILOC2)
+ IF( TRSRC1.NE.TRSRC2 .OR. TCSRC1.NE.TCSRC2 )
+ $ CALL SGESD2D( ICTXT, 1, 1, ELEM2, 1, TRSRC1, TCSRC1 )
+ END IF
+ IF( MYROW.EQ.TRSRC3 .AND. MYCOL.EQ.TCSRC3 ) THEN
+ ELEM3 = T((JLOC3-1)*LLDT+ILOC3)
+ IF( TRSRC1.NE.TRSRC3 .OR. TCSRC1.NE.TCSRC3 )
+ $ CALL SGESD2D( ICTXT, 1, 1, ELEM3, 1, TRSRC1, TCSRC1 )
+ END IF
+ IF( MYROW.EQ.TRSRC4 .AND. MYCOL.EQ.TCSRC4 ) THEN
+ WORK(1) = T((JLOC4-1)*LLDT+ILOC4)
+ IF( K+1.LT.N ) THEN
+ WORK(2) = T((JLOC4-1)*LLDT+ILOC4+1)
+ ELSE
+ WORK(2) = ZERO
+ END IF
+ IF( TRSRC1.NE.TRSRC4 .OR. TCSRC1.NE.TCSRC4 )
+ $ CALL SGESD2D( ICTXT, 2, 1, WORK, 2, TRSRC1, TCSRC1 )
+ END IF
+ IF( MYROW.EQ.TRSRC1 .AND. MYCOL.EQ.TCSRC1 ) THEN
+ ELEM1 = T((JLOC1-1)*LLDT+ILOC1)
+ IF( TRSRC1.NE.TRSRC2 .OR. TCSRC1.NE.TCSRC2 )
+ $ CALL SGERV2D( ICTXT, 1, 1, ELEM2, 1, TRSRC2, TCSRC2 )
+ IF( TRSRC1.NE.TRSRC3 .OR. TCSRC1.NE.TCSRC3 )
+ $ CALL SGERV2D( ICTXT, 1, 1, ELEM3, 1, TRSRC3, TCSRC3 )
+ IF( TRSRC1.NE.TRSRC4 .OR. TCSRC1.NE.TCSRC4 )
+ $ CALL SGERV2D( ICTXT, 2, 1, WORK, 2, TRSRC4, TCSRC4 )
+ ELEM4 = WORK(1)
+ ELEM5 = WORK(2)
+ IF( ELEM5.EQ.ZERO ) THEN
+ IF( WR( K ).EQ.ZERO .AND. WI( K ).EQ.ZERO ) THEN
+ CALL SLANV2( ELEM1, ELEM2, ELEM3, ELEM4, WR( K ),
+ $ WI( K ), WR( K+1 ), WI( K+1 ), SN, CS )
+ ELSEIF( WR( K+1 ).EQ.ZERO .AND. WI( K+1 ).EQ.ZERO ) THEN
+ WR( K+1 ) = ELEM4
+ END IF
+ ELSEIF( WR( K ).EQ.ZERO .AND. WI( K ).EQ.ZERO ) THEN
+ WR( K ) = ELEM1
+ END IF
+ END IF
+ 570 CONTINUE
+*
+ IF( NPROCS.GT.1 ) THEN
+ CALL SGSUM2D( ICTXT, 'All', TOP, N, 1, WR, N, -1, -1 )
+ CALL SGSUM2D( ICTXT, 'All', TOP, N, 1, WI, N, -1, -1 )
+ END IF
+*
+* Store storage requirements in workspaces.
+*
+ WORK( 1 ) = FLOAT(LWMIN)
+ IWORK( 1 ) = LIWMIN
+*
+* Return to calling program.
+*
+ RETURN
+*
+* End of PSTRORD
+*
+ END
+*
diff --git a/SRC/pstrsen.f b/SRC/pstrsen.f
new file mode 100644
index 0000000..6219bdb
--- /dev/null
+++ b/SRC/pstrsen.f
@@ -0,0 +1,709 @@
+ SUBROUTINE PSTRSEN( JOB, COMPQ, SELECT, PARA, N, T, IT, JT,
+ $ DESCT, Q, IQ, JQ, DESCQ, WR, WI, M, S, SEP, WORK, LWORK,
+ $ IWORK, LIWORK, INFO )
+*
+* Contribution from the Department of Computing Science and HPC2N,
+* Umea University, Sweden
+*
+* -- ScaLAPACK computational routine (version 2.0.1) --
+* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
+* Univ. of Colorado Denver and University of California, Berkeley.
+* January, 2012
+*
+ IMPLICIT NONE
+*
+* .. Scalar Arguments ..
+ CHARACTER COMPQ, JOB
+ INTEGER INFO, LIWORK, LWORK, M, N,
+ $ IT, JT, IQ, JQ
+ REAL S, SEP
+* ..
+* .. Array Arguments ..
+ LOGICAL SELECT( N )
+ INTEGER PARA( 6 ), DESCT( * ), DESCQ( * ), IWORK( * )
+ REAL Q( * ), T( * ), WI( * ), WORK( * ), WR( * )
+* ..
+*
+* Purpose
+* =======
+*
+* PSTRSEN 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. The reordering is performed
+* by PSTRORD.
+*
+* Optionally the routine computes the reciprocal condition numbers of
+* the cluster of eigenvalues and/or the invariant subspace. SCASY
+* library is needed for condition estimation.
+*
+* T must be in Schur form (as returned by PSLAHQR), that is, block
+* upper triangular with 1-by-1 and 2-by-2 diagonal blocks.
+*
+* Notes
+* =====
+*
+* Each global data object is described by an associated description
+* vector. This vector stores the information required to establish
+* the mapping between an object element and its corresponding process
+* and memory location.
+*
+* Let A be a generic term for any 2D block cyclicly distributed array.
+* Such a global array has an associated description vector DESCA.
+* In the following comments, the character _ should be read as
+* "of the global array".
+*
+* NOTATION STORED IN EXPLANATION
+* --------------- -------------- --------------------------------------
+* DTYPE_A(global) DESCA( DTYPE_ )The descriptor type. In this case,
+* DTYPE_A = 1.
+* CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating
+* the BLACS process grid A is distribu-
+* ted over. The context itself is glo-
+* bal, but the handle (the integer
+* value) may vary.
+* M_A (global) DESCA( M_ ) The number of rows in the global
+* array A.
+* N_A (global) DESCA( N_ ) The number of columns in the global
+* array A.
+* MB_A (global) DESCA( MB_ ) The blocking factor used to distribute
+* the rows of the array.
+* NB_A (global) DESCA( NB_ ) The blocking factor used to distribute
+* the columns of the array.
+* RSRC_A (global) DESCA( RSRC_ ) The process row over which the first
+* row of the array A is distributed.
+* CSRC_A (global) DESCA( CSRC_ ) The process column over which the
+* first column of the array A is
+* distributed.
+* LLD_A (local) DESCA( LLD_ ) The leading dimension of the local
+* array. LLD_A >= MAX(1,LOCr(M_A)).
+*
+* Let K be the number of rows or columns of a distributed matrix,
+* and assume that its process grid has dimension p x q.
+* LOCr( K ) denotes the number of elements of K that a process
+* would receive if K were distributed over the p processes of its
+* process column.
+* Similarly, LOCc( K ) denotes the number of elements of K that a
+* process would receive if K were distributed over the q processes of
+* its process row.
+* The values of LOCr() and LOCc() may be determined via a call to the
+* ScaLAPACK tool function, NUMROC:
+* LOCr( M ) = NUMROC( M, MB_A, MYROW, RSRC_A, NPROW ),
+* LOCc( N ) = NUMROC( N, NB_A, MYCOL, CSRC_A, NPCOL ).
+* An upper bound for these quantities may be computed by:
+* LOCr( M ) <= ceil( ceil(M/MB_A)/NPROW )*MB_A
+* LOCc( N ) <= ceil( ceil(N/NB_A)/NPCOL )*NB_A
+*
+* Arguments
+* =========
+*
+* JOB (global input) CHARACTER*1
+* Specifies whether condition numbers are required for the
+* cluster of eigenvalues (S) or the invariant subspace (SEP):
+* = 'N': none;
+* = 'E': for eigenvalues only (S);
+* = 'V': for invariant subspace only (SEP);
+* = 'B': for both eigenvalues and invariant subspace (S and
+* SEP).
+*
+* COMPQ (global input) CHARACTER*1
+* = 'V': update the matrix Q of Schur vectors;
+* = 'N': do not update Q.
+*
+* SELECT (global input) LOGICAL array, dimension (N)
+* SELECT specifies the eigenvalues in the selected cluster. To
+* select a real eigenvalue w(j), SELECT(j) must be set to
+* .TRUE.. To select a complex conjugate pair of eigenvalues
+* w(j) and w(j+1), corresponding to a 2-by-2 diagonal block,
+* either SELECT(j) or SELECT(j+1) or both must be set to
+* .TRUE.; a complex conjugate pair of eigenvalues must be
+* either both included in the cluster or both excluded.
+*
+* PARA (global input) INTEGER*6
+* Block parameters (some should be replaced by calls to
+* PILAENV and others by meaningful default values):
+* PARA(1) = maximum number of concurrent computational windows
+* allowed in the algorithm;
+* 0 < PARA(1) <= min(NPROW,NPCOL) must hold;
+* PARA(2) = number of eigenvalues in each window;
+* 0 < PARA(2) < PARA(3) must hold;
+* PARA(3) = window size; PARA(2) < PARA(3) < DESCT(MB_)
+* must hold;
+* PARA(4) = minimal percentage of flops required for
+* performing matrix-matrix multiplications instead
+* of pipelined orthogonal transformations;
+* 0 <= PARA(4) <= 100 must hold;
+* PARA(5) = width of block column slabs for row-wise
+* application of pipelined orthogonal
+* transformations in their factorized form;
+* 0 < PARA(5) <= DESCT(MB_) must hold.
+* PARA(6) = the maximum number of eigenvalues moved together
+* over a process border; in practice, this will be
+* approximately half of the cross border window size
+* 0 < PARA(6) <= PARA(2) must hold;
+*
+* N (global input) INTEGER
+* The order of the globally distributed matrix T. N >= 0.
+*
+* T (local input/output) REAL array,
+* dimension (LLD_T,LOCc(N)).
+* On entry, the local pieces of the global distributed
+* upper quasi-triangular matrix T, in Schur form. On exit, T is
+* overwritten by the local pieces of the reordered matrix T,
+* again in Schur form, with the selected eigenvalues in the
+* globally leading diagonal blocks.
+*
+* IT (global input) INTEGER
+* JT (global input) INTEGER
+* The row and column index in the global array T indicating the
+* first column of sub( T ). IT = JT = 1 must hold.
+*
+* DESCT (global and local input) INTEGER array of dimension DLEN_.
+* The array descriptor for the global distributed matrix T.
+*
+* Q (local input/output) REAL array,
+* dimension (LLD_Q,LOCc(N)).
+* On entry, if COMPQ = 'V', the local pieces of the global
+* distributed matrix Q of Schur vectors.
+* On exit, if COMPQ = 'V', Q has been postmultiplied by the
+* global 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.
+*
+* IQ (global input) INTEGER
+* JQ (global input) INTEGER
+* The column index in the global array Q indicating the
+* first column of sub( Q ). IQ = JQ = 1 must hold.
+*
+* DESCQ (global and local input) INTEGER array of dimension DLEN_.
+* The array descriptor for the global distributed matrix Q.
+*
+* WR (global output) REAL array, dimension (N)
+* WI (global output) REAL array, dimension (N)
+* The real and imaginary parts, respectively, of the reordered
+* eigenvalues of T. The eigenvalues are in principle 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 also that if a complex eigenvalue is sufficiently
+* ill-conditioned, then its value may differ significantly
+* from its value before reordering.
+*
+* M (global output) INTEGER
+* The dimension of the specified invariant subspace.
+* 0 <= M <= N.
+*
+* S (global output) REAL
+* If JOB = 'E' or 'B', S is a lower bound on the reciprocal
+* condition number for the selected cluster of eigenvalues.
+* S cannot underestimate the true reciprocal condition number
+* by more than a factor of sqrt(N). If M = 0 or N, S = 1.
+* If JOB = 'N' or 'V', S is not referenced.
+*
+* SEP (global output) REAL
+* If JOB = 'V' or 'B', SEP is the estimated reciprocal
+* condition number of the specified invariant subspace. If
+* M = 0 or N, SEP = norm(T).
+* If JOB = 'N' or 'E', SEP is not referenced.
+*
+* WORK (local workspace/output) REAL array,
+* dimension (LWORK)
+* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*
+* LWORK (local input) 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 PXERBLA.
+*
+* IWORK (local workspace/output) INTEGER array, dimension (LIWORK)
+*
+* LIWORK (local input) INTEGER
+* The dimension of the array IWORK.
+*
+* 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 PXERBLA.
+*
+* INFO (global output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value.
+* If the i-th argument is an array and the j-entry had
+* an illegal value, then INFO = -(i*1000+j), if the i-th
+* argument is a scalar and had an illegal value, then INFO = -i.
+* > 0: here we have several possibilites
+* *) 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.
+* On exit, INFO = {the index of T where the swap failed}.
+* *) A 2-by-2 block to be reordered split into two 1-by-1
+* blocks and the second block failed to swap with an
+* adjacent block.
+* On exit, INFO = {the index of T where the swap failed}.
+* *) If INFO = N+1, there is no valid BLACS context (see the
+* BLACS documentation for details).
+* *) If INFO = N+2, the routines used in the calculation of
+* the condition numbers raised a positive warning flag
+* (see the documentation for PGESYCTD and PSYCTCON of the
+* SCASY library).
+* *) If INFO = N+3, PGESYCTD raised an input error flag;
+* please report this bug to the authors (see below).
+* If INFO = N+4, PSYCTCON raised an input error flag;
+* please report this bug to the authors (see below).
+* In a future release this subroutine may distinguish between
+* the case 1 and 2 above.
+*
+* Method
+* ======
+*
+* This routine performs parallel eigenvalue reordering in real Schur
+* form by parallelizing the approach proposed in [3]. The condition
+* number estimation part is performed by using techniques and code
+* from SCASY, see http://www.cs.umu.se/research/parallel/scasy.
+*
+* Additional requirements
+* =======================
+*
+* The following alignment requirements must hold:
+* (a) DESCT( MB_ ) = DESCT( NB_ ) = DESCQ( MB_ ) = DESCQ( NB_ )
+* (b) DESCT( RSRC_ ) = DESCQ( RSRC_ )
+* (c) DESCT( CSRC_ ) = DESCQ( CSRC_ )
+*
+* All matrices must be blocked by a block factor larger than or
+* equal to two (3). This to simplify reordering across processor
+* borders in the presence of 2-by-2 blocks.
+*
+* Limitations
+* ===========
+*
+* This algorithm cannot work on submatrices of T and Q, i.e.,
+* IT = JT = IQ = JQ = 1 must hold. This is however no limitation
+* since PSLAHQR does not compute Schur forms of submatrices anyway.
+*
+* References
+* ==========
+*
+* [1] Z. Bai and J. W. Demmel; On swapping diagonal blocks in real
+* Schur form, Linear Algebra Appl., 186:73--95, 1993. Also as
+* LAPACK Working Note 54.
+*
+* [2] Z. Bai, J. W. Demmel, and A. McKenney; On computing condition
+* numbers for the nonsymmetric eigenvalue problem, ACM Trans.
+* Math. Software, 19(2):202--223, 1993. Also as LAPACK Working
+* Note 13.
+*
+* [3] D. Kressner; Block algorithms for reordering standard and
+* generalized Schur forms, ACM TOMS, 32(4):521-532, 2006.
+* Also LAPACK Working Note 171.
+*
+* [4] R. Granat, B. Kagstrom, and D. Kressner; Parallel eigenvalue
+* reordering in real Schur form, Concurrency and Computations:
+* Practice and Experience, 21(9):1225-1250, 2009. Also as
+* LAPACK Working Note 192.
+*
+* Parallel execution recommendations
+* ==================================
+*
+* Use a square grid, if possible, for maximum performance. The block
+* parameters in PARA should be kept well below the data distribution
+* block size. In particular, see [3,4] for recommended settings for
+* these parameters.
+*
+* In general, the parallel algorithm strives to perform as much work
+* as possible without crossing the block borders on the main block
+* diagonal.
+*
+* Contributors
+* ============
+*
+* Implemented by Robert Granat, Dept. of Computing Science and HPC2N,
+* Umea University, Sweden, March 2007,
+* in collaboration with Bo Kagstrom and Daniel Kressner.
+* Modified by Meiyue Shao, October 2011.
+*
+* Revisions
+* =========
+*
+* Please send bug-reports to granat at cs.umu.se
+*
+* Keywords
+* ========
+*
+* Real Schur form, eigenvalue reordering, Sylvester matrix equation
+*
+* =====================================================================
+* ..
+* .. Parameters ..
+ CHARACTER TOP
+ INTEGER BLOCK_CYCLIC_2D, CSRC_, CTXT_, DLEN_, DTYPE_,
+ $ LLD_, MB_, M_, NB_, N_, RSRC_
+ REAL ZERO, ONE
+ PARAMETER ( TOP = '1-Tree',
+ $ BLOCK_CYCLIC_2D = 1, DLEN_ = 9, DTYPE_ = 1,
+ $ CTXT_ = 2, M_ = 3, N_ = 4, MB_ = 5, NB_ = 6,
+ $ RSRC_ = 7, CSRC_ = 8, LLD_ = 9,
+ $ ZERO = 0.0, ONE = 1.0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL LQUERY, WANTBH, WANTQ, WANTS, WANTSP
+ INTEGER ICOFFT12, ICTXT, IDUM1, IDUM2, IERR, ILOC1,
+ $ IPW1, ITER, ITT, JLOC1, JTT, K, LIWMIN, LLDT,
+ $ LLDQ, LWMIN, MMAX, MMIN, MYROW, MYCOL, N1, N2,
+ $ NB, NOEXSY, NPCOL, NPROCS, NPROW, SPACE,
+ $ T12ROWS, T12COLS, TCOLS, TCSRC, TROWS, TRSRC,
+ $ WRK1, IWRK1, WRK2, IWRK2, WRK3, IWRK3
+ REAL DPDUM1, ELEM, EST, SCALE, RNORM
+* .. Local Arrays ..
+ INTEGER DESCT12( DLEN_ ), MBNB2( 2 )
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ INTEGER NUMROC
+ REAL PSLANGE
+ EXTERNAL LSAME, NUMROC, PSLANGE
+* ..
+* .. External Subroutines ..
+ EXTERNAL BLACS_GRIDINFO, CHK1MAT, DESCINIT,
+ $ IGAMX2D, INFOG2L, PSLACPY, PSTRORD, PXERBLA,
+ $ PCHK1MAT, PCHK2MAT
+* $ , PGESYCTD, PSYCTCON
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, MIN, SQRT
+* ..
+* .. Executable Statements ..
+*
+* Get grid parameters
+*
+ ICTXT = DESCT( CTXT_ )
+ CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL )
+ NPROCS = NPROW*NPCOL
+*
+* Test if grid is O.K., i.e., the context is valid
+*
+ INFO = 0
+ IF( NPROW.EQ.-1 ) THEN
+ INFO = N+1
+ END IF
+*
+* Check if workspace
+*
+ LQUERY = LWORK.EQ.-1 .OR. LIWORK.EQ.-1
+*
+* Test dimensions for local sanity
+*
+ IF( INFO.EQ.0 ) THEN
+ CALL CHK1MAT( N, 5, N, 5, IT, JT, DESCT, 9, INFO )
+ END IF
+ IF( INFO.EQ.0 ) THEN
+ CALL CHK1MAT( N, 5, N, 5, IQ, JQ, DESCQ, 13, INFO )
+ END IF
+*
+* Check the blocking sizes for alignment requirements
+*
+ IF( INFO.EQ.0 ) THEN
+ IF( DESCT( MB_ ).NE.DESCT( NB_ ) ) INFO = -(1000*9 + MB_)
+ END IF
+ IF( INFO.EQ.0 ) THEN
+ IF( DESCQ( MB_ ).NE.DESCQ( NB_ ) ) INFO = -(1000*13 + MB_)
+ END IF
+ IF( INFO.EQ.0 ) THEN
+ IF( DESCT( MB_ ).NE.DESCQ( MB_ ) ) INFO = -(1000*9 + MB_)
+ END IF
+*
+* Check the blocking sizes for minimum sizes
+*
+ IF( INFO.EQ.0 ) THEN
+ IF( N.NE.DESCT( MB_ ) .AND. DESCT( MB_ ).LT.3 )
+ $ INFO = -(1000*9 + MB_)
+ IF( N.NE.DESCQ( MB_ ) .AND. DESCQ( MB_ ).LT.3 )
+ $ INFO = -(1000*13 + MB_)
+ END IF
+*
+* Check parameters in PARA
+*
+ NB = DESCT( MB_ )
+ IF( INFO.EQ.0 ) THEN
+ IF( PARA(1).LT.1 .OR. PARA(1).GT.MIN(NPROW,NPCOL) )
+ $ INFO = -(1000 * 4 + 1)
+ IF( PARA(2).LT.1 .OR. PARA(2).GE.PARA(3) )
+ $ INFO = -(1000 * 4 + 2)
+ IF( PARA(3).LT.1 .OR. PARA(3).GT.NB )
+ $ INFO = -(1000 * 4 + 3)
+ IF( PARA(4).LT.0 .OR. PARA(4).GT.100 )
+ $ INFO = -(1000 * 4 + 4)
+ IF( PARA(5).LT.1 .OR. PARA(5).GT.NB )
+ $ INFO = -(1000 * 4 + 5)
+ IF( PARA(6).LT.1 .OR. PARA(6).GT.PARA(2) )
+ $ INFO = -(1000 * 4 + 6)
+ END IF
+*
+* Check requirements on IT, JT, IQ and JQ
+*
+ IF( INFO.EQ.0 ) THEN
+ IF( IT.NE.1 ) INFO = -7
+ IF( JT.NE.IT ) INFO = -8
+ IF( IQ.NE.1 ) INFO = -11
+ IF( JQ.NE.IQ ) INFO = -12
+ END IF
+*
+* Test input parameters for global sanity
+*
+ IF( INFO.EQ.0 ) THEN
+ CALL PCHK1MAT( N, 5, N, 5, IT, JT, DESCT, 9, 0, IDUM1,
+ $ IDUM2, INFO )
+ END IF
+ IF( INFO.EQ.0 ) THEN
+ CALL PCHK1MAT( N, 5, N, 5, IQ, JQ, DESCQ, 13, 0, IDUM1,
+ $ IDUM2, INFO )
+ END IF
+ IF( INFO.EQ.0 ) THEN
+ CALL PCHK2MAT( N, 5, N, 5, IT, JT, DESCT, 9, N, 5, N, 5,
+ $ IQ, JQ, DESCQ, 13, 0, IDUM1, IDUM2, INFO )
+ END IF
+*
+* Decode and test the input parameters
+*
+ IF( INFO.EQ.0 .OR. LQUERY ) THEN
+ WANTBH = LSAME( JOB, 'B' )
+ WANTS = LSAME( JOB, 'E' ) .OR. WANTBH
+ WANTSP = LSAME( JOB, 'V' ) .OR. WANTBH
+ WANTQ = LSAME( COMPQ, 'V' )
+*
+ IF( .NOT.LSAME( JOB, 'N' ) .AND. .NOT.WANTS .AND. .NOT.WANTSP )
+ $ THEN
+ INFO = -1
+ ELSEIF( .NOT.LSAME( COMPQ, 'N' ) .AND. .NOT.WANTQ ) THEN
+ INFO = -2
+ ELSEIF( N.LT.0 ) THEN
+ INFO = -4
+ ELSE
+*
+* Extract local leading dimension
+*
+ LLDT = DESCT( LLD_ )
+ LLDQ = DESCQ( LLD_ )
+*
+* Check the SELECT vector for consistency and set M to the
+* dimension of the specified invariant subspace.
+*
+ M = 0
+ DO 10 K = 1, N
+*
+* IWORK(1:N) is an integer copy of SELECT.
+*
+ IF( SELECT(K) ) THEN
+ IWORK(K) = 1
+ ELSE
+ IWORK(K) = 0
+ END IF
+ IF( K.LT.N ) THEN
+ CALL INFOG2L( K+1, K, DESCT, NPROW, NPCOL,
+ $ MYROW, MYCOL, ITT, JTT, TRSRC, TCSRC )
+ IF( MYROW.EQ.TRSRC .AND. MYCOL.EQ.TCSRC ) THEN
+ ELEM = T( (JTT-1)*LLDT + ITT )
+ IF( ELEM.NE.ZERO ) THEN
+ IF( SELECT(K) .AND. .NOT.SELECT(K+1) ) THEN
+* INFO = -3
+ IWORK(K+1) = 1
+ ELSEIF( .NOT.SELECT(K) .AND. SELECT(K+1) ) THEN
+* INFO = -3
+ IWORK(K) = 1
+ END IF
+ END IF
+ END IF
+ END IF
+ IF( SELECT(K) ) M = M + 1
+ 10 CONTINUE
+ MMAX = M
+ MMIN = M
+ IF( NPROCS.GT.1 )
+ $ CALL IGAMX2D( ICTXT, 'All', TOP, 1, 1, MMAX, 1, -1,
+ $ -1, -1, -1, -1 )
+ IF( NPROCS.GT.1 )
+ $ CALL IGAMN2D( ICTXT, 'All', TOP, 1, 1, MMIN, 1, -1,
+ $ -1, -1, -1, -1 )
+ IF( MMAX.GT.MMIN ) THEN
+ M = MMAX
+ IF( NPROCS.GT.1 )
+ $ CALL IGAMX2D( ICTXT, 'All', TOP, N, 1, IWORK, N,
+ $ -1, -1, -1, -1, -1 )
+ END IF
+*
+* Set parameters for deep pipelining in parallel
+* Sylvester solver.
+*
+ MBNB2( 1 ) = MIN( MAX( PARA( 3 ), PARA( 2 )*2 ), NB )
+ MBNB2( 2 ) = MBNB2( 1 )
+*
+* Compute needed workspace
+*
+ N1 = M
+ N2 = N - M
+ IF( WANTS ) THEN
+c CALL PGESYCTD( 'Solve', 'Schur', 'Schur', 'Notranspose',
+c $ 'Notranspose', -1, 'Demand', N1, N2, T, 1, 1, DESCT,
+c $ T, N1+1, N1+1, DESCT, T, 1, N1+1, DESCT, MBNB2,
+c $ WORK, -1, IWORK(N+1), -1, NOEXSY, SCALE, IERR )
+ WRK1 = INT(WORK(1))
+ IWRK1 = IWORK(N+1)
+ WRK1 = 0
+ IWRK1 = 0
+ ELSE
+ WRK1 = 0
+ IWRK1 = 0
+ END IF
+*
+ IF( WANTSP ) THEN
+c CALL PSYCTCON( 'Notranspose', 'Notranspose', -1,
+c $ 'Demand', N1, N2, T, 1, 1, DESCT, T, N1+1, N1+1,
+c $ DESCT, MBNB2, WORK, -1, IWORK(N+1), -1, EST, ITER,
+c $ IERR )
+ WRK2 = INT(WORK(1))
+ IWRK2 = IWORK(N+1)
+ WRK2 = 0
+ IWRK2 = 0
+ ELSE
+ WRK2 = 0
+ IWRK2 = 0
+ END IF
+*
+ TROWS = NUMROC( N, NB, MYROW, DESCT(RSRC_), NPROW )
+ TCOLS = NUMROC( N, NB, MYCOL, DESCT(CSRC_), NPCOL )
+ WRK3 = N + 7*NB**2 + 2*TROWS*PARA( 3 ) + TCOLS*PARA( 3 ) +
+ $ MAX( TROWS*PARA( 3 ), TCOLS*PARA( 3 ) )
+ IWRK3 = 5*PARA( 1 ) + PARA(2)*PARA(3) -
+ $ PARA(2) * (PARA(2) + 1 ) / 2
+*
+ IF( WANTSP ) THEN
+ LWMIN = MAX( 1, MAX( WRK2, WRK3) )
+ LIWMIN = MAX( 1, MAX( IWRK2, IWRK3 ) )+N
+ ELSE IF( LSAME( JOB, 'N' ) ) THEN
+ LWMIN = MAX( 1, WRK3 )
+ LIWMIN = IWRK3+N
+ ELSE IF( LSAME( JOB, 'E' ) ) THEN
+ LWMIN = MAX( 1, MAX( WRK1, WRK3) )
+ LIWMIN = MAX( 1, MAX( IWRK1, IWRK3 ) )+N
+ END IF
+*
+ IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN
+ INFO = -20
+ ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN
+ INFO = -22
+ END IF
+ END IF
+ END IF
+*
+* Global maximum on info
+*
+ IF( NPROCS.GT.1 )
+ $ CALL IGAMX2D( ICTXT, 'All', TOP, 1, 1, INFO, 1, -1, -1, -1,
+ $ -1, -1 )
+*
+* Return if some argument is incorrect
+*
+ IF( INFO.NE.0 .AND. .NOT.LQUERY ) THEN
+ M = 0
+ S = ONE
+ SEP = ZERO
+ CALL PXERBLA( ICTXT, 'PSTRSEN', -INFO )
+ RETURN
+ ELSEIF( LQUERY ) THEN
+ WORK( 1 ) = FLOAT(LWMIN)
+ IWORK( 1 ) = LIWMIN
+ RETURN
+ END IF
+*
+* Quick return if possible.
+*
+ IF( M.EQ.N .OR. M.EQ.0 ) THEN
+ IF( WANTS )
+ $ S = ONE
+ IF( WANTSP )
+ $ SEP = PSLANGE( '1', N, N, T, IT, JT, DESCT, WORK )
+ GO TO 50
+ END IF
+*
+* Reorder the eigenvalues.
+*
+ CALL PSTRORD( COMPQ, IWORK, PARA, N, T, IT, JT,
+ $ DESCT, Q, IQ, JQ, DESCQ, WR, WI, M, WORK, LWORK,
+ $ IWORK(N+1), LIWORK-N, INFO )
+*
+ IF( WANTS ) THEN
+*
+* Solve Sylvester equation T11*R - R*T2 = scale*T12 for R in
+* parallel.
+*
+* Copy T12 to workspace.
+*
+ CALL INFOG2L( 1, N1+1, DESCT, NPROW, NPCOL, MYROW,
+ $ MYCOL, ILOC1, JLOC1, TRSRC, TCSRC )
+ ICOFFT12 = MOD( N1, NB )
+ T12ROWS = NUMROC( N1, NB, MYROW, TRSRC, NPROW )
+ T12COLS = NUMROC( N2+ICOFFT12, NB, MYCOL, TCSRC, NPCOL )
+ CALL DESCINIT( DESCT12, N1, N2+ICOFFT12, NB, NB, TRSRC,
+ $ TCSRC, ICTXT, MAX(1,T12ROWS), IERR )
+ CALL PSLACPY( 'All', N1, N2, T, 1, N1+1, DESCT, WORK,
+ $ 1, 1+ICOFFT12, DESCT12 )
+*
+* Solve the equation to get the solution in workspace.
+*
+ SPACE = DESCT12( LLD_ ) * T12COLS
+ IPW1 = 1 + SPACE
+c CALL PGESYCTD( 'Solve', 'Schur', 'Schur', 'Notranspose',
+c $ 'Notranspose', -1, 'Demand', N1, N2, T, 1, 1, DESCT, T,
+c $ N1+1, N1+1, DESCT, WORK, 1, 1+ICOFFT12, DESCT12, MBNB2,
+c $ WORK(IPW1), LWORK-SPACE+1, IWORK(N+1), LIWORK-N, NOEXSY,
+c $ SCALE, IERR )
+ IF( IERR.LT.0 ) THEN
+ INFO = N+3
+ ELSE
+ INFO = N+2
+ END IF
+*
+* Estimate the reciprocal of the condition number of the cluster
+* of eigenvalues.
+*
+ RNORM = PSLANGE( 'Frobenius', N1, N2, WORK, 1, 1+ICOFFT12,
+ $ DESCT12, DPDUM1 )
+ 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,T21) in parallel.
+*
+c CALL PSYCTCON( 'Notranspose', 'Notranspose', -1, 'Demand', N1,
+c $ N2, T, 1, 1, DESCT, T, N1+1, N1+1, DESCT, MBNB2, WORK,
+c $ LWORK, IWORK(N+1), LIWORK-N, EST, ITER, IERR )
+ EST = EST * SQRT(FLOAT(N1*N2))
+ SEP = ONE / EST
+ IF( IERR.LT.0 ) THEN
+ INFO = N+4
+ ELSE
+ INFO = N+2
+ END IF
+ END IF
+*
+* Return to calling program.
+*
+ 50 CONTINUE
+*
+ RETURN
+*
+* End of PSTRSEN
+*
+ END
+*
diff --git a/SRC/pzdbtrf.f b/SRC/pzdbtrf.f
index 01a13ff..6c15e29 100644
--- a/SRC/pzdbtrf.f
+++ b/SRC/pzdbtrf.f
@@ -1,12 +1,9 @@
SUBROUTINE PZDBTRF( N, BWL, BWU, A, JA, DESCA, AF, LAF, WORK,
$ LWORK, INFO )
*
-*
-*
-* -- ScaLAPACK routine (version 1.7) --
-* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
-* and University of California, Berkeley.
-* May 25, 2001
+* -- ScaLAPACK routine (version 2.0.2) --
+* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver
+* May 1 2012
*
* .. Scalar Arguments ..
INTEGER BWL, BWU, INFO, JA, LAF, LWORK, N
@@ -381,7 +378,7 @@
* .. External Subroutines ..
EXTERNAL BLACS_GET, BLACS_GRIDEXIT, BLACS_GRIDINFO,
$ DESC_CONVERT, GLOBCHK, PXERBLA, RESHAPE, ZAXPY,
- $ ZGEMM, ZGERV2D, ZGESD2D, ZLACPY, ZLATCPY,
+ $ ZGEMM, ZGERV2D, ZGESD2D, ZLAMOV, ZLATCPY,
$ ZPBTRF, ZPOTRF, ZSYRK, ZTBTRS, ZTRMM, ZTRRV2D,
$ ZTRSD2D, ZTRSM, ZTRTRS
* ..
@@ -743,7 +740,7 @@
$ A(( OFST+(BWL+BWU+1)+(ODD_SIZE-BWL)*LLDA )),
$ LLDA-1, AF( ODD_SIZE*BWU+2*MBW2+1+MAX_BW-BWL ),
$ MAX_BW )
- CALL ZLACPY( 'L', BWU, BWU, A( ( OFST+1+ODD_SIZE*LLDA ) ),
+ CALL ZLAMOV( 'L', BWU, BWU, A( ( OFST+1+ODD_SIZE*LLDA ) ),
$ LLDA-1,
$ AF( WORK_U+ODD_SIZE*BWL+2*MBW2+1+MAX_BW-BWU ),
$ MAX_BW )
@@ -772,7 +769,7 @@
*
* Move the resulting block back to its location in main storage.
*
- CALL ZLACPY( 'L', BWU, BWU,
+ CALL ZLAMOV( 'L', BWU, BWU,
$ AF( WORK_U+ODD_SIZE*BWL+2*MBW2+1+MAX_BW-BWU ),
$ MAX_BW, A(( OFST+1+ODD_SIZE*LLDA )), LLDA-1 )
*
@@ -952,7 +949,7 @@
* Copy last diagonal block into AF storage for subsequent
* operations.
*
- CALL ZLACPY( 'N', MAX_BW, MAX_BW,
+ CALL ZLAMOV( 'N', MAX_BW, MAX_BW,
$ A( OFST+ODD_SIZE*LLDA+BWU+1 ),
$ LLDA-1, AF( ODD_SIZE*BWU+MBW2+1 ),
$ MAX_BW )
@@ -1040,11 +1037,11 @@
* Move block into place that it will be expected to be for
* calcs.
*
- CALL ZLACPY( 'N', MAX_BW, MAX_BW, AF( ODD_SIZE*BWU+1 ),
+ CALL ZLAMOV( 'N', MAX_BW, MAX_BW, AF( ODD_SIZE*BWU+1 ),
$ MAX_BW, AF( WORK_U+ODD_SIZE*BWL+2*MBW2+1 ),
$ MAX_BW )
*
- CALL ZLACPY( 'N', MAX_BW, MAX_BW, AF( WORK_U+ODD_SIZE*BWL+1 ),
+ CALL ZLAMOV( 'N', MAX_BW, MAX_BW, AF( WORK_U+ODD_SIZE*BWL+1 ),
$ MAX_BW, AF( ODD_SIZE*BWU+2*MBW2+1 ), MAX_BW )
*
ELSE
diff --git a/SRC/pzdbtrsv.f b/SRC/pzdbtrsv.f
index afc453c..e6d1735 100644
--- a/SRC/pzdbtrsv.f
+++ b/SRC/pzdbtrsv.f
@@ -1,12 +1,9 @@
SUBROUTINE PZDBTRSV( UPLO, TRANS, N, BWL, BWU, NRHS, A, JA, DESCA,
$ B, IB, DESCB, AF, LAF, WORK, LWORK, INFO )
*
-*
-*
-* -- ScaLAPACK routine (version 1.7) --
-* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
-* and University of California, Berkeley.
-* November 15, 1997
+* -- ScaLAPACK routine (version 2.0.2) --
+* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver
+* May 1 2012
*
* .. Scalar Arguments ..
CHARACTER TRANS, UPLO
@@ -404,7 +401,7 @@
* .. External Subroutines ..
EXTERNAL BLACS_GET, BLACS_GRIDEXIT, BLACS_GRIDINFO,
$ DESC_CONVERT, GLOBCHK, PXERBLA, RESHAPE, ZGEMM,
- $ ZGERV2D, ZGESD2D, ZLACPY, ZMATADD, ZTBTRS,
+ $ ZGERV2D, ZGESD2D, ZLAMOV, ZMATADD, ZTBTRS,
$ ZTRMM, ZTRTRS
* ..
* .. External Functions ..
@@ -787,7 +784,7 @@
* First copy and multiply it into temporary storage,
* then use it on RHS
*
- CALL ZLACPY( 'N', BWL, NRHS,
+ CALL ZLAMOV( 'N', BWL, NRHS,
$ B( PART_OFFSET+ODD_SIZE-BWL+1), LLDB,
$ WORK( 1 ), MAX_BW )
*
@@ -1138,7 +1135,7 @@
* First copy and multiply it into temporary storage,
* then use it on RHS
*
- CALL ZLACPY( 'N', BWL, NRHS, B( PART_OFFSET+ODD_SIZE+1), LLDB,
+ CALL ZLAMOV( 'N', BWL, NRHS, B( PART_OFFSET+ODD_SIZE+1), LLDB,
$ WORK( 1+MAX_BW-BWL ), MAX_BW )
*
CALL ZTRMM( 'L', 'U', 'C', 'N', BWL, NRHS, -CONE,
@@ -1191,7 +1188,7 @@
* First copy and multiply it into temporary storage,
* then use it on RHS
*
- CALL ZLACPY( 'N', BWU, NRHS,
+ CALL ZLAMOV( 'N', BWU, NRHS,
$ B( PART_OFFSET+ODD_SIZE-BWU+1), LLDB,
$ WORK( 1 ), MAX_BW )
*
@@ -1544,7 +1541,7 @@
* First copy and multiply it into temporary storage,
* then use it on RHS
*
- CALL ZLACPY( 'N', BWU, NRHS, B( PART_OFFSET+ODD_SIZE+1), LLDB,
+ CALL ZLAMOV( 'N', BWU, NRHS, B( PART_OFFSET+ODD_SIZE+1), LLDB,
$ WORK( 1+MAX_BW-BWU ), MAX_BW+BWL )
*
CALL ZTRMM( 'L', 'L', 'N', 'N', BWU, NRHS, -CONE,
diff --git a/SRC/pzdttrf.f b/SRC/pzdttrf.f
index 626f6d8..65b116c 100644
--- a/SRC/pzdttrf.f
+++ b/SRC/pzdttrf.f
@@ -1,12 +1,9 @@
SUBROUTINE PZDTTRF( N, DL, D, DU, JA, DESCA, AF, LAF, WORK, LWORK,
$ INFO )
*
-*
-*
-* -- ScaLAPACK routine (version 1.7) --
-* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
-* and University of California, Berkeley.
-* May 25, 2001
+* -- ScaLAPACK routine (version 2.0.2) --
+* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver
+* May 1 2012
*
* .. Scalar Arguments ..
INTEGER INFO, JA, LAF, LWORK, N
@@ -386,7 +383,7 @@
* .. External Subroutines ..
EXTERNAL BLACS_GET, BLACS_GRIDEXIT, BLACS_GRIDINFO,
$ DESC_CONVERT, GLOBCHK, PXERBLA, RESHAPE, ZAXPY,
- $ ZGEMM, ZGERV2D, ZGESD2D, ZLACPY, ZLATCPY,
+ $ ZGEMM, ZGERV2D, ZGESD2D, ZLAMOV, ZLATCPY,
$ ZPBTRF, ZPOTRF, ZSYRK, ZTBTRS, ZTRMM, ZTRRV2D,
$ ZTRSD2D, ZTRSM, ZTRTRS
* ..
diff --git a/SRC/pzdttrsv.f b/SRC/pzdttrsv.f
index f220925..5ec1747 100644
--- a/SRC/pzdttrsv.f
+++ b/SRC/pzdttrsv.f
@@ -1,12 +1,9 @@
SUBROUTINE PZDTTRSV( UPLO, TRANS, N, NRHS, DL, D, DU, JA, DESCA,
$ B, IB, DESCB, AF, LAF, WORK, LWORK, INFO )
*
-*
-*
-* -- ScaLAPACK routine (version 1.7) --
-* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
-* and University of California, Berkeley.
-* November 15, 1997
+* -- ScaLAPACK routine (version 2.0.2) --
+* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver
+* May 1 2012
*
* .. Scalar Arguments ..
CHARACTER TRANS, UPLO
@@ -418,7 +415,7 @@
* .. External Subroutines ..
EXTERNAL BLACS_GET, BLACS_GRIDEXIT, BLACS_GRIDINFO,
$ DESC_CONVERT, GLOBCHK, PXERBLA, RESHAPE, ZGEMM,
- $ ZGERV2D, ZGESD2D, ZLACPY, ZMATADD, ZTBTRS,
+ $ ZGERV2D, ZGESD2D, ZLAMOV, ZMATADD, ZTBTRS,
$ ZTRMM, ZTRTRS
* ..
* .. External Functions ..
diff --git a/SRC/pzgbtrf.f b/SRC/pzgbtrf.f
index b27516e..5dededb 100644
--- a/SRC/pzgbtrf.f
+++ b/SRC/pzgbtrf.f
@@ -1,12 +1,9 @@
SUBROUTINE PZGBTRF( N, BWL, BWU, A, JA, DESCA, IPIV, AF, LAF,
$ WORK, LWORK, INFO )
*
-*
-*
-* -- ScaLAPACK routine (version 1.7) --
-* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
-* and University of California, Berkeley.
-* November 15, 1997
+* -- ScaLAPACK routine (version 2.0.2) --
+* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver
+* May 1 2012
*
* .. Scalar Arguments ..
INTEGER BWL, BWU, INFO, JA, LAF, LWORK, N
@@ -390,7 +387,7 @@
* .. External Subroutines ..
EXTERNAL BLACS_GRIDEXIT, BLACS_GRIDINFO, DESC_CONVERT,
$ GLOBCHK, PXERBLA, RESHAPE, ZAXPY, ZGEMM,
- $ ZGERV2D, ZGESD2D, ZLACPY, ZLATCPY, ZPBTRF,
+ $ ZGERV2D, ZGESD2D, ZLAMOV, ZLATCPY, ZPBTRF,
$ ZPOTRF, ZSYRK, ZTBTRS, ZTRMM, ZTRRV2D, ZTRSD2D,
$ ZTRSM, ZTRTRS
* ..
@@ -841,7 +838,7 @@
* DBPTR = Pointer to diagonal blocks in A
DBPTR = BW+1 + LBWU + LN*LLDA
*
- CALL ZLACPY('G',BM,BN, A(DBPTR),LLDA-1,
+ CALL ZLAMOV('G',BM,BN, A(DBPTR),LLDA-1,
$ AF(BBPTR + BW*LDBB),LDBB)
*
* Zero out any junk entries that were copied
@@ -857,7 +854,7 @@
* ODPTR = Pointer to offdiagonal blocks in A
*
ODPTR = LM-BM+1
- CALL ZLACPY('G',BM,BW, AF(ODPTR),LM,
+ CALL ZLAMOV('G',BM,BW, AF(ODPTR),LM,
$ AF(BBPTR +2*BW*LDBB),LDBB)
ENDIF
*
@@ -924,7 +921,7 @@
*
* Copy diagonal block to align whole system
*
- CALL ZLACPY( 'G', BMN, BW, AF( BBPTR+BM ),
+ CALL ZLAMOV( 'G', BMN, BW, AF( BBPTR+BM ),
$ LDBB, AF( BBPTR+2*BW*LDBB+BM ), LDBB )
ENDIF
*
@@ -950,7 +947,7 @@
CALL ZGESD2D( ICTXT, BM, 2*BW, AF(BBPTR+BW*LDBB),
$ LDBB, 0, NEICOL )
*
- CALL ZLACPY('G',BM, 2*BW, AF(BBPTR+BW*LDBB),LDBB,
+ CALL ZLAMOV('G',BM, 2*BW, AF(BBPTR+BW*LDBB),LDBB,
$ AF(BBPTR+BMN),LDBB)
*
DO 31 J=BBPTR+2*BW*LDBB, BBPTR+3*BW*LDBB-1, LDBB
@@ -966,7 +963,7 @@
*
* Copy diagonal block to align whole system
*
- CALL ZLACPY( 'G', BM, BW, AF( BBPTR+BMN ),
+ CALL ZLAMOV( 'G', BM, BW, AF( BBPTR+BMN ),
$ LDBB, AF( BBPTR+2*BW*LDBB+BMN ), LDBB )
ENDIF
*
@@ -1029,10 +1026,10 @@
* Local copying in the block bidiagonal area
*
*
- CALL ZLACPY('G',BM,BW,
+ CALL ZLAMOV('G',BM,BW,
$ AF(BBPTR+BW),
$ LDBB, AF(BBPTR+BW*LDBB), LDBB)
- CALL ZLACPY('G',BM,BW,
+ CALL ZLAMOV('G',BM,BW,
$ AF(BBPTR+2*BW*LDBB+BW),
$ LDBB, AF(BBPTR+2*BW*LDBB), LDBB)
*
diff --git a/SRC/pzgbtrs.f b/SRC/pzgbtrs.f
index 8f6aabf..c2d16aa 100644
--- a/SRC/pzgbtrs.f
+++ b/SRC/pzgbtrs.f
@@ -1,12 +1,9 @@
SUBROUTINE PZGBTRS( TRANS, N, BWL, BWU, NRHS, A, JA, DESCA, IPIV,
$ B, IB, DESCB, AF, LAF, WORK, LWORK, INFO )
*
-*
-*
-* -- ScaLAPACK routine (version 1.7) --
-* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
-* and University of California, Berkeley.
-* August 7, 2001
+* -- ScaLAPACK routine (version 2.0.2) --
+* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver
+* May 1 2012
*
* .. Scalar Arguments ..
CHARACTER TRANS
@@ -737,7 +734,7 @@
*
LDW = NB+BWU + 2*BW+BWU
*
- CALL ZLACPY( 'G', LM, NRHS, B(1), LLDB, WORK( WPTR ), LDW )
+ CALL ZLAMOV( 'G', LM, NRHS, B(1), LLDB, WORK( WPTR ), LDW )
*
* Zero out rest of work
*
@@ -882,7 +879,7 @@
BMN = BW
ENDIF
*
- CALL ZLACPY( 'G', BM, NRHS, WORK(LN+1), LDW,
+ CALL ZLAMOV( 'G', BM, NRHS, WORK(LN+1), LDW,
$ WORK(NB+BWU+BMN+1), LDW )
*
CALL ZGERV2D( ICTXT, BMN, NRHS, WORK( NB+BWU+1 ),
@@ -1029,7 +1026,7 @@
*
* Move RHS to make room for received solutions
*
- CALL ZLACPY( 'G', BW, NRHS, WORK(NB+BWU+1),
+ CALL ZLAMOV( 'G', BW, NRHS, WORK(NB+BWU+1),
$ LDW, WORK(NB+BWU+BW+1), LDW )
*
CALL ZGERV2D( ICTXT, 2*BW, NRHS, WORK( LN+1 ),
@@ -1060,7 +1057,7 @@
*
* Copy new solution into expected place
*
- CALL ZLACPY( 'G', BW, NRHS, WORK(NB+BWU+1+BW),
+ CALL ZLAMOV( 'G', BW, NRHS, WORK(NB+BWU+1+BW),
$ LDW, WORK(LN+BW+1), LDW )
*
ELSE
@@ -1077,7 +1074,7 @@
*
* Shift solutions into expected positions
*
- CALL ZLACPY( 'G', BNN+BN-BW, NRHS, WORK(NB+BWU+1+BW),
+ CALL ZLAMOV( 'G', BNN+BN-BW, NRHS, WORK(NB+BWU+1+BW),
$ LDW, WORK(LN+1), LDW )
*
*
@@ -1155,7 +1152,7 @@
*
*
*
- CALL ZLACPY( 'G', ODD_SIZE, NRHS, WORK( 1 ), LDW,
+ CALL ZLAMOV( 'G', ODD_SIZE, NRHS, WORK( 1 ), LDW,
$ B( 1 ), LLDB )
*
* Free BLACS space used to hold standard-form grid.
diff --git a/SRC/pzgecon.f b/SRC/pzgecon.f
index 837dd4b..5522e71 100644
--- a/SRC/pzgecon.f
+++ b/SRC/pzgecon.f
@@ -154,7 +154,7 @@
* LRWORK (local or global input) INTEGER
* The dimension of the array RWORK.
* LRWORK is local input and must be at least
-* LRWORK >= 2*LOCc(N+MOD(JA-1,NB_A)).
+* LRWORK >= MAX( 1, 2*LOCc(N+MOD(JA-1,NB_A)) ).
*
* If LRWORK = -1, then LRWORK is global input and a workspace
* query is assumed; the routine only calculates the minimum
@@ -246,7 +246,7 @@
$ DESCA( NB_ )*
$ MAX( 1, ICEIL( NPCOL-1, NPROW ) ) ) )
WORK( 1 ) = DBLE( LWMIN )
- LRWMIN = 2*NQMOD
+ LRWMIN = MAX( 1, 2*NQMOD )
RWORK( 1 ) = DBLE( LRWMIN )
LQUERY = ( LWORK.EQ.-1 .OR. LRWORK.EQ.-1 )
*
diff --git a/SRC/pzgels.f b/SRC/pzgels.f
index 4936d65..f39baf1 100644
--- a/SRC/pzgels.f
+++ b/SRC/pzgels.f
@@ -280,7 +280,11 @@
INFO = -( 800 + CTXT_ )
ELSE
CALL CHK1MAT( M, 2, N, 3, IA, JA, DESCA, 8, INFO )
- CALL CHK1MAT( N, 3, NRHS, 4, IB, JB, DESCB, 12, INFO )
+ IF ( M .GE. N ) THEN
+ CALL CHK1MAT( M, 2, NRHS, 4, IB, JB, DESCB, 12, INFO )
+ ELSE
+ CALL CHK1MAT( N, 3, NRHS, 4, IB, JB, DESCB, 12, INFO )
+ ENDIF
IF( INFO.EQ.0 ) THEN
IROFFA = MOD( IA-1, DESCA( MB_ ) )
ICOFFA = MOD( JA-1, DESCA( NB_ ) )
diff --git a/SRC/pzheev.f b/SRC/pzheev.f
index 296a07b..8aca69e 100644
--- a/SRC/pzheev.f
+++ b/SRC/pzheev.f
@@ -20,7 +20,7 @@
* =======
*
* PZHEEV computes selected eigenvalues and, optionally, eigenvectors
-* of a real symmetric matrix A by calling the recommended sequence
+* of a complex Hermitian matrix A by calling the recommended sequence
* of ScaLAPACK routines.
*
* In its present form, PZHEEV assumes a homogeneous system and makes
@@ -91,7 +91,7 @@
*
* UPLO (global input) CHARACTER*1
* Specifies whether the upper or lower triangular part of the
-* symmetric matrix A is stored:
+* Hermitian matrix A is stored:
* = 'U': Upper triangular
* = 'L': Lower triangular
*
@@ -102,11 +102,11 @@
* global dimension (N, N), local dimension ( LLD_A,
* LOCc(JA+N-1) )
*
-* On entry, the symmetric matrix A. If UPLO = 'U', only the
+* On entry, the Hermitian matrix A. If UPLO = 'U', only the
* upper triangular part of A is used to define the elements of
-* the symmetric matrix. If UPLO = 'L', only the lower
+* the Hermitian matrix. If UPLO = 'L', only the lower
* triangular part of A is used to define the elements of the
-* symmetric matrix.
+* Hermitian matrix.
*
* On exit, the lower triangle (if UPLO='L') or the upper
* triangle (if UPLO='U') of A, including the diagonal, is
@@ -126,8 +126,7 @@
* correct error reporting.
*
* W (global output) DOUBLE PRECISION array, dimension (N)
-* On normal exit, the first M entries contain the selected
-* eigenvalues in ascending order.
+* If INFO=0, the eigenvalues in ascending order.
*
* Z (local output) COMPLEX*16 array,
* global dimension (N, N),
@@ -354,6 +353,9 @@
RSRC_Z = DESCZ( RSRC_ )
IROFFZ = MOD( IZ-1, MB_A )
IZROW = INDXG2P( 1, NB_A, MYROW, RSRC_Z, NPROW )
+ ELSE
+ IROFFZ = 0
+ IZROW = 0
END IF
*
* COMPLEX*16 work space for PZHETRD
@@ -524,7 +526,7 @@
CALL PZLASCL( UPLO, ONE, SIGMA, N, N, A, IA, JA, DESCA, IINFO )
END IF
*
-* Reduce symmetric matrix to tridiagonal form.
+* Reduce Hermitian matrix to tridiagonal form.
*
CALL PZHETRD( UPLO, N, A, IA, JA, DESCA, RWORK( INDRD ),
$ RWORK( INDRE ), WORK( INDTAU ), WORK( INDWORK ),
diff --git a/SRC/pzheevr.f b/SRC/pzheevr.f
new file mode 100644
index 0000000..4b7715d
--- /dev/null
+++ b/SRC/pzheevr.f
@@ -0,0 +1,1219 @@
+ SUBROUTINE PZHEEVR( JOBZ, RANGE, UPLO, N, A, IA, JA,
+ $ DESCA, VL, VU, IL, IU, M, NZ, W, Z, IZ,
+ $ JZ, DESCZ,
+ $ WORK, LWORK, RWORK, LRWORK, IWORK, LIWORK,
+ $ INFO )
+
+ IMPLICIT NONE
+*
+* -- ScaLAPACK routine (version 2.0.2) --
+* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver
+* May 1 2012
+*
+* .. Scalar Arguments ..
+ CHARACTER JOBZ, RANGE, UPLO
+
+ INTEGER IA, IL, INFO, IU, IZ, JA, JZ, LIWORK, LRWORK,
+ $ LWORK, M, N, NZ
+ DOUBLE PRECISION VL, VU
+* ..
+* .. Array Arguments ..
+ INTEGER DESCA( * ), DESCZ( * ), IWORK( * )
+ DOUBLE PRECISION W( * ), RWORK( * )
+ COMPLEX*16 A( * ), WORK( * ), Z( * )
+* ..
+*
+* Purpose
+* =======
+*
+* PZHEEVR computes selected eigenvalues and, optionally, eigenvectors
+* of a complex Hermitian matrix A distributed in 2D blockcyclic format
+* by calling the recommended sequence of ScaLAPACK routines.
+*
+* First, the matrix A is reduced to real symmetric tridiagonal form.
+* Then, the eigenproblem is solved using the parallel MRRR algorithm.
+* Last, if eigenvectors have been computed, a backtransformation is done.
+*
+* Upon successful completion, each processor stores a copy of all computed
+* eigenvalues in W. The eigenvector matrix Z is stored in
+* 2D blockcyclic format distributed over all processors.
+*
+* For constructive feedback and comments, please contact cvoemel at lbl.gov
+* C. Voemel
+*
+*
+* Arguments
+* =========
+*
+* JOBZ (global input) CHARACTER*1
+* Specifies whether or not to compute the eigenvectors:
+* = 'N': Compute eigenvalues only.
+* = 'V': Compute eigenvalues and eigenvectors.
+*
+* RANGE (global input) CHARACTER*1
+* = 'A': all eigenvalues will be found.
+* = 'V': all eigenvalues in the interval [VL,VU] will be found.
+* = 'I': the IL-th through IU-th eigenvalues will be found.
+*
+* UPLO (global input) CHARACTER*1
+* Specifies whether the upper or lower triangular part of the
+* symmetric matrix A is stored:
+* = 'U': Upper triangular
+* = 'L': Lower triangular
+*
+* N (global input) INTEGER
+* The number of rows and columns of the matrix A. N >= 0
+*
+* A (local input/workspace) 2D block cyclic COMPLEX*16 array,
+* global dimension (N, N),
+* local dimension ( LLD_A, LOCc(JA+N-1) )
+* (see Notes below for more detailed explanation of 2d arrays)
+*
+* On entry, the symmetric matrix A. If UPLO = 'U', only the
+* upper triangular part of A is used to define the elements of
+* the symmetric matrix. If UPLO = 'L', only the lower
+* triangular part of A is used to define the elements of the
+* symmetric matrix.
+*
+* On exit, the lower triangle (if UPLO='L') or the upper
+* triangle (if UPLO='U') of A, including the diagonal, is
+* destroyed.
+*
+* IA (global input) INTEGER
+* A's global row index, which points to the beginning of the
+* submatrix which is to be operated on.
+* It should be set to 1 when operating on a full matrix.
+*
+* JA (global input) INTEGER
+* A's global column index, which points to the beginning of
+* the submatrix which is to be operated on.
+* It should be set to 1 when operating on a full matrix.
+*
+* DESCA (global and local input) INTEGER array of dimension DLEN_.
+* (The ScaLAPACK descriptor length is DLEN_ = 9.)
+* The array descriptor for the distributed matrix A.
+* The descriptor stores details about the 2D block-cyclic
+* storage, see the notes below.
+* If DESCA is incorrect, PZHEEVR cannot work correctly.
+* Also note the array alignment requirements specified below
+*
+* VL (global input) DOUBLE PRECISION
+* If RANGE='V', the lower bound of the interval to be searched
+* for eigenvalues. Not referenced if RANGE = 'A' or 'I'.
+*
+* VU (global input) DOUBLE PRECISION
+* If RANGE='V', the upper bound of the interval to be searched
+* for eigenvalues. Not referenced if RANGE = 'A' or 'I'.
+*
+* IL (global input) INTEGER
+* If RANGE='I', the index (from smallest to largest) of the
+* smallest eigenvalue to be returned. IL >= 1.
+* Not referenced if RANGE = 'A'.
+*
+* IU (global input) INTEGER
+* If RANGE='I', the index (from smallest to largest) of the
+* largest eigenvalue to be returned. min(IL,N) <= IU <= N.
+* Not referenced if RANGE = 'A'.
+*
+* M (global output) INTEGER
+* Total number of eigenvalues found. 0 <= M <= N.
+*
+* NZ (global output) INTEGER
+* Total number of eigenvectors computed. 0 <= NZ <= M.
+* The number of columns of Z that are filled.
+* If JOBZ .NE. 'V', NZ is not referenced.
+* If JOBZ .EQ. 'V', NZ = M
+*
+* W (global output) DOUBLE PRECISION array, dimension (N)
+* On normal exit, the first M entries contain the selected
+* eigenvalues in ascending order.
+*
+* Z (local output) COMPLEX*16 array,
+* global dimension (N, N),
+* local dimension ( LLD_Z, LOCc(JZ+N-1) )
+* If JOBZ = 'V', then on normal exit the first M columns of Z
+* contain the orthonormal eigenvectors of the matrix
+* corresponding to the selected eigenvalues.
+* If JOBZ = 'N', then Z is not referenced.
+*
+* IZ (global input) INTEGER
+* Z's global row index, which points to the beginning of the
+* submatrix which is to be operated on.
+* It should be set to 1 when operating on a full matrix.
+*
+* JZ (global input) INTEGER
+* Z's global column index, which points to the beginning of
+* the submatrix which is to be operated on.
+* It should be set to 1 when operating on a full matrix.
+*
+* DESCZ (global and local input) INTEGER array of dimension DLEN_.
+* The array descriptor for the distributed matrix Z.
+* DESCZ( CTXT_ ) must equal DESCA( CTXT_ )
+*
+* WORK (local workspace/output) COMPLEX*16 array,
+* dimension (LWORK)
+* WORK(1) returns workspace adequate workspace to allow
+* optimal performance.
+*
+* LWORK (local input) INTEGER
+* Size of WORK array, must be at least 3.
+* If only eigenvalues are requested:
+* LWORK >= N + MAX( NB * ( NP00 + 1 ), NB * 3 )
+* If eigenvectors are requested:
+* LWORK >= N + ( NP00 + MQ00 + NB ) * NB
+* For definitions of NP00 & MQ00, see LRWORK.
+*
+* For optimal performance, greater workspace is needed, i.e.
+* LWORK >= MAX( LWORK, NHETRD_LWORK )
+* Where LWORK is as defined above, and
+* NHETRD_LWORK = N + 2*( ANB+1 )*( 4*NPS+2 ) +
+* ( NPS + 1 ) * NPS
+*
+* ICTXT = DESCA( CTXT_ )
+* ANB = PJLAENV( ICTXT, 3, 'PZHETTRD', 'L', 0, 0, 0, 0 )
+* SQNPC = SQRT( DBLE( NPROW * NPCOL ) )
+* NPS = MAX( NUMROC( N, 1, 0, 0, SQNPC ), 2*ANB )
+*
+* If LWORK = -1, then LWORK is global input and a workspace
+* query is assumed; the routine only calculates the
+* optimal size for all work arrays. Each of these
+* values is returned in the first entry of the corresponding
+* work array, and no error message is issued by PXERBLA.
+* NOTE THAT FOR OPTIMAL PERFORMANCE, LWOPT IS RETURNED
+* (THE OPTIMUM WORKSPACE) RATHER THAN THE MINIMUM NECESSARY
+* WORKSPACE LWMIN WHEN A WORKSPACE QUERY IS ISSUED.
+* FOR VERY SMALL MATRICES, LWOPT >> LWMIN.
+*
+* RWORK (local workspace/output) DOUBLE PRECISION array,
+* dimension (LRWORK)
+* On return, RWORK(1) contains the optimal amount of
+* workspace required for efficient execution.
+* if JOBZ='N' RWORK(1) = optimal amount of workspace
+* required to compute the eigenvalues.
+* if JOBZ='V' RWORK(1) = optimal amount of workspace
+* required to compute eigenvalues and eigenvectors.
+*
+* LRWORK (local input) INTEGER
+* Size of RWORK, must be at least 3.
+* See below for definitions of variables used to define LRWORK.
+* If no eigenvectors are requested (JOBZ = 'N') then
+* LRWORK >= 2 + 5 * N + MAX( 12 * N, NB * ( NP00 + 1 ) )
+* If eigenvectors are requested (JOBZ = 'V' ) then
+* the amount of workspace required is:
+* LRWORK >= 2 + 5 * N + MAX( 18*N, NP00 * MQ00 + 2 * NB * NB ) +
+* (2 + ICEIL( NEIG, NPROW*NPCOL))*N
+*
+* Variable definitions:
+* NEIG = number of eigenvectors requested
+* NB = DESCA( MB_ ) = DESCA( NB_ ) =
+* DESCZ( MB_ ) = DESCZ( NB_ )
+* NN = MAX( N, NB, 2 )
+* DESCA( RSRC_ ) = DESCA( NB_ ) = DESCZ( RSRC_ ) =
+* DESCZ( CSRC_ ) = 0
+* NP00 = NUMROC( NN, NB, 0, 0, NPROW )
+* MQ00 = NUMROC( MAX( NEIG, NB, 2 ), NB, 0, 0, NPCOL )
+* ICEIL( X, Y ) is a ScaLAPACK function returning
+* ceiling(X/Y)
+*
+* If LRWORK = -1, then LRWORK is global input and a workspace
+* query is assumed; the routine only calculates the size
+* required for optimal performance for all work arrays. Each of
+* these values is returned in the first entry of the
+* corresponding work arrays, and no error message is issued by
+* PXERBLA.
+*
+* IWORK (local workspace) INTEGER array
+* On return, IWORK(1) contains the amount of integer workspace
+* required.
+*
+* LIWORK (local input) INTEGER
+* size of IWORK
+*
+* Let NNP = MAX( N, NPROW*NPCOL + 1, 4 ). Then:
+* LIWORK >= 12*NNP + 2*N when the eigenvectors are desired
+* LIWORK >= 10*NNP + 2*N when only the eigenvalues have to be computed
+*
+* If LIWORK = -1, then LIWORK is global input and a workspace
+* query is assumed; the routine only calculates the minimum
+* and optimal size for all work arrays. Each of these
+* values is returned in the first entry of the corresponding
+* work array, and no error message is issued by PXERBLA.
+*
+* INFO (global output) INTEGER
+* = 0: successful exit
+* < 0: If the i-th argument is an array and the j-entry had
+* an illegal value, then INFO = -(i*100+j), if the i-th
+* argument is a scalar and had an illegal value, then
+* INFO = -i.
+*
+* Notes
+* =====
+*
+* Each global data object is described by an associated description
+* vector. This vector stores the information required to establish
+* the mapping between an object element and its corresponding process
+* and memory location.
+*
+* Let A be a generic term for any 2D block cyclicly distributed array.
+* Such a global array has an associated description vector DESCA.
+* In the following comments, the character _ should be read as
+* "of the global array".
+*
+* NOTATION STORED IN EXPLANATION
+* --------------- -------------- --------------------------------------
+* DTYPE_A(global) DESCA( DTYPE_ )The descriptor type. In this case,
+* DTYPE_A = 1.
+* CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating
+* the BLACS process grid A is distribu-
+* ted over. The context itself is glo-
+* bal, but the handle (the integer
+* value) may vary.
+* M_A (global) DESCA( M_ ) The number of rows in the global
+* array A.
+* N_A (global) DESCA( N_ ) The number of columns in the global
+* array A.
+* MB_A (global) DESCA( MB_ ) The blocking factor used to distribute
+* the rows of the array.
+* NB_A (global) DESCA( NB_ ) The blocking factor used to distribute
+* the columns of the array.
+* RSRC_A (global) DESCA( RSRC_ ) The process row over which the first
+* row of the array A is distributed.
+* CSRC_A (global) DESCA( CSRC_ ) The process column over which the
+* first column of the array A is
+* distributed.
+* LLD_A (local) DESCA( LLD_ ) The leading dimension of the local
+* array. LLD_A >= MAX(1,LOCr(M_A)).
+*
+* Let K be the number of rows or columns of a distributed matrix,
+* and assume that its process grid has dimension p x q.
+* LOCr( K ) denotes the number of elements of K that a process
+* would receive if K were distributed over the p processes of its
+* process column.
+* Similarly, LOCc( K ) denotes the number of elements of K that a
+* process would receive if K were distributed over the q processes of
+* its process row.
+* The values of LOCr() and LOCc() may be determined via a call to the
+* ScaLAPACK tool function, NUMROC:
+* LOCr( M ) = NUMROC( M, MB_A, MYROW, RSRC_A, NPROW ),
+* LOCc( N ) = NUMROC( N, NB_A, MYCOL, CSRC_A, NPCOL ).
+* An upper bound for these quantities may be computed by:
+* LOCr( M ) <= ceil( ceil(M/MB_A)/NPROW )*MB_A
+* LOCc( N ) <= ceil( ceil(N/NB_A)/NPCOL )*NB_A
+*
+* PZHEEVR assumes IEEE 754 standard compliant arithmetic.
+*
+* Alignment requirements
+* ======================
+*
+* The distributed submatrices A(IA:*, JA:*) and Z(IZ:IZ+M-1,JZ:JZ+N-1)
+* must satisfy the following alignment properties:
+*
+* 1.Identical (quadratic) dimension:
+* DESCA(M_) = DESCZ(M_) = DESCA(N_) = DESCZ(N_)
+* 2.Quadratic conformal blocking:
+* DESCA(MB_) = DESCA(NB_) = DESCZ(MB_) = DESCZ(NB_)
+* DESCA(RSRC_) = DESCZ(RSRC_)
+* 3.MOD( IA-1, MB_A ) = MOD( IZ-1, MB_Z ) = 0
+* 4.IAROW = IZROW
+*
+*
+* .. Parameters ..
+ INTEGER CTXT_, M_, N_,
+ $ MB_, NB_, RSRC_, CSRC_
+ PARAMETER ( CTXT_ = 2, M_ = 3, N_ = 4, MB_ = 5, NB_ = 6,
+ $ RSRC_ = 7, CSRC_ = 8 )
+ DOUBLE PRECISION ZERO
+ PARAMETER ( ZERO = 0.0D0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL ALLEIG, COLBRT, DOBCST, FINISH, FIRST, INDEIG,
+ $ LOWER, LQUERY, VALEIG, VSTART, WANTZ
+ INTEGER ANB, DOL, DOU, DSTCOL, DSTROW, EIGCNT, FRSTCL,
+ $ I, IAROW, ICTXT, IIL, IINDERR, IINDWLC, IINFO,
+ $ IIU, IM, INDD, INDD2, INDE, INDE2, INDERR,
+ $ INDILU, INDRTAU, INDRW, INDRWORK, INDTAU,
+ $ INDWLC, INDWORK, IPIL, IPIU, IPROC, IZROW,
+ $ LASTCL, LENGTHI, LENGTHI2, LIWMIN, LLRWORK,
+ $ LLWORK, LRWMIN, LRWOPT, LWMIN, LWOPT, MAXCLS,
+ $ MQ00, MYCOL, MYIL, MYIU, MYPROC, MYROW, MZ, NB,
+ $ NDEPTH, NEEDIL, NEEDIU, NHETRD_LWOPT, NNP,
+ $ NP00, NPCOL, NPROCS, NPROW, NPS, NSPLIT,
+ $ OFFSET, PARITY, RLENGTHI, RLENGTHI2, RSTARTI,
+ $ SIZE1, SIZE2, SQNPC, SRCCOL, SRCROW, STARTI,
+ $ ZOFFSET
+
+ DOUBLE PRECISION PIVMIN, SAFMIN, SCALE, VLL, VUU, WL,
+ $ WU
+*
+* .. Local Arrays ..
+ INTEGER IDUM1( 4 ), IDUM2( 4 )
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ INTEGER ICEIL, INDXG2P, NUMROC, PJLAENV
+ DOUBLE PRECISION PDLAMCH
+ EXTERNAL ICEIL, INDXG2P, LSAME, NUMROC, PDLAMCH,
+ $ PJLAENV
+* ..
+* .. External Subroutines ..
+ EXTERNAL BLACS_GRIDINFO, CHK1MAT, DCOPY, DGEBR2D,
+ $ DGEBS2D, DGERV2D, DGESD2D, DLARRC, DLASRT2,
+ $ DSTEGR2A, DSTEGR2B, DSTEGR2, IGEBR2D,
+ $ IGEBS2D, IGERV2D, IGESD2D, IGSUM2D, PCHK1MAT,
+ $ PCHK2MAT, PDLARED1D, PXERBLA, PZELGET,
+ $ PZHENTRD, PZLAEVSWP, PZUNMTR
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, DBLE, DCMPLX, ICHAR, INT, MAX, MIN, MOD,
+ $ SQRT
+* ..
+* .. Executable Statements ..
+*
+
+ INFO = 0
+
+***********************************************************************
+*
+* Decode character arguments to find out what the code should do
+*
+***********************************************************************
+ WANTZ = LSAME( JOBZ, 'V' )
+ LOWER = LSAME( UPLO, 'L' )
+ ALLEIG = LSAME( RANGE, 'A' )
+ VALEIG = LSAME( RANGE, 'V' )
+ INDEIG = LSAME( RANGE, 'I' )
+ LQUERY = ( LWORK.EQ.-1 .OR. LRWORK.EQ.-1 .OR. LIWORK.EQ.-1 )
+
+***********************************************************************
+*
+* GET MACHINE PARAMETERS
+*
+***********************************************************************
+ ICTXT = DESCA( CTXT_ )
+ SAFMIN = PDLAMCH( ICTXT, 'Safe minimum' )
+
+***********************************************************************
+*
+* Set up pointers into the (complex) WORK array
+*
+***********************************************************************
+ INDTAU = 1
+ INDWORK = INDTAU + N
+ LLWORK = LWORK - INDWORK + 1
+
+***********************************************************************
+*
+* Set up pointers into the RWORK array
+*
+***********************************************************************
+ INDRTAU = 1
+ INDD = INDRTAU + N
+ INDE = INDD + N + 1
+ INDD2 = INDE + N + 1
+ INDE2 = INDD2 + N
+ INDRWORK = INDE2 + N
+ LLRWORK = LRWORK - INDRWORK + 1
+
+***********************************************************************
+*
+* BLACS PROCESSOR GRID SETUP
+*
+***********************************************************************
+ CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL )
+
+
+ NPROCS = NPROW * NPCOL
+ MYPROC = MYROW * NPCOL + MYCOL
+ IF( NPROW.EQ.-1 ) THEN
+ INFO = -( 800+CTXT_ )
+ ELSE IF( WANTZ ) THEN
+ IF( ICTXT.NE.DESCZ( CTXT_ ) ) THEN
+ INFO = -( 2100+CTXT_ )
+ END IF
+ END IF
+
+***********************************************************************
+*
+* COMPUTE REAL WORKSPACE
+*
+***********************************************************************
+ IF ( ALLEIG ) THEN
+ MZ = N
+ ELSE IF ( INDEIG ) THEN
+ MZ = IU - IL + 1
+ ELSE
+* Take upper bound for VALEIG case
+ MZ = N
+ END IF
+*
+ NB = DESCA( NB_ )
+ NP00 = NUMROC( N, NB, 0, 0, NPROW )
+ MQ00 = NUMROC( MZ, NB, 0, 0, NPCOL )
+ IF ( WANTZ ) THEN
+ INDRW = INDRWORK + MAX(18*N, NP00*MQ00 + 2*NB*NB)
+ LRWMIN = INDRW - 1 + (ICEIL(MZ, NPROCS) + 2)*N
+ LWMIN = N + MAX((NP00 + MQ00 + NB) * NB, 3 * NB)
+ ELSE
+ INDRW = INDRWORK + 12*N
+ LRWMIN = INDRW - 1
+ LWMIN = N + MAX( NB*( NP00 + 1 ), 3 * NB )
+ END IF
+
+* The code that validates the input requires 3 workspace entries
+ LRWMIN = MAX(3, LRWMIN)
+ LRWOPT = LRWMIN
+ LWMIN = MAX(3, LWMIN)
+ LWOPT = LWMIN
+*
+ ANB = PJLAENV( ICTXT, 3, 'PZHETTRD', 'L', 0, 0, 0, 0 )
+ SQNPC = INT( SQRT( DBLE( NPROCS ) ) )
+ NPS = MAX( NUMROC( N, 1, 0, 0, SQNPC ), 2*ANB )
+ NHETRD_LWOPT = 2*( ANB+1 )*( 4*NPS+2 ) + ( NPS+4 )*NPS
+ LWOPT = MAX( LWOPT, N+NHETRD_LWOPT )
+*
+ SIZE1 = INDRW - INDRWORK
+
+***********************************************************************
+*
+* COMPUTE INTEGER WORKSPACE
+*
+***********************************************************************
+ NNP = MAX( N, NPROCS+1, 4 )
+ IF ( WANTZ ) THEN
+ LIWMIN = 12*NNP + 2*N
+ ELSE
+ LIWMIN = 10*NNP + 2*N
+ END IF
+
+***********************************************************************
+*
+* Set up pointers into the IWORK array
+*
+***********************************************************************
+* Pointer to eigenpair distribution over processors
+ INDILU = LIWMIN - 2*NPROCS + 1
+ SIZE2 = INDILU - 2*N
+
+
+***********************************************************************
+*
+* Test the input arguments.
+*
+***********************************************************************
+ IF( INFO.EQ.0 ) THEN
+ CALL CHK1MAT( N, 4, N, 4, IA, JA, DESCA, 8, INFO )
+ IF( WANTZ )
+ $ CALL CHK1MAT( N, 4, N, 4, IZ, JZ, DESCZ, 21, INFO )
+*
+ IF( INFO.EQ.0 ) THEN
+ 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( MOD( IA-1, DESCA( MB_ ) ).NE.0 ) THEN
+ INFO = -6
+ ELSE IF( VALEIG .AND. N.GT.0 .AND. VU.LE.VL ) THEN
+ INFO = -10
+ ELSE IF( INDEIG .AND. ( IL.LT.1 .OR. IL.GT.MAX( 1, N ) ) )
+ $ THEN
+ INFO = -11
+ ELSE IF( INDEIG .AND. ( IU.LT.MIN( N, IL ) .OR. IU.GT.N ))
+ $ THEN
+ INFO = -12
+ ELSE IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN
+ INFO = -21
+ ELSE IF( LRWORK.LT.LRWMIN .AND. .NOT.LQUERY ) THEN
+ INFO = -23
+ ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN
+ INFO = -25
+ ELSE IF( DESCA( MB_ ).NE.DESCA( NB_ ) ) THEN
+ INFO = -( 800+NB_ )
+ END IF
+ IF( WANTZ ) THEN
+ IAROW = INDXG2P( 1, DESCA( NB_ ), MYROW,
+ $ DESCA( RSRC_ ), NPROW )
+ IZROW = INDXG2P( 1, DESCA( NB_ ), MYROW,
+ $ DESCZ( RSRC_ ), NPROW )
+ IF( IAROW.NE.IZROW ) THEN
+ INFO = -19
+ ELSE IF( MOD( IA-1, DESCA( MB_ ) ).NE.
+ $ MOD( IZ-1, DESCZ( MB_ ) ) ) THEN
+ INFO = -19
+ ELSE IF( DESCA( M_ ).NE.DESCZ( M_ ) ) THEN
+ INFO = -( 2100+M_ )
+ ELSE IF( DESCA( N_ ).NE.DESCZ( N_ ) ) THEN
+ INFO = -( 2100+N_ )
+ ELSE IF( DESCA( MB_ ).NE.DESCZ( MB_ ) ) THEN
+ INFO = -( 2100+MB_ )
+ ELSE IF( DESCA( NB_ ).NE.DESCZ( NB_ ) ) THEN
+ INFO = -( 2100+NB_ )
+ ELSE IF( DESCA( RSRC_ ).NE.DESCZ( RSRC_ ) ) THEN
+ INFO = -( 2100+RSRC_ )
+ ELSE IF( DESCA( CSRC_ ).NE.DESCZ( CSRC_ ) ) THEN
+ INFO = -( 2100+CSRC_ )
+ ELSE IF( ICTXT.NE.DESCZ( CTXT_ ) ) THEN
+ INFO = -( 2100+CTXT_ )
+ END IF
+ END IF
+ END IF
+ IDUM2( 1 ) = 1
+ IF( LOWER ) THEN
+ IDUM1( 2 ) = ICHAR( 'L' )
+ ELSE
+ IDUM1( 2 ) = ICHAR( 'U' )
+ END IF
+ IDUM2( 2 ) = 2
+ IF( ALLEIG ) THEN
+ IDUM1( 3 ) = ICHAR( 'A' )
+ ELSE IF( INDEIG ) THEN
+ IDUM1( 3 ) = ICHAR( 'I' )
+ ELSE
+ IDUM1( 3 ) = ICHAR( 'V' )
+ END IF
+ IDUM2( 3 ) = 3
+ IF( LQUERY ) THEN
+ IDUM1( 4 ) = -1
+ ELSE
+ IDUM1( 4 ) = 1
+ END IF
+ IDUM2( 4 ) = 4
+ IF( WANTZ ) THEN
+ IDUM1( 1 ) = ICHAR( 'V' )
+ CALL PCHK2MAT( N, 4, N, 4, IA, JA, DESCA, 8, N, 4, N, 4,IZ,
+ $ JZ, DESCZ, 21, 4, IDUM1, IDUM2, INFO )
+ ELSE
+ IDUM1( 1 ) = ICHAR( 'N' )
+ CALL PCHK1MAT( N, 4, N, 4, IA, JA, DESCA, 8, 4, IDUM1,
+ $ IDUM2, INFO )
+ END IF
+ WORK( 1 ) = DCMPLX( LWOPT )
+ RWORK( 1 ) = DBLE( LRWOPT )
+ IWORK( 1 ) = LIWMIN
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL PXERBLA( ICTXT, 'PZHEEVR', -INFO )
+ RETURN
+ ELSE IF( LQUERY ) THEN
+ RETURN
+ END IF
+
+***********************************************************************
+*
+* Quick return if possible
+*
+***********************************************************************
+ IF( N.EQ.0 ) THEN
+ IF( WANTZ ) THEN
+ NZ = 0
+ END IF
+ M = 0
+ WORK( 1 ) = DCMPLX( LWOPT )
+ RWORK( 1 ) = DBLE( LRWOPT )
+ IWORK( 1 ) = LIWMIN
+ RETURN
+ END IF
+
+ IF( VALEIG ) THEN
+ VLL = VL
+ VUU = VU
+ ELSE
+ VLL = ZERO
+ VUU = ZERO
+ END IF
+*
+* No scaling done here, leave this to MRRR kernel.
+* Scale tridiagonal rather than full matrix.
+*
+***********************************************************************
+*
+* REDUCE MATRIX TO REAL SYMMETRIC TRIDIAGONAL FORM.
+*
+***********************************************************************
+
+
+ CALL PZHENTRD( UPLO, N, A, IA, JA, DESCA, RWORK( INDD ),
+ $ RWORK( INDE ), WORK( INDTAU ), WORK( INDWORK ),
+ $ LLWORK, RWORK( INDRWORK ), LLRWORK,IINFO )
+
+
+ IF (IINFO .NE. 0) THEN
+ CALL PXERBLA( ICTXT, 'PZHENTRD', -IINFO )
+ RETURN
+ END IF
+
+***********************************************************************
+*
+* DISTRIBUTE TRIDIAGONAL TO ALL PROCESSORS
+*
+***********************************************************************
+ OFFSET = 0
+ IF( IA.EQ.1 .AND. JA.EQ.1 .AND.
+ $ DESCA( RSRC_ ).EQ.0 .AND. DESCA( CSRC_ ).EQ.0 )
+ $ THEN
+ CALL PDLARED1D( N, IA, JA, DESCA, RWORK( INDD ),
+ $ RWORK( INDD2 ), RWORK( INDRWORK ), LLRWORK )
+*
+ CALL PDLARED1D( N, IA, JA, DESCA, RWORK( INDE ),
+ $ RWORK( INDE2 ), RWORK( INDRWORK ), LLRWORK )
+ IF( .NOT.LOWER )
+ $ OFFSET = 1
+ ELSE
+ DO 10 I = 1, N
+ CALL PZELGET( 'A', ' ', WORK( INDWORK ), A,
+ $ I+IA-1, I+JA-1, DESCA )
+ RWORK( INDD2+I-1 ) = DBLE( WORK( INDWORK ) )
+ 10 CONTINUE
+ IF( LSAME( UPLO, 'U' ) ) THEN
+ DO 20 I = 1, N - 1
+ CALL PZELGET( 'A', ' ', WORK( INDWORK ), A,
+ $ I+IA-1, I+JA, DESCA )
+ RWORK( INDE2+I-1 ) = DBLE( WORK( INDWORK ) )
+ 20 CONTINUE
+ ELSE
+ DO 30 I = 1, N - 1
+ CALL PZELGET( 'A', ' ', WORK( INDWORK ), A,
+ $ I+IA, I+JA-1, DESCA )
+ RWORK( INDE2+I-1 ) = DBLE( WORK( INDWORK ) )
+ 30 CONTINUE
+ END IF
+ END IF
+
+
+
+
+***********************************************************************
+*
+* SET IIL, IIU
+*
+***********************************************************************
+ IF ( ALLEIG ) THEN
+ IIL = 1
+ IIU = N
+ ELSE IF ( INDEIG ) THEN
+ IIL = IL
+ IIU = IU
+ ELSE IF ( VALEIG ) THEN
+ CALL DLARRC('T', N, VLL, VUU, RWORK( INDD2 ),
+ $ RWORK( INDE2 + OFFSET ), SAFMIN, EIGCNT, IIL, IIU, INFO)
+* Refine upper bound N that was taken
+ MZ = EIGCNT
+ IIL = IIL + 1
+ ENDIF
+
+ IF(MZ.EQ.0) THEN
+ M = 0
+ IF( WANTZ ) THEN
+ NZ = 0
+ END IF
+ WORK( 1 ) = DBLE( LWOPT )
+ IWORK( 1 ) = LIWMIN
+ RETURN
+ END IF
+
+ MYIL = 0
+ MYIU = 0
+ M = 0
+ IM = 0
+
+***********************************************************************
+*
+* COMPUTE WORK ASSIGNMENTS
+*
+***********************************************************************
+
+*
+* Each processor computes the work assignments for all processors
+*
+ CALL PMPIM2( IIL, IIU, NPROCS,
+ $ IWORK(INDILU), IWORK(INDILU+NPROCS) )
+*
+* Find local work assignment
+*
+ MYIL = IWORK(INDILU+MYPROC)
+ MYIU = IWORK(INDILU+NPROCS+MYPROC)
+
+
+ ZOFFSET = MAX(0, MYIL - IIL - 1)
+ FIRST = ( MYIL .EQ. IIL )
+
+
+***********************************************************************
+*
+* CALLS TO MRRR KERNEL
+*
+***********************************************************************
+ IF(.NOT.WANTZ) THEN
+*
+* Compute eigenvalues only.
+*
+ IINFO = 0
+ IF ( MYIL.GT.0 ) THEN
+ DOL = 1
+ DOU = MYIU - MYIL + 1
+ CALL DSTEGR2( JOBZ, 'I', N, RWORK( INDD2 ),
+ $ RWORK( INDE2+OFFSET ), VLL, VUU, MYIL, MYIU,
+ $ IM, W( 1 ), RWORK( INDRW ), N,
+ $ MYIU - MYIL + 1,
+ $ IWORK( 1 ), RWORK( INDRWORK ), SIZE1,
+ $ IWORK( 2*N+1 ), SIZE2,
+ $ DOL, DOU, ZOFFSET, IINFO )
+* DSTEGR2 zeroes out the entire W array, so we can't just give
+* it the part of W we need. So here we copy the W entries into
+* their correct location
+ DO 49 I = 1, IM
+ W( MYIL-IIL+I ) = W( I )
+ 49 CONTINUE
+* W( MYIL ) is at W( MYIL - IIL + 1 )
+* W( X ) is at W(X - IIL + 1 )
+ END IF
+ IF (IINFO .NE. 0) THEN
+ CALL PXERBLA( ICTXT, 'DSTEGR2', -IINFO )
+ RETURN
+ END IF
+ ELSEIF ( WANTZ .AND. NPROCS.EQ.1 ) THEN
+*
+* Compute eigenvalues and -vectors, but only on one processor
+*
+ IINFO = 0
+ IF ( MYIL.GT.0 ) THEN
+ DOL = MYIL - IIL + 1
+ DOU = MYIU - IIL + 1
+ CALL DSTEGR2( JOBZ, 'I', N, RWORK( INDD2 ),
+ $ RWORK( INDE2+OFFSET ), VLL, VUU, IIL, IIU,
+ $ IM, W( 1 ), RWORK( INDRW ), N,
+ $ N,
+ $ IWORK( 1 ), RWORK( INDRWORK ), SIZE1,
+ $ IWORK( 2*N+1 ), SIZE2, DOL, DOU,
+ $ ZOFFSET, IINFO )
+ ENDIF
+ IF (IINFO .NE. 0) THEN
+ CALL PXERBLA( ICTXT, 'DSTEGR2', -IINFO )
+ RETURN
+ END IF
+ ELSEIF ( WANTZ ) THEN
+* Compute representations in parallel.
+* Share eigenvalue computation for root between all processors
+* Then compute the eigenvectors.
+ IINFO = 0
+* Part 1. compute root representations and root eigenvalues
+ IF ( MYIL.GT.0 ) THEN
+ DOL = MYIL - IIL + 1
+ DOU = MYIU - IIL + 1
+ CALL DSTEGR2A( JOBZ, 'I', N, RWORK( INDD2 ),
+ $ RWORK( INDE2+OFFSET ), VLL, VUU, IIL, IIU,
+ $ IM, W( 1 ), RWORK( INDRW ), N,
+ $ N, RWORK( INDRWORK ), SIZE1,
+ $ IWORK( 2*N+1 ), SIZE2, DOL,
+ $ DOU, NEEDIL, NEEDIU,
+ $ INDERR, NSPLIT, PIVMIN, SCALE, WL, WU,
+ $ IINFO )
+ ENDIF
+ IF (IINFO .NE. 0) THEN
+ CALL PXERBLA( ICTXT, 'DSTEGR2A', -IINFO )
+ RETURN
+ END IF
+*
+* The second part of parallel MRRR, the representation tree
+* construction begins. Upon successful completion, the
+* eigenvectors have been computed. This is indicated by
+* the flag FINISH.
+*
+ VSTART = .TRUE.
+ FINISH = (MYIL.LE.0)
+C Part 2. Share eigenvalues and uncertainties between all processors
+ IINDERR = INDRWORK + INDERR - 1
+
+*
+
+
+*
+* There are currently two ways to communicate eigenvalue information
+* using the BLACS.
+* 1.) BROADCAST
+* 2.) POINT2POINT between collaborators (those processors working
+* jointly on a cluster.
+* For efficiency, BROADCAST has been disabled.
+* At a later stage, other more efficient communication algorithms
+* might be implemented, e. g. group or tree-based communication.
+
+ DOBCST = .FALSE.
+ IF(DOBCST) THEN
+* First gather everything on the first processor.
+* Then use BROADCAST-based communication
+ DO 45 I = 2, NPROCS
+ IF (MYPROC .EQ. (I - 1)) THEN
+ DSTROW = 0
+ DSTCOL = 0
+ STARTI = DOL
+ IWORK(1) = STARTI
+ IF(MYIL.GT.0) THEN
+ LENGTHI = MYIU - MYIL + 1
+ ELSE
+ LENGTHI = 0
+ ENDIF
+ IWORK(2) = LENGTHI
+ CALL IGESD2D( ICTXT, 2, 1, IWORK, 2,
+ $ DSTROW, DSTCOL )
+ IF (( STARTI.GE.1 ) .AND. ( LENGTHI.GE.1 )) THEN
+ LENGTHI2 = 2*LENGTHI
+* Copy eigenvalues into communication buffer
+ CALL DCOPY(LENGTHI,W( STARTI ),1,
+ $ RWORK( INDD ), 1)
+* Copy uncertainties into communication buffer
+ CALL DCOPY(LENGTHI,RWORK(IINDERR+STARTI-1),1,
+ $ RWORK( INDD+LENGTHI ), 1)
+* send buffer
+ CALL DGESD2D( ICTXT, LENGTHI2,
+ $ 1, RWORK( INDD ), LENGTHI2,
+ $ DSTROW, DSTCOL )
+ END IF
+ ELSE IF (MYPROC .EQ. 0) THEN
+ SRCROW = (I-1) / NPCOL
+ SRCCOL = MOD(I-1, NPCOL)
+ CALL IGERV2D( ICTXT, 2, 1, IWORK, 2,
+ $ SRCROW, SRCCOL )
+ STARTI = IWORK(1)
+ LENGTHI = IWORK(2)
+ IF (( STARTI.GE.1 ) .AND. ( LENGTHI.GE.1 )) THEN
+ LENGTHI2 = 2*LENGTHI
+* receive buffer
+ CALL DGERV2D( ICTXT, LENGTHI2, 1,
+ $ RWORK(INDD), LENGTHI2, SRCROW, SRCCOL )
+* copy eigenvalues from communication buffer
+ CALL DCOPY( LENGTHI, RWORK(INDD), 1,
+ $ W( STARTI ), 1)
+* copy uncertainties (errors) from communication buffer
+ CALL DCOPY(LENGTHI,RWORK(INDD+LENGTHI),1,
+ $ RWORK( IINDERR+STARTI-1 ), 1)
+ END IF
+ END IF
+ 45 CONTINUE
+ LENGTHI = IIU - IIL + 1
+ LENGTHI2 = LENGTHI * 2
+ IF (MYPROC .EQ. 0) THEN
+* Broadcast eigenvalues and errors to all processors
+ CALL DCOPY(LENGTHI,W ,1, RWORK( INDD ), 1)
+ CALL DCOPY(LENGTHI,RWORK( IINDERR ),1,
+ $ RWORK( INDD+LENGTHI ), 1)
+ CALL DGEBS2D( ICTXT, 'A', ' ', LENGTHI2, 1,
+ $ RWORK(INDD), LENGTHI2 )
+ ELSE
+ SRCROW = 0
+ SRCCOL = 0
+ CALL DGEBR2D( ICTXT, 'A', ' ', LENGTHI2, 1,
+ $ RWORK(INDD), LENGTHI2, SRCROW, SRCCOL )
+ CALL DCOPY( LENGTHI, RWORK(INDD), 1, W, 1)
+ CALL DCOPY(LENGTHI,RWORK(INDD+LENGTHI),1,
+ $ RWORK( IINDERR ), 1)
+ END IF
+ ELSE
+* Enable point2point communication between collaborators
+
+* Find collaborators of MYPROC
+ IF( (NPROCS.GT.1).AND.(MYIL.GT.0) ) THEN
+ CALL PMPCOL( MYPROC, NPROCS, IIL, NEEDIL, NEEDIU,
+ $ IWORK(INDILU), IWORK(INDILU+NPROCS),
+ $ COLBRT, FRSTCL, LASTCL )
+ ELSE
+ COLBRT = .FALSE.
+ ENDIF
+
+ IF(COLBRT) THEN
+* If the processor collaborates with others,
+* communicate information.
+ DO 47 IPROC = FRSTCL, LASTCL
+ IF (MYPROC .EQ. IPROC) THEN
+ STARTI = DOL
+ IWORK(1) = STARTI
+ LENGTHI = MYIU - MYIL + 1
+ IWORK(2) = LENGTHI
+
+ IF ((STARTI.GE.1) .AND. (LENGTHI.GE.1)) THEN
+* Copy eigenvalues into communication buffer
+ CALL DCOPY(LENGTHI,W( STARTI ),1,
+ $ RWORK(INDD), 1)
+* Copy uncertainties into communication buffer
+ CALL DCOPY(LENGTHI,
+ $ RWORK( IINDERR+STARTI-1 ),1,
+ $ RWORK(INDD+LENGTHI), 1)
+ ENDIF
+
+ DO 46 I = FRSTCL, LASTCL
+ IF(I.EQ.MYPROC) GOTO 46
+ DSTROW = I/ NPCOL
+ DSTCOL = MOD(I, NPCOL)
+ CALL IGESD2D( ICTXT, 2, 1, IWORK, 2,
+ $ DSTROW, DSTCOL )
+ IF ((STARTI.GE.1) .AND. (LENGTHI.GE.1)) THEN
+ LENGTHI2 = 2*LENGTHI
+* send buffer
+ CALL DGESD2D( ICTXT, LENGTHI2,
+ $ 1, RWORK(INDD), LENGTHI2,
+ $ DSTROW, DSTCOL )
+ END IF
+ 46 CONTINUE
+ ELSE
+ SRCROW = IPROC / NPCOL
+ SRCCOL = MOD(IPROC, NPCOL)
+ CALL IGERV2D( ICTXT, 2, 1, IWORK, 2,
+ $ SRCROW, SRCCOL )
+ RSTARTI = IWORK(1)
+ RLENGTHI = IWORK(2)
+ IF ((RSTARTI.GE.1 ) .AND. (RLENGTHI.GE.1 )) THEN
+ RLENGTHI2 = 2*RLENGTHI
+ CALL DGERV2D( ICTXT, RLENGTHI2, 1,
+ $ RWORK(INDE), RLENGTHI2,
+ $ SRCROW, SRCCOL )
+* copy eigenvalues from communication buffer
+ CALL DCOPY( RLENGTHI,RWORK(INDE), 1,
+ $ W( RSTARTI ), 1)
+* copy uncertainties (errors) from communication buffer
+ CALL DCOPY(RLENGTHI,RWORK(INDE+RLENGTHI),1,
+ $ RWORK( IINDERR+RSTARTI-1 ), 1)
+ END IF
+ END IF
+ 47 CONTINUE
+ ENDIF
+ ENDIF
+
+* Part 3. Compute representation tree and eigenvectors.
+* What follows is a loop in which the tree
+* is constructed in parallel from top to bottom,
+* on level at a time, until all eigenvectors
+* have been computed.
+*
+ 100 CONTINUE
+ IF ( MYIL.GT.0 ) THEN
+ CALL DSTEGR2B( JOBZ, N, RWORK( INDD2 ),
+ $ RWORK( INDE2+OFFSET ),
+ $ IM, W( 1 ), RWORK( INDRW ), N, N,
+ $ IWORK( 1 ), RWORK( INDRWORK ), SIZE1,
+ $ IWORK( 2*N+1 ), SIZE2, DOL,
+ $ DOU, NEEDIL, NEEDIU, INDWLC,
+ $ PIVMIN, SCALE, WL, WU,
+ $ VSTART, FINISH,
+ $ MAXCLS, NDEPTH, PARITY, ZOFFSET, IINFO )
+ IINDWLC = INDRWORK + INDWLC - 1
+ IF(.NOT.FINISH) THEN
+ IF((NEEDIL.LT.DOL).OR.(NEEDIU.GT.DOU)) THEN
+ CALL PMPCOL( MYPROC, NPROCS, IIL, NEEDIL, NEEDIU,
+ $ IWORK(INDILU), IWORK(INDILU+NPROCS),
+ $ COLBRT, FRSTCL, LASTCL )
+ ELSE
+ COLBRT = .FALSE.
+ FRSTCL = MYPROC
+ LASTCL = MYPROC
+ ENDIF
+*
+* Check if this processor collaborates, i.e.
+* communication is needed.
+*
+ IF(COLBRT) THEN
+ DO 147 IPROC = FRSTCL, LASTCL
+ IF (MYPROC .EQ. IPROC) THEN
+ STARTI = DOL
+ IWORK(1) = STARTI
+ IF(MYIL.GT.0) THEN
+ LENGTHI = MYIU - MYIL + 1
+ ELSE
+ LENGTHI = 0
+ ENDIF
+ IWORK(2) = LENGTHI
+ IF ((STARTI.GE.1).AND.(LENGTHI.GE.1)) THEN
+* Copy eigenvalues into communication buffer
+ CALL DCOPY(LENGTHI,
+ $ RWORK( IINDWLC+STARTI-1 ),1,
+ $ RWORK(INDD), 1)
+* Copy uncertainties into communication buffer
+ CALL DCOPY(LENGTHI,
+ $ RWORK( IINDERR+STARTI-1 ),1,
+ $ RWORK(INDD+LENGTHI), 1)
+ ENDIF
+
+ DO 146 I = FRSTCL, LASTCL
+ IF(I.EQ.MYPROC) GOTO 146
+ DSTROW = I/ NPCOL
+ DSTCOL = MOD(I, NPCOL)
+ CALL IGESD2D( ICTXT, 2, 1, IWORK, 2,
+ $ DSTROW, DSTCOL )
+ IF ((STARTI.GE.1).AND.(LENGTHI.GE.1)) THEN
+ LENGTHI2 = 2*LENGTHI
+* send buffer
+ CALL DGESD2D( ICTXT, LENGTHI2,
+ $ 1, RWORK(INDD), LENGTHI2,
+ $ DSTROW, DSTCOL )
+ END IF
+ 146 CONTINUE
+ ELSE
+ SRCROW = IPROC / NPCOL
+ SRCCOL = MOD(IPROC, NPCOL)
+ CALL IGERV2D( ICTXT, 2, 1, IWORK, 2,
+ $ SRCROW, SRCCOL )
+ RSTARTI = IWORK(1)
+ RLENGTHI = IWORK(2)
+ IF ((RSTARTI.GE.1).AND.(RLENGTHI.GE.1)) THEN
+ RLENGTHI2 = 2*RLENGTHI
+ CALL DGERV2D( ICTXT,RLENGTHI2, 1,
+ $ RWORK(INDE),RLENGTHI2,
+ $ SRCROW, SRCCOL )
+* copy eigenvalues from communication buffer
+ CALL DCOPY(RLENGTHI,RWORK(INDE), 1,
+ $ RWORK( IINDWLC+RSTARTI-1 ), 1)
+* copy uncertainties (errors) from communication buffer
+ CALL DCOPY(RLENGTHI,RWORK(INDE+RLENGTHI),
+ $ 1,RWORK( IINDERR+RSTARTI-1 ), 1)
+ END IF
+ END IF
+ 147 CONTINUE
+ ENDIF
+ GOTO 100
+ ENDIF
+ ENDIF
+ IF (IINFO .NE. 0) THEN
+ CALL PXERBLA( ICTXT, 'DSTEGR2B', -IINFO )
+ RETURN
+ END IF
+*
+ ENDIF
+
+*
+***********************************************************************
+*
+* MAIN PART ENDS HERE
+*
+***********************************************************************
+*
+
+***********************************************************************
+*
+* ALLGATHER: EACH PROCESSOR SENDS ITS EIGENVALUES TO THE FIRST ONE,
+* THEN THE FIRST PROCESSOR BROADCASTS ALL EIGENVALUES
+*
+***********************************************************************
+
+ DO 50 I = 2, NPROCS
+ IF (MYPROC .EQ. (I - 1)) THEN
+ DSTROW = 0
+ DSTCOL = 0
+ STARTI = MYIL - IIL + 1
+ IWORK(1) = STARTI
+ IF(MYIL.GT.0) THEN
+ LENGTHI = MYIU - MYIL + 1
+ ELSE
+ LENGTHI = 0
+ ENDIF
+ IWORK(2) = LENGTHI
+ CALL IGESD2D( ICTXT, 2, 1, IWORK, 2,
+ $ DSTROW, DSTCOL )
+ IF ((STARTI.GE.1).AND.(LENGTHI.GE.1)) THEN
+ CALL DGESD2D( ICTXT, LENGTHI,
+ $ 1, W( STARTI ), LENGTHI,
+ $ DSTROW, DSTCOL )
+ ENDIF
+ ELSE IF (MYPROC .EQ. 0) THEN
+ SRCROW = (I-1) / NPCOL
+ SRCCOL = MOD(I-1, NPCOL)
+ CALL IGERV2D( ICTXT, 2, 1, IWORK, 2,
+ $ SRCROW, SRCCOL )
+ STARTI = IWORK(1)
+ LENGTHI = IWORK(2)
+ IF ((STARTI.GE.1).AND.(LENGTHI.GE.1)) THEN
+ CALL DGERV2D( ICTXT, LENGTHI, 1,
+ $ W( STARTI ), LENGTHI, SRCROW, SRCCOL )
+ ENDIF
+ ENDIF
+ 50 CONTINUE
+
+* Accumulate M from all processors
+ M = IM
+ CALL IGSUM2D( ICTXT, 'A', ' ', 1, 1, M, 1, -1, -1 )
+
+* Broadcast eigenvalues to all processors
+ IF (MYPROC .EQ. 0) THEN
+* Send eigenvalues
+ CALL DGEBS2D( ICTXT, 'A', ' ', M, 1, W, M )
+ ELSE
+ SRCROW = 0
+ SRCCOL = 0
+ CALL DGEBR2D( ICTXT, 'A', ' ', M, 1,
+ $ W, M, SRCROW, SRCCOL )
+ END IF
+*
+* Sort the eigenvalues and keep permutation in IWORK to
+* sort the eigenvectors accordingly
+*
+ DO 160 I = 1, M
+ IWORK( NPROCS+1+I ) = I
+ 160 CONTINUE
+ CALL DLASRT2( 'I', M, W, IWORK( NPROCS+2 ), IINFO )
+ IF (IINFO.NE.0) THEN
+ CALL PXERBLA( ICTXT, 'DLASRT2', -IINFO )
+ RETURN
+ END IF
+
+***********************************************************************
+*
+* TRANSFORM Z FROM 1D WORKSPACE INTO 2D BLOCKCYCLIC STORAGE
+*
+***********************************************************************
+ IF ( WANTZ ) THEN
+ DO 170 I = 1, M
+ IWORK( M+NPROCS+1+IWORK( NPROCS+1+I ) ) = I
+ 170 CONTINUE
+* Store NVS in IWORK(1:NPROCS+1) for PZLAEVSWP
+ IWORK( 1 ) = 0
+ DO 180 I = 1, NPROCS
+* Find IL and IU for processor i-1
+* Has already been computed by PMPIM2 and stored
+ IPIL = IWORK(INDILU+I-1)
+ IPIU = IWORK(INDILU+NPROCS+I-1)
+ IF (IPIL .EQ. 0) THEN
+ IWORK( I + 1 ) = IWORK( I )
+ ELSE
+ IWORK( I + 1 ) = IWORK( I ) + IPIU - IPIL + 1
+ ENDIF
+ 180 CONTINUE
+
+ IF ( FIRST ) THEN
+ CALL PZLAEVSWP(N, RWORK( INDRW ), N, Z, IZ, JZ,
+ $ DESCZ, IWORK( 1 ), IWORK( NPROCS+M+2 ), RWORK( INDRWORK ),
+ $ SIZE1 )
+ ELSE
+ CALL PZLAEVSWP(N, RWORK( INDRW + N ), N, Z, IZ, JZ,
+ $ DESCZ, IWORK( 1 ), IWORK( NPROCS+M+2 ), RWORK( INDRWORK ),
+ $ SIZE1 )
+ END IF
+*
+ NZ = M
+*
+
+***********************************************************************
+*
+* Compute eigenvectors of A from eigenvectors of T
+*
+***********************************************************************
+ IF( NZ.GT.0 ) THEN
+ CALL PZUNMTR( 'L', UPLO, 'N', N, NZ, A, IA, JA, DESCA,
+ $ WORK( INDTAU ), Z, IZ, JZ, DESCZ,
+ $ WORK( INDWORK ), LLWORK, IINFO )
+ END IF
+ IF (IINFO.NE.0) THEN
+ CALL PXERBLA( ICTXT, 'PZUNMTR', -IINFO )
+ RETURN
+ END IF
+*
+
+ END IF
+*
+ WORK( 1 ) = DCMPLX( LWOPT )
+ RWORK( 1 ) = DBLE( LRWOPT )
+ IWORK( 1 ) = LIWMIN
+
+ RETURN
+*
+* End of PZHEEVR
+*
+ END
diff --git a/SRC/pzheevx.f b/SRC/pzheevx.f
index b705565..e09d80b 100644
--- a/SRC/pzheevx.f
+++ b/SRC/pzheevx.f
@@ -607,6 +607,9 @@
RSRC_Z = DESCZ( RSRC_ )
IROFFZ = MOD( IZ-1, MB_A )
IZROW = INDXG2P( 1, NB_A, MYROW, RSRC_Z, NPROW )
+ ELSE
+ IROFFZ = 0
+ IZROW = 0
END IF
*
IF( ( .NOT.WANTZ ) .OR. ( VALEIG .AND. ( .NOT.LQUERY ) ) )
diff --git a/SRC/pzhettrd.f b/SRC/pzhettrd.f
index f8c05a6..ad797f4 100644
--- a/SRC/pzhettrd.f
+++ b/SRC/pzhettrd.f
@@ -1,10 +1,9 @@
SUBROUTINE PZHETTRD( UPLO, N, A, IA, JA, DESCA, D, E, TAU, WORK,
$ LWORK, INFO )
*
-* -- ScaLAPACK routine (version 1.7) --
-* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
-* and University of California, Berkeley.
-* October 15, 1999
+* -- ScaLAPACK routine (version 2.0.2) --
+* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver
+* May 1 2012
*
* .. Scalar Arguments ..
CHARACTER UPLO
@@ -445,7 +444,7 @@
EXTERNAL BLACS_GRIDINFO, CHK1MAT, DCOMBNRM2, DGEBR2D,
$ DGEBS2D, DGSUM2D, PCHK1MAT, PDTREECOMB,
$ PXERBLA, ZGEBR2D, ZGEBS2D, ZGEMM, ZGEMV,
- $ ZGERV2D, ZGESD2D, ZGSUM2D, ZLACPY, ZSCAL,
+ $ ZGERV2D, ZGESD2D, ZGSUM2D, ZLAMOV, ZSCAL,
$ ZTRMVT
* ..
* .. External Functions ..
@@ -1133,10 +1132,10 @@
IF( INTERLEAVE ) THEN
LDZG = LDV / 2
ELSE
- CALL ZLACPY( 'A', LTNM1, ANB, WORK( INHT+LIJP1-1 ),
+ CALL ZLAMOV( 'A', LTNM1, ANB, WORK( INHT+LIJP1-1 ),
$ LDV, WORK( INVT+LIJP1-1+ANB*LDV ), LDV )
*
- CALL ZLACPY( 'A', LTNM1, ANB, WORK( INV+LTLIP1-1 ),
+ CALL ZLAMOV( 'A', LTNM1, ANB, WORK( INV+LTLIP1-1 ),
$ LDV, WORK( INH+LTLIP1-1+ANB*LDV ), LDV )
LDZG = LDV
END IF
diff --git a/SRC/pzlacp2.f b/SRC/pzlacp2.f
index 218adeb..65cedf2 100644
--- a/SRC/pzlacp2.f
+++ b/SRC/pzlacp2.f
@@ -1,10 +1,9 @@
SUBROUTINE PZLACP2( UPLO, M, N, A, IA, JA, DESCA, B, IB, JB,
$ DESCB )
*
-* -- ScaLAPACK auxiliary routine (version 1.7) --
-* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
-* and University of California, Berkeley.
-* November 15, 1997
+* -- ScaLAPACK auxiliary routine (version 2.0.2) --
+* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver
+* May 1 2012
*
* .. Scalar Arguments ..
CHARACTER UPLO
@@ -157,7 +156,7 @@
$ NQ, NQAA, WIDE
* ..
* .. External Subroutines ..
- EXTERNAL BLACS_GRIDINFO, INFOG2L, ZLACPY
+ EXTERNAL BLACS_GRIDINFO, INFOG2L, ZLAMOV
* ..
* .. External Functions ..
LOGICAL LSAME
@@ -247,7 +246,7 @@
*
10 CONTINUE
IF( ( N-ITOP ).GT.0 ) THEN
- CALL ZLACPY( UPLO, IINXTA-IIBEGA+1, N-ITOP,
+ CALL ZLAMOV( UPLO, IINXTA-IIBEGA+1, N-ITOP,
$ A( IIBEGA+(JJA+ITOP-1)*LDA ), LDA,
$ B( IIBEGB+(JJB+ITOP-1)*LDB ), LDB )
MYDIST = MYDIST + NPROW
@@ -272,10 +271,10 @@
20 CONTINUE
IF( JJAA.LE.( JJA+N-1 ) ) THEN
HEIGHT = IBASE - ITOP
- CALL ZLACPY( 'All', MPAA, ITOP-JJAA+JJA,
+ CALL ZLAMOV( 'All', MPAA, ITOP-JJAA+JJA,
$ A( IIAA+(JJAA-1)*LDA ), LDA,
$ B( IIBB+(JJBB-1)*LDB ), LDB )
- CALL ZLACPY( UPLO, MPAA, HEIGHT,
+ CALL ZLAMOV( UPLO, MPAA, HEIGHT,
$ A( IIAA+(JJA+ITOP-1)*LDA ), LDA,
$ B( IIBB+(JJB+ITOP-1)*LDB ), LDB )
MPAA = MAX( 0, MPAA - HEIGHT )
@@ -292,7 +291,7 @@
*
ELSE
*
- CALL ZLACPY( 'All', MP, N, A( IIA+(JJA-1)*LDA ),
+ CALL ZLAMOV( 'All', MP, N, A( IIA+(JJA-1)*LDA ),
$ LDA, B( IIB+(JJB-1)*LDB ), LDB )
*
END IF
@@ -345,7 +344,7 @@
*
30 CONTINUE
IF( ( M-ILEFT ).GT.0 ) THEN
- CALL ZLACPY( UPLO, M-ILEFT, JJNXTA-JJBEGA+1,
+ CALL ZLAMOV( UPLO, M-ILEFT, JJNXTA-JJBEGA+1,
$ A( IIA+ILEFT+(JJBEGA-1)*LDA ), LDA,
$ B( IIB+ILEFT+(JJBEGB-1)*LDB ), LDB )
MYDIST = MYDIST + NPCOL
@@ -370,10 +369,10 @@
40 CONTINUE
IF( IIAA.LE.( IIA+M-1 ) ) THEN
WIDE = IRIGHT - ILEFT
- CALL ZLACPY( 'All', ILEFT-IIAA+IIA, NQAA,
+ CALL ZLAMOV( 'All', ILEFT-IIAA+IIA, NQAA,
$ A( IIAA+(JJAA-1)*LDA ), LDA,
$ B( IIBB+(JJBB-1)*LDB ), LDB )
- CALL ZLACPY( UPLO, WIDE, NQAA,
+ CALL ZLAMOV( UPLO, WIDE, NQAA,
$ A( IIA+ILEFT+(JJAA-1)*LDA ), LDA,
$ B( IIB+ILEFT+(JJBB-1)*LDB ), LDB )
NQAA = MAX( 0, NQAA - WIDE )
@@ -390,7 +389,7 @@
*
ELSE
*
- CALL ZLACPY( 'All', M, NQ, A( IIA+(JJA-1)*LDA ),
+ CALL ZLAMOV( 'All', M, NQ, A( IIA+(JJA-1)*LDA ),
$ LDA, B( IIB+(JJB-1)*LDB ), LDB )
*
END IF
diff --git a/SRC/pzlarfb.f b/SRC/pzlarfb.f
index f6d4be0..8a9e375 100644
--- a/SRC/pzlarfb.f
+++ b/SRC/pzlarfb.f
@@ -1,10 +1,9 @@
SUBROUTINE PZLARFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, V, IV,
$ JV, DESCV, T, C, IC, JC, DESCC, WORK )
*
-* -- ScaLAPACK auxiliary routine (version 1.7) --
-* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
-* and University of California, Berkeley.
-* May 1, 1997
+* -- ScaLAPACK routine (version 2.0.2) --
+* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver
+* May 1 2012
*
* .. Scalar Arguments ..
CHARACTER SIDE, TRANS, DIRECT, STOREV
@@ -238,7 +237,7 @@
* .. External Subroutines ..
EXTERNAL BLACS_GRIDINFO, INFOG1L, INFOG2L, PB_TOPGET,
$ PBZTRAN, ZGEBR2D, ZGEBS2D, ZGEMM,
- $ ZGSUM2D, ZLACPY, ZLASET, ZTRBR2D,
+ $ ZGSUM2D, ZLAMOV, ZLASET, ZTRBR2D,
$ ZTRBS2D, ZTRMM
* ..
* .. Intrinsic Functions ..
@@ -325,7 +324,7 @@
IF( MYROW.EQ.IVROW )
$ CALL ZTRBS2D( ICTXT, 'Rowwise', ROWBTOP, UPLO,
$ 'Non unit', K, K, T, NBV )
- CALL ZLACPY( 'All', MPC, K, V( IOFFV ), LDV, WORK( IPV ),
+ CALL ZLAMOV( 'All', MPC, K, V( IOFFV ), LDV, WORK( IPV ),
$ LV )
ELSE
CALL ZGEBR2D( ICTXT, 'Rowwise', ROWBTOP, MPC, K,
@@ -462,11 +461,11 @@
CALL ZLASET( 'All', IROFFV, K, ZERO, ZERO,
$ WORK( IPW ), LW )
IPW1 = IPW + IROFFV
- CALL ZLACPY( 'All', NPV, K, V( IOFFV ), LDV,
+ CALL ZLAMOV( 'All', NPV, K, V( IOFFV ), LDV,
$ WORK( IPW1 ), LW )
ELSE
IPW1 = IPW
- CALL ZLACPY( 'All', NPV, K, V( IOFFV ), LDV,
+ CALL ZLAMOV( 'All', NPV, K, V( IOFFV ), LDV,
$ WORK( IPW1 ), LW )
END IF
*
@@ -626,11 +625,11 @@
CALL ZLASET( 'All', K, ICOFFV, ZERO, ZERO,
$ WORK( IPW ), LW )
IPW1 = IPW + ICOFFV * LW
- CALL ZLACPY( 'All', K, MQV, V( IOFFV ), LDV,
+ CALL ZLAMOV( 'All', K, MQV, V( IOFFV ), LDV,
$ WORK( IPW1 ), LW )
ELSE
IPW1 = IPW
- CALL ZLACPY( 'All', K, MQV, V( IOFFV ), LDV,
+ CALL ZLAMOV( 'All', K, MQV, V( IOFFV ), LDV,
$ WORK( IPW1 ), LW )
END IF
*
@@ -775,7 +774,7 @@
IF( MYCOL.EQ.IVCOL )
$ CALL ZTRBS2D( ICTXT, 'Columnwise', COLBTOP, UPLO,
$ 'Non unit', K, K, T, MBV )
- CALL ZLACPY( 'All', K, NQC, V( IOFFV ), LDV, WORK( IPV ),
+ CALL ZLAMOV( 'All', K, NQC, V( IOFFV ), LDV, WORK( IPV ),
$ LV )
ELSE
CALL ZGEBR2D( ICTXT, 'Columnwise', COLBTOP, K, NQC,
diff --git a/SRC/pzlarzb.f b/SRC/pzlarzb.f
index 08282da..45cd672 100644
--- a/SRC/pzlarzb.f
+++ b/SRC/pzlarzb.f
@@ -1,10 +1,9 @@
SUBROUTINE PZLARZB( SIDE, TRANS, DIRECT, STOREV, M, N, K, L, V,
$ IV, JV, DESCV, T, C, IC, JC, DESCC, WORK )
*
-* -- ScaLAPACK auxiliary routine (version 1.7) --
-* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
-* and University of California, Berkeley.
-* March 14, 2000
+* -- ScaLAPACK auxiliary routine (version 2.0.2) --
+* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver
+* May 1 2012
*
* .. Scalar Arguments ..
CHARACTER DIRECT, SIDE, STOREV, TRANS
@@ -244,7 +243,7 @@
EXTERNAL BLACS_ABORT, BLACS_GRIDINFO, INFOG2L,
$ PBZMATADD, PB_TOPGET, PXERBLA, PBZTRAN,
$ ZGEBR2D, ZGEBS2D, ZGEMM,
- $ ZGSUM2D, ZLACGV, ZLACPY, ZLASET,
+ $ ZGSUM2D, ZLACGV, ZLAMOV, ZLASET,
$ ZTRBR2D, ZTRBS2D, ZTRMM
* ..
* .. Intrinsic Functions ..
@@ -381,10 +380,10 @@
*
IF( MYROW.EQ.IVROW ) THEN
IF( MYCOL.EQ.IVCOL ) THEN
- CALL ZLACPY( 'All', K, MQV, V( IOFFV ), LDV,
+ CALL ZLAMOV( 'All', K, MQV, V( IOFFV ), LDV,
$ WORK( IPW+ICOFFV*LW ), LW )
ELSE
- CALL ZLACPY( 'All', K, MQV, V( IOFFV ), LDV,
+ CALL ZLAMOV( 'All', K, MQV, V( IOFFV ), LDV,
$ WORK( IPW ), LW )
END IF
END IF
@@ -517,7 +516,7 @@
IF( MYCOL.EQ.IVCOL )
$ CALL ZTRBS2D( ICTXT, 'Columnwise', COLBTOP, 'Lower',
$ 'Non unit', K, K, T, MBV )
- CALL ZLACPY( 'All', K, NQC2, V( IOFFV ), LDV, WORK( IPV ),
+ CALL ZLAMOV( 'All', K, NQC2, V( IOFFV ), LDV, WORK( IPV ),
$ LV )
ELSE
CALL ZGEBR2D( ICTXT, 'Columnwise', COLBTOP, K, NQC2,
diff --git a/SRC/pzlascl.f b/SRC/pzlascl.f
index 295e7ad..91f0898 100644
--- a/SRC/pzlascl.f
+++ b/SRC/pzlascl.f
@@ -153,10 +153,10 @@
EXTERNAL BLACS_GRIDINFO, CHK1MAT, INFOG2L, PXERBLA
* ..
* .. External Functions ..
- LOGICAL LSAME
+ LOGICAL LSAME, DISNAN
INTEGER ICEIL, NUMROC
DOUBLE PRECISION PDLAMCH
- EXTERNAL ICEIL, LSAME, NUMROC, PDLAMCH
+ EXTERNAL DISNAN, ICEIL, LSAME, NUMROC, PDLAMCH
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MIN, MOD
@@ -189,8 +189,10 @@
END IF
IF( ITYPE.EQ.-1 ) THEN
INFO = -1
- ELSE IF( CFROM.EQ.ZERO ) THEN
+ ELSE IF( CFROM.EQ.ZERO .OR. DISNAN(CFROM) ) THEN
INFO = -4
+ ELSE IF( DISNAN(CTO) ) THEN
+ INFO = -5
END IF
END IF
END IF
@@ -230,18 +232,32 @@
*
10 CONTINUE
CFROM1 = CFROMC*SMLNUM
- CTO1 = CTOC / BIGNUM
- IF( ABS( CFROM1 ).GT.ABS( CTOC ) .AND. CTOC.NE.ZERO ) THEN
- MUL = SMLNUM
- DONE = .FALSE.
- CFROMC = CFROM1
- ELSE IF( ABS( CTO1 ).GT.ABS( CFROMC ) ) THEN
- MUL = BIGNUM
- DONE = .FALSE.
- CTOC = CTO1
- ELSE
+ 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
*
IOFFA = ( JJA - 1 ) * LDA
diff --git a/SRC/pzpbtrf.f b/SRC/pzpbtrf.f
index 1a5c314..aaf34e1 100644
--- a/SRC/pzpbtrf.f
+++ b/SRC/pzpbtrf.f
@@ -1,12 +1,9 @@
SUBROUTINE PZPBTRF( UPLO, N, BW, A, JA, DESCA, AF, LAF, WORK,
$ LWORK, INFO )
*
-*
-*
-* -- ScaLAPACK routine (version 1.7) --
-* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
-* and University of California, Berkeley.
-* May 25, 2001
+* -- ScaLAPACK routine (version 2.0.2) --
+* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver
+* May 1 2012
*
* .. Scalar Arguments ..
CHARACTER UPLO
@@ -383,7 +380,7 @@
* .. External Subroutines ..
EXTERNAL BLACS_GET, BLACS_GRIDEXIT, BLACS_GRIDINFO,
$ DESC_CONVERT, GLOBCHK, PXERBLA, RESHAPE, ZAXPY,
- $ ZGEMM, ZGERV2D, ZGESD2D, ZLACPY, ZLATCPY,
+ $ ZGEMM, ZGERV2D, ZGESD2D, ZLAMOV, ZLATCPY,
$ ZPBTRF, ZPOTRF, ZSYRK, ZTBTRS, ZTRMM, ZTRRV2D,
$ ZTRSD2D, ZTRSM, ZTRTRS
* ..
@@ -878,7 +875,7 @@
* Copy last diagonal block into AF storage for subsequent
* operations.
*
- CALL ZLACPY( 'N', BW, BW,
+ CALL ZLAMOV( 'N', BW, BW,
$ A( OFST+ODD_SIZE*LLDA+1 ),
$ LLDA-1, AF( ODD_SIZE*BW+MBW2+1 ),
$ BW )
@@ -965,7 +962,7 @@
* Move block into place that it will be expected to be for
* calcs.
*
- CALL ZLACPY( 'N', BW, BW, AF( ODD_SIZE*BW+1 ), BW,
+ CALL ZLAMOV( 'N', BW, BW, AF( ODD_SIZE*BW+1 ), BW,
$ AF( ODD_SIZE*BW+2*MBW2+1 ), BW )
*
ELSE
@@ -1124,7 +1121,7 @@
*
* Move the connection block in preparation.
*
- CALL ZLACPY( 'L', BW, BW, A( ( OFST+1+ODD_SIZE*LLDA ) ),
+ CALL ZLAMOV( 'L', BW, BW, A( ( OFST+1+ODD_SIZE*LLDA ) ),
$ LLDA-1, AF( ODD_SIZE*BW+2*MBW2+1+BW-BW ), BW )
*
*
@@ -1136,7 +1133,7 @@
*
* Move the resulting block back to its location in main storage.
*
- CALL ZLACPY( 'L', BW, BW, AF( ODD_SIZE*BW+2*MBW2+1+BW-BW ),
+ CALL ZLAMOV( 'L', BW, BW, AF( ODD_SIZE*BW+2*MBW2+1+BW-BW ),
$ BW, A(( OFST+1+ODD_SIZE*LLDA )), LLDA-1 )
*
*
@@ -1353,7 +1350,7 @@
* Move block into place that it will be expected to be for
* calcs.
*
- CALL ZLACPY( 'N', BW, BW, AF( ODD_SIZE*BW+1 ), BW,
+ CALL ZLAMOV( 'N', BW, BW, AF( ODD_SIZE*BW+1 ), BW,
$ AF( ODD_SIZE*BW+2*MBW2+1 ), BW )
*
ELSE
diff --git a/SRC/pzpbtrsv.f b/SRC/pzpbtrsv.f
index cb00fcc..33d8766 100644
--- a/SRC/pzpbtrsv.f
+++ b/SRC/pzpbtrsv.f
@@ -1,12 +1,9 @@
SUBROUTINE PZPBTRSV( UPLO, TRANS, N, BW, NRHS, A, JA, DESCA, B,
$ IB, DESCB, AF, LAF, WORK, LWORK, INFO )
*
-*
-*
-* -- ScaLAPACK routine (version 1.7) --
-* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
-* and University of California, Berkeley.
-* November 15, 1997
+* -- ScaLAPACK routine (version 2.0.2) --
+* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver
+* May 1 2012
*
* .. Scalar Arguments ..
CHARACTER TRANS, UPLO
@@ -401,7 +398,7 @@
* .. External Subroutines ..
EXTERNAL BLACS_GET, BLACS_GRIDEXIT, BLACS_GRIDINFO,
$ DESC_CONVERT, GLOBCHK, PXERBLA, RESHAPE, ZGEMM,
- $ ZGERV2D, ZGESD2D, ZLACPY, ZMATADD, ZTBTRS,
+ $ ZGERV2D, ZGESD2D, ZLAMOV, ZMATADD, ZTBTRS,
$ ZTRMM, ZTRTRS
* ..
* .. External Functions ..
@@ -772,7 +769,7 @@
* First copy and multiply it into temporary storage,
* then use it on RHS
*
- CALL ZLACPY( 'N', BW, NRHS,
+ CALL ZLAMOV( 'N', BW, NRHS,
$ B( PART_OFFSET+ODD_SIZE-BW+1), LLDB,
$ WORK( 1 ), BW )
*
@@ -1115,7 +1112,7 @@
* First copy and multiply it into temporary storage,
* then use it on RHS
*
- CALL ZLACPY( 'N', BW, NRHS, B( PART_OFFSET+ODD_SIZE+1), LLDB,
+ CALL ZLAMOV( 'N', BW, NRHS, B( PART_OFFSET+ODD_SIZE+1), LLDB,
$ WORK( 1+BW-BW ), BW )
*
CALL ZTRMM( 'L', 'U', 'C', 'N', BW, NRHS, -CONE,
@@ -1168,7 +1165,7 @@
* First copy and multiply it into temporary storage,
* then use it on RHS
*
- CALL ZLACPY( 'N', BW, NRHS,
+ CALL ZLAMOV( 'N', BW, NRHS,
$ B( PART_OFFSET+ODD_SIZE-BW+1), LLDB,
$ WORK( 1 ), BW )
*
@@ -1511,7 +1508,7 @@
* First copy and multiply it into temporary storage,
* then use it on RHS
*
- CALL ZLACPY( 'N', BW, NRHS, B( PART_OFFSET+ODD_SIZE+1), LLDB,
+ CALL ZLAMOV( 'N', BW, NRHS, B( PART_OFFSET+ODD_SIZE+1), LLDB,
$ WORK( 1+BW-BW ), BW )
*
CALL ZTRMM( 'L', 'L', 'N', 'N', BW, NRHS, -CONE,
diff --git a/SRC/pzpttrf.f b/SRC/pzpttrf.f
index 4cedcfd..5b679cd 100644
--- a/SRC/pzpttrf.f
+++ b/SRC/pzpttrf.f
@@ -1,12 +1,9 @@
SUBROUTINE PZPTTRF( N, D, E, JA, DESCA, AF, LAF, WORK, LWORK,
$ INFO )
*
-*
-*
-* -- ScaLAPACK routine (version 1.7) --
-* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
-* and University of California, Berkeley.
-* May 25, 2001
+* -- ScaLAPACK routine (version 2.0.2) --
+* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver
+* May 1 2012
*
* .. Scalar Arguments ..
INTEGER INFO, JA, LAF, LWORK, N
@@ -381,7 +378,7 @@
* .. External Subroutines ..
EXTERNAL BLACS_GET, BLACS_GRIDEXIT, BLACS_GRIDINFO,
$ DESC_CONVERT, GLOBCHK, PXERBLA, RESHAPE, ZAXPY,
- $ ZGEMM, ZGERV2D, ZGESD2D, ZLACPY, ZLATCPY,
+ $ ZGEMM, ZGERV2D, ZGESD2D, ZLAMOV, ZLATCPY,
$ ZPBTRF, ZPOTRF, ZSYRK, ZTBTRS, ZTRMM, ZTRRV2D,
$ ZTRSD2D, ZTRSM, ZTRTRS
* ..
diff --git a/SRC/pzpttrsv.f b/SRC/pzpttrsv.f
index e098a51..7103356 100644
--- a/SRC/pzpttrsv.f
+++ b/SRC/pzpttrsv.f
@@ -1,12 +1,9 @@
SUBROUTINE PZPTTRSV( UPLO, TRANS, N, NRHS, D, E, JA, DESCA, B, IB,
$ DESCB, AF, LAF, WORK, LWORK, INFO )
*
-*
-*
-* -- ScaLAPACK routine (version 1.7) --
-* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
-* and University of California, Berkeley.
-* November 15, 1997
+* -- ScaLAPACK routine (version 2.0.2) --
+* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver
+* May 1 2012
*
* .. Scalar Arguments ..
CHARACTER TRANS, UPLO
@@ -410,7 +407,7 @@
* .. External Subroutines ..
EXTERNAL BLACS_GET, BLACS_GRIDEXIT, BLACS_GRIDINFO,
$ DESC_CONVERT, GLOBCHK, PXERBLA, RESHAPE, ZGEMM,
- $ ZGERV2D, ZGESD2D, ZLACPY, ZMATADD, ZTBTRS,
+ $ ZGERV2D, ZGESD2D, ZLAMOV, ZMATADD, ZTBTRS,
$ ZTRMM, ZTRTRS
* ..
* .. External Functions ..
diff --git a/SRC/pzunmrq.f b/SRC/pzunmrq.f
index f2b07c8..fc25c4e 100644
--- a/SRC/pzunmrq.f
+++ b/SRC/pzunmrq.f
@@ -223,7 +223,7 @@
$ RSRC_ = 7, CSRC_ = 8, LLD_ = 9 )
* ..
* .. Local Scalars ..
- LOGICAL LEFT, LQUERY, NOTRAN
+ LOGICAL LEFT, LQUERY, NOTRAN, RIGHT, TRAN
CHARACTER COLBTOP, ROWBTOP, TRANST
INTEGER I, I1, I2, I3, IACOL, IB, ICCOL, ICOFFA,
$ ICOFFC, ICROW, ICTXT, IINFO, IPW, IROFFC, LCM,
@@ -259,8 +259,20 @@
IF( NPROW.EQ.-1 ) THEN
INFO = -(900+CTXT_)
ELSE
- LEFT = LSAME( SIDE, 'L' )
- NOTRAN = LSAME( TRANS, 'N' )
+ IF( LSAME( SIDE, 'L' ) ) THEN
+ LEFT = .TRUE.
+ RIGHT = .FALSE.
+ ELSE
+ LEFT = .FALSE.
+ RIGHT = .TRUE.
+ END IF
+ IF( LSAME( TRANS, 'N' ) ) THEN
+ NOTRAN = .TRUE.
+ TRAN = .FALSE.
+ ELSE
+ NOTRAN = .FALSE.
+ TRAN = .TRUE.
+ END IF
*
* NQ is the order of Q
*
@@ -440,8 +452,8 @@
$ WORK( IPW ) )
10 CONTINUE
*
- IF( ( LEFT .AND. .NOT.NOTRAN ) .OR.
- $ ( .NOT.LEFT .AND. NOTRAN ) ) THEN
+ IF( ( RIGHT .AND. TRAN ) .OR.
+ $ ( LEFT .AND. NOTRAN ) ) THEN
IB = I2 - IA
IF( LEFT ) THEN
MI = M - K + IB
diff --git a/SRC/sdbtf2.f b/SRC/sdbtf2.f
index 08f5b34..b1d814e 100644
--- a/SRC/sdbtf2.f
+++ b/SRC/sdbtf2.f
@@ -1,5 +1,8 @@
SUBROUTINE SDBTF2( M, N, KL, KU, AB, LDAB, INFO )
*
+* -- ScaLAPACK auxiliary routine (version 2.0) --
+* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver
+*
* Modified by Andrew J. Cleary in November, 96 from:
* -- LAPACK auxiliary routine (preliminary version) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
diff --git a/SRC/sdbtrf.f b/SRC/sdbtrf.f
index d0b27f2..8fbe469 100644
--- a/SRC/sdbtrf.f
+++ b/SRC/sdbtrf.f
@@ -1,5 +1,8 @@
SUBROUTINE SDBTRF( M, N, KL, KU, AB, LDAB, INFO )
*
+* -- ScaLAPACK auxiliary routine (version 2.0) --
+* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver
+*
* Written by Andrew J. Cleary, University of Tennessee.
* August, 1996.
* Modified from SGBTRF:
diff --git a/SRC/sdttrf.f b/SRC/sdttrf.f
index 3cd4f58..ccbd968 100644
--- a/SRC/sdttrf.f
+++ b/SRC/sdttrf.f
@@ -1,5 +1,8 @@
SUBROUTINE SDTTRF( N, DL, D, DU, INFO )
*
+* -- ScaLAPACK auxiliary routine (version 2.0) --
+* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver
+*
* Written by Andrew J. Cleary, November 1996.
* Modified from SGTTRF:
* -- LAPACK routine (preliminary version) --
diff --git a/SRC/sdttrsv.f b/SRC/sdttrsv.f
index d7e70ab..b1d517f 100644
--- a/SRC/sdttrsv.f
+++ b/SRC/sdttrsv.f
@@ -1,6 +1,9 @@
SUBROUTINE SDTTRSV( UPLO, TRANS, N, NRHS, DL, D, DU,
$ B, LDB, INFO )
*
+* -- ScaLAPACK auxiliary routine (version 2.0) --
+* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver
+*
* Written by Andrew J. Cleary, University of Tennessee.
* August, 1996.
* Modified from SGTTRS:
diff --git a/SRC/slamov.c b/SRC/slamov.c
new file mode 100644
index 0000000..1bf035d
--- /dev/null
+++ b/SRC/slamov.c
@@ -0,0 +1,11 @@
+//
+// slamov.c
+//
+// Written by Lee Killough 04/19/2012
+//
+
+#define TYPE float
+#define FUNC "SLAMOV"
+#define LAMOV slamov_
+#define LACPY slacpy_
+#include "lamov.h"
diff --git a/SRC/slaqr6.f b/SRC/slaqr6.f
new file mode 100644
index 0000000..44bdc79
--- /dev/null
+++ b/SRC/slaqr6.f
@@ -0,0 +1,861 @@
+ SUBROUTINE SLAQR6( JOB, 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 )
+*
+* Contribution from the Department of Computing Science and HPC2N,
+* Umea University, Sweden
+*
+* -- ScaLAPACK auxiliary routine (version 2.0.2) --
+* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver
+* May 1 2012
+*
+ IMPLICIT NONE
+*
+* .. Scalar Arguments ..
+ CHARACTER JOB
+ INTEGER IHIZ, ILOZ, KACC22, KBOT, KTOP, LDH, LDU, LDV,
+ $ LDWH, LDWV, LDZ, N, NH, NSHFTS, NV
+ LOGICAL WANTT, WANTZ
+* ..
+* .. Array Arguments ..
+ REAL H( LDH, * ), SI( * ), SR( * ), U( LDU, * ),
+ $ V( LDV, * ), WH( LDWH, * ), WV( LDWV, * ),
+ $ Z( LDZ, * )
+* ..
+*
+* This auxiliary subroutine called by PSLAQR5 performs a
+* single small-bulge multi-shift QR sweep, moving the chain
+* of bulges from top to bottom in the submatrix
+* H(KTOP:KBOT,KTOP:KBOT), collecting the transformations in the
+* matrix HV *or* accumulating the transformations in the matrix
+* Z (see below).
+*
+* This is a modified version of DLAQR5 from LAPACK 3.1.
+*
+* ======================================================================
+*
+* JOB (input) character scalar
+* Set the kind of job to do in SLAQR6, as follows:
+* JOB = 'I': Introduce and chase bulges in submatrix
+* JOB = 'C': Chase bulges from top to bottom of submatrix
+* JOB = 'O': Chase bulges off submatrix
+*
+* WANTT (input) logical scalar
+* WANTT = .true. if the quasi-triangular Schur factor
+* is being computed. WANTT is set to .false. otherwise.
+*
+* WANTZ (input) logical scalar
+* WANTZ = .true. if the orthogonal Schur factor is being
+* computed. WANTZ is set to .false. otherwise.
+*
+* KACC22 (input) integer with value 0, 1, or 2.
+* Specifies the computation mode of far-from-diagonal
+* orthogonal updates.
+* = 0: SLAQR6 does not accumulate reflections and does not
+* use matrix-matrix multiply to update far-from-diagonal
+* matrix entries.
+* = 1: SLAQR6 accumulates reflections and uses matrix-matrix
+* multiply to update the far-from-diagonal matrix entries.
+* = 2: SLAQR6 accumulates reflections, uses matrix-matrix
+* multiply to update the far-from-diagonal matrix entries,
+* and takes advantage of 2-by-2 block structure during
+* matrix multiplies.
+*
+* N (input) integer scalar
+* N is the order of the Hessenberg matrix H upon which this
+* subroutine operates.
+*
+* KTOP (input) integer scalar
+* KBOT (input) integer scalar
+* These are the first and last rows and columns of an
+* isolated diagonal block upon which the QR sweep is to be
+* applied. It is assumed without a check that
+* either KTOP = 1 or H(KTOP,KTOP-1) = 0
+* and
+* either KBOT = N or H(KBOT+1,KBOT) = 0.
+*
+* NSHFTS (input) integer scalar
+* NSHFTS gives the number of simultaneous shifts. NSHFTS
+* must be positive and even.
+*
+* SR (input) REAL array of size (NSHFTS)
+* SI (input) REAL array of size (NSHFTS)
+* SR contains the real parts and SI contains the imaginary
+* parts of the NSHFTS shifts of origin that define the
+* multi-shift QR sweep.
+*
+* H (input/output) REAL array of size (LDH,N)
+* On input H contains a Hessenberg matrix. On output a
+* multi-shift QR sweep with shifts SR(J)+i*SI(J) is applied
+* to the isolated diagonal block in rows and columns KTOP
+* through KBOT.
+*
+* LDH (input) integer scalar
+* LDH is the leading dimension of H just as declared in the
+* calling procedure. LDH.GE.MAX(1,N).
+*
+* ILOZ (input) INTEGER
+* IHIZ (input) INTEGER
+* Specify the rows of Z to which transformations must be
+* applied if WANTZ is .TRUE.. 1 .LE. ILOZ .LE. IHIZ .LE. N
+*
+* Z (input/output) REAL array of size (LDZ,IHI)
+* If WANTZ = .TRUE., then the QR Sweep orthogonal
+* similarity transformation is accumulated into
+* Z(ILOZ:IHIZ,ILO:IHI) from the right.
+* If WANTZ = .FALSE., then Z is unreferenced.
+*
+* LDZ (input) integer scalar
+* LDA is the leading dimension of Z just as declared in
+* the calling procedure. LDZ.GE.N.
+*
+* V (workspace) REAL array of size (LDV,NSHFTS/2)
+*
+* LDV (input) integer scalar
+* LDV is the leading dimension of V as declared in the
+* calling procedure. LDV.GE.3.
+*
+* U (workspace) REAL array of size
+* (LDU,3*NSHFTS-3)
+*
+* LDU (input) integer scalar
+* LDU is the leading dimension of U just as declared in the
+* in the calling subroutine. LDU.GE.3*NSHFTS-3.
+*
+* NH (input) integer scalar
+* NH is the number of columns in array WH available for
+* workspace. NH.GE.1 is required for usage of this
+* workspace, otherwise the updates of the far-from-diagonal
+* elements will be updated without level 3 BLAS.
+*
+* WH (workspace) REAL array of size (LDWH,NH)
+*
+* LDWH (input) integer scalar
+* Leading dimension of WH just as declared in the
+* calling procedure. LDWH.GE.3*NSHFTS-3.
+*
+* NV (input) integer scalar
+* NV is the number of rows in WV agailable for workspace.
+* NV.GE.1 is required for usage of this
+* workspace, otherwise the updates of the far-from-diagonal
+* elements will be updated without level 3 BLAS.
+*
+* WV (workspace) REAL array of size
+* (LDWV,3*NSHFTS-3)
+*
+* LDWV (input) integer scalar
+* LDWV is the leading dimension of WV as declared in the
+* in the calling subroutine. LDWV.GE.NV.
+*
+*
+* ================================================================
+* Based on contributions by
+* Karen Braman and Ralph Byers, Department of Mathematics,
+* University of Kansas, USA
+*
+* Robert Granat, Department of Computing Science and HPC2N,
+* Umea University, Sweden
+*
+* ============================================================
+* Reference:
+*
+* K. Braman, R. Byers and R. Mathias, The Multi-Shift QR
+* Algorithm Part I: Maintaining Well Focused Shifts, and
+* Level 3 Performance, SIAM Journal of Matrix Analysis,
+* volume 23, pages 929--947, 2002.
+*
+* ============================================================
+* .. Parameters ..
+ REAL ZERO, ONE
+ PARAMETER ( ZERO = 0.0e0, ONE = 1.0e0 )
+* ..
+* .. Local Scalars ..
+ REAL 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, SINCOL, EINCOL, UINCOL, IPHV, CHUNK,
+ $ THREADS, JLEN2, JCOL2, GCHUNK, JROW2, MAXCHUNK
+ LOGICAL ACCUM, BLK22, BMP22, INTRO, CHASE, OFF, ALL
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ INTEGER PILAENVX
+ REAL SLAMCH
+ EXTERNAL LSAME, SLAMCH, PILAENVX
+* ..
+* .. Intrinsic Functions ..
+*
+ INTRINSIC ABS, FLOAT, MAX, MIN, MOD
+* ..
+* .. Local Arrays ..
+ REAL VT( 3 )
+* ..
+* .. External Subroutines ..
+ EXTERNAL SGEMM, SLABAD, SLAMOV, SLAQR1, SLARFG, SLASET,
+ $ STRMM
+* ..
+* .. 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
+ THREADS = 1
+*
+* ==== 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 = SLAMCH( 'SAFE MINIMUM' )
+ SAFMAX = ONE / SAFMIN
+ CALL SLABAD( SAFMIN, SAFMAX )
+ ULP = SLAMCH( 'PRECISION' )
+ SMLNUM = SAFMIN*( FLOAT( N ) / ULP )
+*
+* ==== Use accumulated reflections to update far-from-diagonal
+* . entries ? This is only performed if both NH and NV is
+* greater than 1. ====
+*
+ ACCUM = ( KACC22.EQ.1 ) .OR. ( KACC22.EQ.2 )
+ ACCUM = ACCUM .AND. NH.GE.1 .AND. NV.GE.1
+*
+* ==== If so, exploit the 2-by-2 block structure? ====
+*
+ BLK22 = ( NS.GT.2 ) .AND. ( KACC22.EQ.2 )
+*
+* ==== Decode JOB ====
+*
+ ALL = LSAME( JOB, 'A' )
+ IF( .NOT. ALL )
+ $ INTRO = LSAME( JOB, 'I' )
+ IF( .NOT. ALL .AND. .NOT. INTRO )
+ $ CHASE = LSAME( JOB, 'C' )
+ IF( .NOT. ALL .AND. .NOT. INTRO .AND. .NOT. CHASE ) THEN
+ OFF = LSAME( JOB, 'O' )
+ IF( .NOT. OFF )
+ $ RETURN
+ END IF
+*
+* ==== clear trash ====
+*
+ IF( INTRO.OR.ALL .AND. 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
+*
+* Set loop limits for bulge-chasing depending on working mode
+*
+ IF( ALL ) THEN
+ SINCOL = 3*( 1-NBMPS ) + KTOP - 1
+ EINCOL = KBOT - 2
+ UINCOL = 3*NBMPS - 2
+ ELSEIF( INTRO ) THEN
+ SINCOL = 3*( 1-NBMPS ) + KTOP - 1
+ EINCOL = KBOT - 3*NBMPS - 1
+ UINCOL = 3*NBMPS - 2
+ ELSEIF( CHASE ) THEN
+ SINCOL = KTOP
+ EINCOL = KBOT - 3*NBMPS - 1
+ UINCOL = 3*NBMPS - 2
+ ELSEIF( OFF ) THEN
+ SINCOL = KTOP
+ EINCOL = KBOT - 2
+ UINCOL = 3*NBMPS - 2
+ END IF
+ IPHV = 0
+*
+* ==== Create and/or chase chains of NBMPS bulges ====
+*
+ DO 220 INCOL = SINCOL, EINCOL, UINCOL
+ NDCOL = MIN( INCOL + KDU, EINCOL )
+ IF( ACCUM )
+ $ CALL SLASET( '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( EINCOL, 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 SLAQR1( 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 SLARFG( 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 SLARFG( 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 SLAQR1( 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 SLARFG( 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 SLAQR1( 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 SLARFG( 2, BETA, V( 2, M22 ), 1, V( 1, M22 ) )
+ ELSE
+ BETA = H( K+1, K )
+ V( 2, M22 ) = H( K+2, K )
+ CALL SLARFG( 2, BETA, V( 2, M22 ), 1, V( 1, M22 ) )
+ H( K+1, K ) = BETA
+ H( K+2, K ) = ZERO
+ END IF
+ ELSE
+*
+* ==== Initialize V(1,M22) here to avoid possible undefined
+* . variable problems later. ====
+*
+ V( 1, M22 ) = ZERO
+ END IF
+*
+* ==== Multiply H by reflections from the left ====
+*
+ IF( ACCUM ) THEN
+ JBOT = MIN( MAX(INCOL+KDU,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
+ K1 = MAX( 1, KTOP-INCOL )
+ NU = ( KDU-MAX( 0, MAX(INCOL+KDU,NDCOL)-KBOT ) ) - K1 + 1
+ IF( ( .NOT.BLK22 ) .OR. ( INCOL.LT.KTOP ) .OR.
+ $ ( NDCOL.GT.KBOT ) .OR. ( NS.LE.2 ) .OR.
+ $ NU.LT.KDU ) 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. ====
+*
+* ==== Horizontal Multiply ====
+*
+ DO 160 JCOL = MIN(MAX(INCOL+KDU,NDCOL),KBOT)+ 1, JBOT, NH
+ JLEN = MIN( NH, JBOT-JCOL+1 )
+ CALL SGEMM( 'C', 'N', NU, JLEN, NU, ONE, U( K1, K1 ),
+ $ LDU, H( INCOL+K1, JCOL ), LDH, ZERO, WH,
+ $ LDWH )
+ CALL SLAMOV( '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 SGEMM( 'N', 'N', JLEN, NU, NU, ONE,
+ $ H( JROW, INCOL+K1 ), LDH, U( K1, K1 ),
+ $ LDU, ZERO, WV, LDWV )
+ CALL SLAMOV( '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 SGEMM( 'N', 'N', JLEN, NU, NU, ONE,
+ $ Z( JROW, INCOL+K1 ), LDZ, U( K1, K1 ),
+ $ LDU, ZERO, WV, LDWV )
+ CALL SLAMOV( '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(MAX(INCOL+KDU,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 SLAMOV( 'ALL', KNZ, JLEN, H( INCOL+1+J2, JCOL ),
+ $ LDH, WH( KZS+1, 1 ), LDWH )
+ CALL SLASET( 'ALL', KZS, JLEN, ZERO, ZERO, WH, LDWH )
+*
+* ==== Multiply by U21' ====
+*
+ CALL STRMM( 'L', 'U', 'C', 'N', KNZ, JLEN, ONE,
+ $ U( J2+1, 1+KZS ), LDU, WH( KZS+1, 1 ),
+ $ LDWH )
+*
+* ==== Multiply top of H by U11' ====
+*
+ CALL SGEMM( '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 SLAMOV( 'ALL', J2, JLEN, H( INCOL+1, JCOL ), LDH,
+ $ WH( I2+1, 1 ), LDWH )
+*
+* ==== Multiply by U21' ====
+*
+ CALL STRMM( 'L', 'L', 'C', 'N', J2, JLEN, ONE,
+ $ U( 1, I2+1 ), LDU, WH( I2+1, 1 ), LDWH )
+*
+* ==== Multiply by U22 ====
+*
+ CALL SGEMM( '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 SLAMOV( '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 SLAMOV( 'ALL', JLEN, KNZ, H( JROW, INCOL+1+J2 ),
+ $ LDH, WV( 1, 1+KZS ), LDWV )
+ CALL SLASET( 'ALL', JLEN, KZS, ZERO, ZERO, WV, LDWV )
+*
+* ==== Multiply by U21 ====
+*
+ CALL STRMM( 'R', 'U', 'N', 'N', JLEN, KNZ, ONE,
+ $ U( J2+1, 1+KZS ), LDU, WV( 1, 1+KZS ),
+ $ LDWV )
+*
+* ==== Multiply by U11 ====
+*
+ CALL SGEMM( '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 SLAMOV( 'ALL', JLEN, J2, H( JROW, INCOL+1 ), LDH,
+ $ WV( 1, 1+I2 ), LDWV )
+*
+* ==== Multiply by U21 ====
+*
+ CALL STRMM( 'R', 'L', 'N', 'N', JLEN, I4-I2, ONE,
+ $ U( 1, I2+1 ), LDU, WV( 1, 1+I2 ), LDWV )
+*
+* ==== Multiply by U22 ====
+*
+ CALL SGEMM( '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 SLAMOV( '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 SLAMOV( 'ALL', JLEN, KNZ,
+ $ Z( JROW, INCOL+1+J2 ), LDZ,
+ $ WV( 1, 1+KZS ), LDWV )
+*
+* ==== Multiply by U12 ====
+*
+ CALL SLASET( 'ALL', JLEN, KZS, ZERO, ZERO, WV,
+ $ LDWV )
+ CALL STRMM( 'R', 'U', 'N', 'N', JLEN, KNZ, ONE,
+ $ U( J2+1, 1+KZS ), LDU, WV( 1, 1+KZS ),
+ $ LDWV )
+*
+* ==== Multiply by U11 ====
+*
+ CALL SGEMM( '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 SLAMOV( 'ALL', JLEN, J2, Z( JROW, INCOL+1 ),
+ $ LDZ, WV( 1, 1+I2 ), LDWV )
+*
+* ==== Multiply by U21 ====
+*
+ CALL STRMM( 'R', 'L', 'N', 'N', JLEN, I4-I2, ONE,
+ $ U( 1, I2+1 ), LDU, WV( 1, 1+I2 ),
+ $ LDWV )
+*
+* ==== Multiply by U22 ====
+*
+ CALL SGEMM( '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 SLAMOV( 'ALL', JLEN, KDU, WV, LDWV,
+ $ Z( JROW, INCOL+1 ), LDZ )
+ 210 CONTINUE
+ END IF
+ END IF
+ END IF
+ 220 CONTINUE
+*
+* ==== Clear out workspaces and return. ====
+*
+ IF( N.GE.5 )
+ $ CALL SLASET( 'Lower', N-4, N-4, ZERO, ZERO, H(5,1), LDH )
+*
+* ==== End of SLAQR6 ====
+*
+ END
diff --git a/SRC/slar1va.f b/SRC/slar1va.f
new file mode 100644
index 0000000..e0f660e
--- /dev/null
+++ b/SRC/slar1va.f
@@ -0,0 +1,423 @@
+ SUBROUTINE SLAR1VA(N, B1, BN, LAMBDA, D, L, LD, LLD,
+ $ PIVMIN, GAPTOL, Z, WANTNC, NEGCNT, ZTZ, MINGMA,
+ $ R, ISUPPZ, NRMINV, RESID, RQCORR, WORK )
+*
+ IMPLICIT NONE
+*
+* -- ScaLAPACK computational routine (version 2.0) --
+* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver
+* July 4, 2010
+*
+* .. Scalar Arguments ..
+ LOGICAL WANTNC
+ INTEGER B1, BN, N, NEGCNT, R
+ REAL GAPTOL, LAMBDA, MINGMA, NRMINV, PIVMIN, RESID,
+ $ RQCORR, ZTZ
+* ..
+* .. Array Arguments ..
+ INTEGER ISUPPZ( * )
+ REAL D( * ), L( * ), LD( * ), LLD( * ),
+ $ WORK( * )
+ REAL Z( * )
+*
+* Purpose
+* =======
+*
+* SLAR1VA computes the (scaled) r-th column of the inverse of
+* the sumbmatrix in rows B1 through BN of the tridiagonal matrix
+* L D L^T - sigma I. When sigma is close to an eigenvalue, the
+* computed vector is an accurate eigenvector. Usually, r corresponds
+* to the index where the eigenvector is largest in magnitude.
+* The following steps accomplish this computation :
+* (a) Stationary qd transform, L D L^T - sigma I = L(+) D(+) L(+)^T,
+* (b) Progressive qd transform, L D L^T - sigma I = U(-) D(-) U(-)^T,
+* (c) Computation of the diagonal elements of the inverse of
+* L D L^T - sigma I by combining the above transforms, and choosing
+* r as the index where the diagonal of the inverse is (one of the)
+* largest in magnitude.
+* (d) Computation of the (scaled) r-th column of the inverse using the
+* twisted factorization obtained by combining the top part of the
+* the stationary and the bottom part of the progressive transform.
+*
+* Arguments
+* =========
+*
+* N (input) INTEGER
+* The order of the matrix L D L^T.
+*
+* B1 (input) INTEGER
+* First index of the submatrix of L D L^T.
+*
+* BN (input) INTEGER
+* Last index of the submatrix of L D L^T.
+*
+* LAMBDA (input) REAL
+* The shift. In order to compute an accurate eigenvector,
+* LAMBDA should be a good approximation to an eigenvalue
+* of L D L^T.
+*
+* L (input) REAL array, dimension (N-1)
+* The (n-1) subdiagonal elements of the unit bidiagonal matrix
+* L, in elements 1 to N-1.
+*
+* D (input) REAL array, dimension (N)
+* The n diagonal elements of the diagonal matrix D.
+*
+* LD (input) REAL array, dimension (N-1)
+* The n-1 elements L(i)*D(i).
+*
+* LLD (input) REAL array, dimension (N-1)
+* The n-1 elements L(i)*L(i)*D(i).
+*
+* PIVMIN (input) REAL
+* The minimum pivot in the Sturm sequence.
+*
+* GAPTOL (input) REAL
+* Tolerance that indicates when eigenvector entries are negligible
+* w.r.t. their contribution to the residual.
+*
+* Z (input/output) REAL array, dimension (N)
+* On input, all entries of Z must be set to 0.
+* On output, Z contains the (scaled) r-th column of the
+* inverse. The scaling is such that Z(R) equals 1.
+*
+* WANTNC (input) LOGICAL
+* Specifies whether NEGCNT has to be computed.
+*
+* NEGCNT (output) INTEGER
+* If WANTNC is .TRUE. then NEGCNT = the number of pivots < pivmin
+* in the matrix factorization L D L^T, and NEGCNT = -1 otherwise.
+*
+* ZTZ (output) REAL
+* The square of the 2-norm of Z.
+*
+* MINGMA (output) REAL
+* The reciprocal of the largest (in magnitude) diagonal
+* element of the inverse of L D L^T - sigma I.
+*
+* R (input/output) INTEGER
+* The twist index for the twisted factorization used to
+* compute Z.
+* On input, 0 <= R <= N. If R is input as 0, R is set to
+* the index where (L D L^T - sigma I)^{-1} is largest
+* in magnitude. If 1 <= R <= N, R is unchanged.
+* On output, R contains the twist index used to compute Z.
+* Ideally, R designates the position of the maximum entry in the
+* eigenvector.
+*
+* ISUPPZ (output) INTEGER array, dimension (2)
+* The support of the vector in Z, i.e., the vector Z is
+* nonzero only in elements ISUPPZ(1) through ISUPPZ( 2 ).
+*
+* NRMINV (output) REAL
+* NRMINV = 1/SQRT( ZTZ )
+*
+* RESID (output) REAL
+* The residual of the FP vector.
+* RESID = ABS( MINGMA )/SQRT( ZTZ )
+*
+* RQCORR (output) REAL
+* The Rayleigh Quotient correction to LAMBDA.
+* RQCORR = MINGMA*TMP
+*
+* WORK (workspace) REAL array, dimension (4*N)
+*
+* Further Details
+* ===============
+*
+* Based on contributions by
+* Beresford Parlett, University of California, Berkeley, USA
+* Jim Demmel, University of California, Berkeley, USA
+* Inderjit Dhillon, University of Texas, Austin, USA
+* Osni Marques, LBNL/NERSC, USA
+* Christof Voemel, University of California, Berkeley, USA
+*
+* =====================================================================
+*
+* .. Parameters ..
+ INTEGER BLKLEN
+ PARAMETER ( BLKLEN = 16 )
+ REAL ZERO, ONE
+ PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0 )
+
+* ..
+* .. Local Scalars ..
+ LOGICAL SAWNAN1, SAWNAN2
+ INTEGER BI, I, INDLPL, INDP, INDS, INDUMN, NB, NEG1,
+ $ NEG2, NX, R1, R2, TO
+ REAL ABSZCUR, ABSZPREV, DMINUS, DPLUS, EPS,
+ $ S, TMP, ZPREV
+* ..
+* .. External Functions ..
+ LOGICAL SISNAN
+ REAL SLAMCH
+ EXTERNAL SISNAN, SLAMCH
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX, MIN, REAL
+* ..
+* .. Executable Statements ..
+*
+ EPS = SLAMCH( '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 = SISNAN( 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 = SISNAN( 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 = SISNAN( 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
+*
+ NB = INT((R-B1)/BLKLEN)
+ NX = R-NB*BLKLEN
+ IF( .NOT.SAWNAN1 ) THEN
+ DO 210 BI = R-1, NX, -BLKLEN
+ TO = BI-BLKLEN+1
+ DO 205 I = BI, TO, -1
+ Z( I ) = -( WORK(INDLPL+I)*Z(I+1) )
+ ZTZ = ZTZ + Z( I )*Z( I )
+ 205 CONTINUE
+ IF( ABS(Z(TO)).LT.EPS .AND.
+ $ ABS(Z(TO+1)).LT.EPS ) THEN
+ ISUPPZ(1) = TO
+ GOTO 220
+ ENDIF
+ 210 CONTINUE
+ DO 215 I = NX-1, B1, -1
+ Z( I ) = -( WORK(INDLPL+I)*Z(I+1) )
+ ZTZ = ZTZ + Z( I )*Z( I )
+ 215 CONTINUE
+ 220 CONTINUE
+ ELSE
+* Run slower loop if NaN occurred.
+ DO 230 BI = R-1, NX, -BLKLEN
+ TO = BI-BLKLEN+1
+ DO 225 I = BI, TO, -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
+ ZTZ = ZTZ + Z( I )*Z( I )
+ 225 CONTINUE
+ IF( ABS(Z(TO)).LT.EPS .AND.
+ $ ABS(Z(TO+1)).LT.EPS ) THEN
+ ISUPPZ(1) = TO
+ GOTO 240
+ ENDIF
+ 230 CONTINUE
+ DO 235 I = NX-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
+ ZTZ = ZTZ + Z( I )*Z( I )
+ 235 CONTINUE
+ 240 CONTINUE
+ ENDIF
+ DO 245 I= B1, (ISUPPZ(1)-1)
+ Z(I) = ZERO
+ 245 CONTINUE
+
+* Compute the FP vector downwards from R in blocks of size BLKLEN
+ IF( .NOT.SAWNAN2 ) THEN
+ DO 260 BI = R+1, BN, BLKLEN
+ TO = BI+BLKLEN-1
+ IF ( TO.LE.BN ) THEN
+ DO 250 I = BI, TO
+ Z(I) = -(WORK(INDUMN+I-1)*Z(I-1))
+ ZTZ = ZTZ + Z( I )*Z( I )
+ 250 CONTINUE
+ IF( ABS(Z(TO)).LE.EPS .AND.
+ $ ABS(Z(TO-1)).LE.EPS ) THEN
+ ISUPPZ(2) = TO
+ GOTO 265
+ ENDIF
+ ELSE
+ DO 255 I = BI, BN
+ Z(I) = -(WORK(INDUMN+I-1)*Z(I-1))
+ ZTZ = ZTZ + Z( I )*Z( I )
+ 255 CONTINUE
+ ENDIF
+ 260 CONTINUE
+ 265 CONTINUE
+ ELSE
+* Run slower loop if NaN occurred.
+ DO 280 BI = R+1, BN, BLKLEN
+ TO = BI+BLKLEN-1
+ IF ( TO.LE.BN ) THEN
+ DO 270 I = BI, TO
+ ZPREV = Z(I-1)
+ ABSZPREV = ABS(ZPREV)
+ IF( ZPREV.NE.ZERO ) THEN
+ Z(I)= -(WORK(INDUMN+I-1)*ZPREV)
+ ELSE
+ Z(I)= -(LD(I-2)/LD(I-1))*Z(I-2)
+ END IF
+ ABSZCUR = ABS(Z(I))
+ ZTZ = ZTZ + ABSZCUR**2
+ 270 CONTINUE
+ IF( ABSZCUR.LT.EPS .AND.
+ $ ABSZPREV.LT.EPS ) THEN
+ ISUPPZ(2) = I
+ GOTO 285
+ ENDIF
+ ELSE
+ DO 275 I = BI, BN
+ ZPREV = Z(I-1)
+ ABSZPREV = ABS(ZPREV)
+ IF( ZPREV.NE.ZERO ) THEN
+ Z(I)= -(WORK(INDUMN+I-1)*ZPREV)
+ ELSE
+ Z(I)= -(LD(I-2)/LD(I-1))*Z(I-2)
+ END IF
+ ABSZCUR = ABS(Z(I))
+ ZTZ = ZTZ + ABSZCUR**2
+ 275 CONTINUE
+ ENDIF
+ 280 CONTINUE
+ 285 CONTINUE
+ END IF
+ DO 290 I= ISUPPZ(2)+1,BN
+ Z(I) = ZERO
+ 290 CONTINUE
+*
+* Compute quantities for convergence test
+*
+ TMP = ONE / ZTZ
+ NRMINV = SQRT( TMP )
+ RESID = ABS( MINGMA )*NRMINV
+ RQCORR = MINGMA*TMP
+*
+ RETURN
+*
+* End of SLAR1VA
+*
+ END
diff --git a/SRC/slaref.f b/SRC/slaref.f
index 30a6a43..3639132 100644
--- a/SRC/slaref.f
+++ b/SRC/slaref.f
@@ -1,11 +1,12 @@
SUBROUTINE SLAREF( TYPE, A, LDA, WANTZ, Z, LDZ, BLOCK, IROW1,
- $ ICOL1, ISTART, ISTOP, ITMP1, ITMP2, LILOZ,
- $ LIHIZ, VECS, V2, V3, T1, T2, T3 )
+ $ ICOL1, ISTART, ISTOP, ITMP1, ITMP2, LILOZ,
+ $ LIHIZ, VECS, V2, V3, T1, T2, T3 )
+ IMPLICIT NONE
*
-* -- ScaLAPACK routine (version 1.7) --
+* -- ScaLAPACK auxiliary routine (version 1.5) --
* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
* and University of California, Berkeley.
-* December 31, 1998
+* May 1, 1997
*
* .. Scalar Arguments ..
LOGICAL BLOCK, WANTZ
@@ -34,7 +35,7 @@
* Otherwise: Apply reflectors to the columns of the matrix
* Unchanged on exit.
*
-* A (global input/output) REAL array, (LDA,*)
+* A (global input/output) REAL array, (LDA,*)
* On entry, the matrix to receive the reflections.
* The updated matrix on exit.
*
@@ -45,7 +46,7 @@
* If .TRUE., then apply any column reflections to Z as well.
* If .FALSE., then do no additional work on Z.
*
-* Z (global input/output) REAL array, (LDZ,*)
+* Z (global input/output) REAL array, (LDZ,*)
* On entry, the second matrix to receive column reflections.
* This is changed only if WANTZ is set.
*
@@ -90,8 +91,8 @@
* These serve the same purpose as ITMP1,ITMP2 but for Z
* when WANTZ is set.
*
-* VECS (global input) REAL array of size 3*N (matrix
-* size)
+* VECS (global input) REAL array of size 3*N (matrix
+* size)
* This holds the size 3 reflectors one after another and this
* is only accessed when BLOCK is .TRUE.
*
@@ -99,19 +100,21 @@
* V3
* T1
* T2
-* T3 (global input/output) REAL
+* T3 (global input/output) REAL
* This holds information on a single size 3 Householder
* reflector and is read when BLOCK is .FALSE., and
* overwritten when BLOCK is .TRUE.
*
-* Implemented by: G. Henry, November 17, 1996
+* Implemented by: G. Henry, May 1, 1997
*
* =====================================================================
*
* .. Local Scalars ..
INTEGER J, K
REAL H11, H22, SUM, T12, T13, T22, T23, T32, T33,
- $ V22, V23, V32, V33
+ $ V22, V23, V32, V33, A1, A2, A3, A4, A5, B1,
+ $ B2, B3, B4, B5, TMP1, TMP2, TMP3, SUM1, SUM2,
+ $ SUM3, A11, A22
* ..
* .. External Functions ..
LOGICAL LSAME
@@ -124,7 +127,7 @@
*
IF( LSAME( TYPE, 'R' ) ) THEN
IF( BLOCK ) THEN
- DO 20 K = ISTART, ISTOP - MOD( ISTOP-ISTART+1, 3 ), 3
+ DO 30 K = ISTART, ISTOP - MOD( ISTOP-ISTART+1, 3 ), 3
V2 = VECS( ( K-1 )*3+1 )
V3 = VECS( ( K-1 )*3+2 )
T1 = VECS( ( K-1 )*3+3 )
@@ -140,7 +143,43 @@
T32 = T12*V32
T23 = T13*V23
T33 = T13*V33
- DO 10 J = ITMP1, ITMP2
+ DO 10 J = ITMP1, ITMP2-MOD(ITMP2-ITMP1+1,2), 2
+ A1 = A ( IROW1 , J )
+ A2 = A ( IROW1+1, J )
+ A3 = A ( IROW1+2, J )
+ A4 = A ( IROW1+3, J )
+ A5 = A ( IROW1+4, J )
+ B1 = A ( IROW1 , J+1 )
+ B2 = A ( IROW1+1, J+1 )
+ B3 = A ( IROW1+2, J+1 )
+ B4 = A ( IROW1+3, J+1 )
+ B5 = A ( IROW1+4, J+1 )
+ SUM1 = A1 + V2*A2 + V3*A3
+ A( IROW1 , J ) = A1 - SUM1 * T1
+ H11 = A2 - SUM1 * T2
+ H22 = A3 - SUM1 * T3
+ TMP1 = B1 + V2*B2 + V3*B3
+ A( IROW1 , J+1 ) = B1 - TMP1 * T1
+ A11 = B2 - TMP1 * T2
+ A22 = B3 - TMP1 * T3
+ SUM2 = H11 + V22*H22 + V32*A4
+ A( IROW1+1, J ) = H11 - SUM2 * T12
+ H11 = H22 - SUM2 * T22
+ H22 = A4 - SUM2 * T32
+ TMP2 = A11 + V22*A22 + V32*B4
+ A( IROW1+1, J+1 ) = A11 - TMP2 * T12
+ A11 = A22 - TMP2 * T22
+ A22 = B4 - TMP2 * T32
+ SUM3 = H11 + V23*H22 + V33*A5
+ A( IROW1+2, J ) = H11 - SUM3 * T13
+ A( IROW1+3, J ) = H22 - SUM3 * T23
+ A( IROW1+4, J ) = A5 - SUM3 * T33
+ TMP3 = A11 + V23*A22 + V33*B5
+ A( IROW1+2, J+1 ) = A11 - TMP3 * T13
+ A( IROW1+3, J+1 ) = A22 - TMP3 * T23
+ A( IROW1+4, J+1 ) = B5 - TMP3 * T33
+ 10 CONTINUE
+ DO 20 J = ITMP2-MOD(ITMP2-ITMP1+1,2)+1, ITMP2
SUM = A( IROW1, J ) + V2*A( IROW1+1, J ) +
$ V3*A( IROW1+2, J )
A( IROW1, J ) = A( IROW1, J ) - SUM*T1
@@ -154,39 +193,39 @@
A( IROW1+2, J ) = H11 - SUM*T13
A( IROW1+3, J ) = H22 - SUM*T23
A( IROW1+4, J ) = A( IROW1+4, J ) - SUM*T33
- 10 CONTINUE
+ 20 CONTINUE
IROW1 = IROW1 + 3
- 20 CONTINUE
- DO 40 K = ISTOP - MOD( ISTOP-ISTART+1, 3 ) + 1, ISTOP
+ 30 CONTINUE
+ DO 50 K = ISTOP - MOD( ISTOP-ISTART+1, 3 ) + 1, ISTOP
V2 = VECS( ( K-1 )*3+1 )
V3 = VECS( ( K-1 )*3+2 )
T1 = VECS( ( K-1 )*3+3 )
T2 = T1*V2
T3 = T1*V3
- DO 30 J = ITMP1, ITMP2
+ DO 40 J = ITMP1, ITMP2
SUM = A( IROW1, J ) + V2*A( IROW1+1, J ) +
$ V3*A( IROW1+2, J )
A( IROW1, J ) = A( IROW1, J ) - SUM*T1
A( IROW1+1, J ) = A( IROW1+1, J ) - SUM*T2
A( IROW1+2, J ) = A( IROW1+2, J ) - SUM*T3
- 30 CONTINUE
+ 40 CONTINUE
IROW1 = IROW1 + 1
- 40 CONTINUE
+ 50 CONTINUE
ELSE
- DO 50 J = ITMP1, ITMP2
+ DO 60 J = ITMP1, ITMP2
SUM = A( IROW1, J ) + V2*A( IROW1+1, J ) +
$ V3*A( IROW1+2, J )
A( IROW1, J ) = A( IROW1, J ) - SUM*T1
A( IROW1+1, J ) = A( IROW1+1, J ) - SUM*T2
A( IROW1+2, J ) = A( IROW1+2, J ) - SUM*T3
- 50 CONTINUE
+ 60 CONTINUE
END IF
ELSE
*
* Do column transforms
*
IF( BLOCK ) THEN
- DO 80 K = ISTART, ISTOP - MOD( ISTOP-ISTART+1, 3 ), 3
+ DO 90 K = ISTART, ISTOP - MOD( ISTOP-ISTART+1, 3 ), 3
V2 = VECS( ( K-1 )*3+1 )
V3 = VECS( ( K-1 )*3+2 )
T1 = VECS( ( K-1 )*3+3 )
@@ -202,7 +241,7 @@
T32 = T12*V32
T23 = T13*V23
T33 = T13*V33
- DO 60 J = ITMP1, ITMP2
+ DO 70 J = ITMP1, ITMP2
SUM = A( J, ICOL1 ) + V2*A( J, ICOL1+1 ) +
$ V3*A( J, ICOL1+2 )
A( J, ICOL1 ) = A( J, ICOL1 ) - SUM*T1
@@ -216,9 +255,9 @@
A( J, ICOL1+2 ) = H11 - SUM*T13
A( J, ICOL1+3 ) = H22 - SUM*T23
A( J, ICOL1+4 ) = A( J, ICOL1+4 ) - SUM*T33
- 60 CONTINUE
+ 70 CONTINUE
IF( WANTZ ) THEN
- DO 70 J = LILOZ, LIHIZ
+ DO 80 J = LILOZ, LIHIZ
SUM = Z( J, ICOL1 ) + V2*Z( J, ICOL1+1 ) +
$ V3*Z( J, ICOL1+2 )
Z( J, ICOL1 ) = Z( J, ICOL1 ) - SUM*T1
@@ -232,42 +271,42 @@
Z( J, ICOL1+2 ) = H11 - SUM*T13
Z( J, ICOL1+3 ) = H22 - SUM*T23
Z( J, ICOL1+4 ) = Z( J, ICOL1+4 ) - SUM*T33
- 70 CONTINUE
+ 80 CONTINUE
END IF
ICOL1 = ICOL1 + 3
- 80 CONTINUE
- DO 110 K = ISTOP - MOD( ISTOP-ISTART+1, 3 ) + 1, ISTOP
+ 90 CONTINUE
+ DO 120 K = ISTOP - MOD( ISTOP-ISTART+1, 3 ) + 1, ISTOP
V2 = VECS( ( K-1 )*3+1 )
V3 = VECS( ( K-1 )*3+2 )
T1 = VECS( ( K-1 )*3+3 )
T2 = T1*V2
T3 = T1*V3
- DO 90 J = ITMP1, ITMP2
+ DO 100 J = ITMP1, ITMP2
SUM = A( J, ICOL1 ) + V2*A( J, ICOL1+1 ) +
$ V3*A( J, ICOL1+2 )
A( J, ICOL1 ) = A( J, ICOL1 ) - SUM*T1
A( J, ICOL1+1 ) = A( J, ICOL1+1 ) - SUM*T2
A( J, ICOL1+2 ) = A( J, ICOL1+2 ) - SUM*T3
- 90 CONTINUE
+ 100 CONTINUE
IF( WANTZ ) THEN
- DO 100 J = LILOZ, LIHIZ
+ DO 110 J = LILOZ, LIHIZ
SUM = Z( J, ICOL1 ) + V2*Z( J, ICOL1+1 ) +
$ V3*Z( J, ICOL1+2 )
Z( J, ICOL1 ) = Z( J, ICOL1 ) - SUM*T1
Z( J, ICOL1+1 ) = Z( J, ICOL1+1 ) - SUM*T2
Z( J, ICOL1+2 ) = Z( J, ICOL1+2 ) - SUM*T3
- 100 CONTINUE
+ 110 CONTINUE
END IF
ICOL1 = ICOL1 + 1
- 110 CONTINUE
+ 120 CONTINUE
ELSE
- DO 120 J = ITMP1, ITMP2
+ DO 130 J = ITMP1, ITMP2
SUM = A( J, ICOL1 ) + V2*A( J, ICOL1+1 ) +
$ V3*A( J, ICOL1+2 )
A( J, ICOL1 ) = A( J, ICOL1 ) - SUM*T1
A( J, ICOL1+1 ) = A( J, ICOL1+1 ) - SUM*T2
A( J, ICOL1+2 ) = A( J, ICOL1+2 ) - SUM*T3
- 120 CONTINUE
+ 130 CONTINUE
END IF
END IF
RETURN
diff --git a/SRC/slarrb2.f b/SRC/slarrb2.f
new file mode 100644
index 0000000..c38d00c
--- /dev/null
+++ b/SRC/slarrb2.f
@@ -0,0 +1,662 @@
+ SUBROUTINE SLARRB2( N, D, LLD, IFIRST, ILAST, RTOL1,
+ $ RTOL2, OFFSET, W, WGAP, WERR, WORK, IWORK,
+ $ PIVMIN, LGPVMN, LGSPDM, TWIST, INFO )
+*
+* -- ScaLAPACK auxiliary routine (version 2.0) --
+* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver
+* July 4, 2010
+*
+ IMPLICIT NONE
+*
+* .. Scalar Arguments ..
+ INTEGER IFIRST, ILAST, INFO, N, OFFSET, TWIST
+ REAL LGPVMN, LGSPDM, PIVMIN,
+ $ RTOL1, RTOL2
+* ..
+* .. Array Arguments ..
+ INTEGER IWORK( * )
+ REAL D( * ), LLD( * ), W( * ),
+ $ WERR( * ), WGAP( * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* Given the relatively robust representation(RRR) L D L^T, SLARRB2
+* 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.
+*
+* NOTE:
+* There are very few minor differences between SLARRB from LAPACK
+* and this current subroutine SLARRB2.
+* The most important reason for creating this nearly identical copy
+* is profiling: in the ScaLAPACK MRRR algorithm, eigenvalue computation
+* using SLARRB2 is used for refinement in the construction of
+* the representation tree, as opposed to the initial computation of the
+* eigenvalues for the root RRR which uses SLARRB. When profiling,
+* this allows an easy quantification of refinement work vs. computing
+* eigenvalues of the root.
+*
+* Arguments
+* =========
+*
+* N (input) INTEGER
+* The order of the matrix.
+*
+* D (input) REAL array, dimension (N)
+* The N diagonal elements of the diagonal matrix D.
+*
+* LLD (input) REAL array, dimension (N-1)
+* The (N-1) elements L(i)*L(i)*D(i).
+*
+* IFIRST (input) INTEGER
+* The index of the first eigenvalue to be computed.
+*
+* ILAST (input) INTEGER
+* The index of the last eigenvalue to be computed.
+*
+* RTOL1 (input) REAL
+* RTOL2 (input) REAL
+* Tolerance for the convergence of the bisection intervals.
+* An interval [LEFT,RIGHT] has converged if
+* RIGHT-LEFT.LT.MAX( RTOL1*GAP, RTOL2*MAX(|LEFT|,|RIGHT|) )
+* where GAP is the (estimated) distance to the nearest
+* eigenvalue.
+*
+* OFFSET (input) INTEGER
+* Offset for the arrays W, WGAP and WERR, i.e., the IFIRST-OFFSET
+* through ILAST-OFFSET elements of these arrays are to be used.
+*
+* W (input/output) REAL array, dimension (N)
+* On input, W( IFIRST-OFFSET ) through W( ILAST-OFFSET ) are
+* estimates of the eigenvalues of L D L^T indexed IFIRST through ILAST.
+* On output, these estimates are refined.
+*
+* WGAP (input/output) REAL array, dimension (N-1)
+* On input, the (estimated) gaps between consecutive
+* eigenvalues of L D L^T, i.e., WGAP(I-OFFSET) is the gap between
+* eigenvalues I and I+1. Note that if IFIRST.EQ.ILAST
+* then WGAP(IFIRST-OFFSET) must be set to ZERO.
+* On output, these gaps are refined.
+*
+* WERR (input/output) REAL array, dimension (N)
+* On input, WERR( IFIRST-OFFSET ) through WERR( ILAST-OFFSET ) are
+* the errors in the estimates of the corresponding elements in W.
+* On output, these errors are refined.
+*
+* WORK (workspace) REAL array, dimension (4*N)
+* Workspace.
+*
+* IWORK (workspace) INTEGER array, dimension (2*N)
+* Workspace.
+*
+* PIVMIN (input) REAL
+* The minimum pivot in the sturm sequence.
+*
+* LGPVMN (input) REAL
+* Logarithm of PIVMIN, precomputed.
+*
+* LGSPDM (input) REAL
+* Logarithm of the spectral diameter, precomputed.
+*
+* TWIST (input) INTEGER
+* The twist index for the twisted factorization that is used
+* for the negcount.
+* TWIST = N: Compute negcount from L D L^T - LAMBDA I = L+ D+ L+^T
+* TWIST = 1: Compute negcount from L D L^T - LAMBDA I = U- D- U-^T
+* TWIST = R: Compute negcount from L D L^T - LAMBDA I = N(r) D(r) N(r)
+*
+* INFO (output) INTEGER
+* Error flag.
+*
+* .. Parameters ..
+ REAL ZERO, TWO, HALF
+ PARAMETER ( ZERO = 0.0E0, TWO = 2.0E0,
+ $ HALF = 0.5E0 )
+ INTEGER MAXITR
+* ..
+* .. Local Scalars ..
+ INTEGER I, I1, II, INDLLD, IP, ITER, J, K, NEGCNT,
+ $ NEXT, NINT, OLNINT, PREV, R
+ REAL BACK, CVRGD, GAP, LEFT, LGAP, MID, MNWDTH,
+ $ RGAP, RIGHT, SAVGAP, TMP, WIDTH
+ LOGICAL PARANOID
+* ..
+* .. External Functions ..
+ LOGICAL SISNAN
+ REAL SLAMCH
+ INTEGER SLANEG2A
+ EXTERNAL SISNAN, SLAMCH,
+ $ SLANEG2A
+*
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX, MIN
+* ..
+* .. Executable Statements ..
+*
+ INFO = 0
+*
+* Turn on paranoid check for rounding errors
+* invalidating uncertainty intervals of eigenvalues
+*
+ PARANOID = .TRUE.
+*
+ MAXITR = INT( ( LGSPDM - LGPVMN ) / LOG( TWO ) ) + 2
+ MNWDTH = TWO * PIVMIN
+*
+ R = TWIST
+*
+ INDLLD = 2*N
+ DO 5 J = 1, N-1
+ I=2*J
+ WORK(INDLLD+I-1) = D(J)
+ WORK(INDLLD+I) = LLD(J)
+ 5 CONTINUE
+ WORK(INDLLD+2*N-1) = D(N)
+*
+ 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 )
+
+ IF((ABS(LEFT).LE.16*PIVMIN).OR.(ABS(RIGHT).LE.16*PIVMIN))
+ $ THEN
+ INFO = -1
+ RETURN
+ ENDIF
+
+ IF( PARANOID ) THEN
+* 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 = SLANEG2A( N, WORK(INDLLD+1), 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 = SLANEG2A( N, WORK(INDLLD+1),RIGHT, PIVMIN, R )
+
+ IF( NEGCNT.LT.I ) THEN
+ RIGHT = RIGHT + BACK
+ BACK = TWO*BACK
+ GO TO 50
+ END IF
+ ENDIF
+
+ 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 = SLANEG2A( N, WORK(INDLLD+1), 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
+*
+* save this gap to restore it after the loop
+ SAVGAP = WGAP( ILAST-OFFSET )
+*
+ LEFT = WORK( 2*IFIRST-1 )
+ DO 110 I = IFIRST, ILAST
+ K = 2*I
+ II = I - OFFSET
+* RIGHT is the right boundary of this current interval
+ RIGHT = WORK( K )
+* All intervals marked by '0' have been refined.
+ IF( IWORK( K-1 ).EQ.0 ) THEN
+ W( II ) = HALF*( LEFT+RIGHT )
+ WERR( II ) = RIGHT - W( II )
+ END IF
+* Left is the boundary of the next interval
+ LEFT = WORK( K +1 )
+ WGAP( II ) = MAX( ZERO, LEFT - RIGHT )
+ 110 CONTINUE
+* restore the last gap which was overwritten by garbage
+ WGAP( ILAST-OFFSET ) = SAVGAP
+
+ RETURN
+*
+* End of SLARRB2
+*
+ END
+*
+*
+*
+ FUNCTION SLANEG2( N, D, LLD, SIGMA, PIVMIN, R )
+*
+ IMPLICIT NONE
+*
+ INTEGER SLANEG2
+*
+* .. Scalar Arguments ..
+ INTEGER N, R
+ REAL PIVMIN, SIGMA
+* ..
+* .. Array Arguments ..
+ REAL D( * ), LLD( * )
+*
+ REAL ZERO
+ PARAMETER ( ZERO = 0.0E0 )
+
+ INTEGER BLKLEN
+ PARAMETER ( BLKLEN = 2048 )
+* ..
+* .. Local Scalars ..
+ INTEGER BJ, J, NEG1, NEG2, NEGCNT, TO
+ REAL DMINUS, DPLUS, GAMMA, P, S, T, TMP, XSAV
+ LOGICAL SAWNAN
+* ..
+* .. External Functions ..
+ LOGICAL SISNAN
+ EXTERNAL SISNAN
+
+ NEGCNT = 0
+*
+* I) upper part: L D L^T - SIGMA I = L+ D+ L+^T
+* run dstqds block-wise to avoid excessive work when NaNs occur
+*
+ S = ZERO
+ DO 210 BJ = 1, R-1, BLKLEN
+ NEG1 = 0
+ XSAV = S
+ TO = BJ+BLKLEN-1
+ IF ( TO.LE.R-1 ) THEN
+ DO 21 J = BJ, TO
+ T = S - SIGMA
+ DPLUS = D( J ) + T
+ IF( DPLUS.LT.ZERO ) NEG1=NEG1 + 1
+ S = T*LLD( J ) / DPLUS
+ 21 CONTINUE
+ ELSE
+ DO 22 J = BJ, R-1
+ T = S - SIGMA
+ DPLUS = D( J ) + T
+ IF( DPLUS.LT.ZERO ) NEG1=NEG1 + 1
+ S = T*LLD( J ) / DPLUS
+ 22 CONTINUE
+ ENDIF
+ SAWNAN = SISNAN( S )
+*
+ IF( SAWNAN ) THEN
+ NEG1 = 0
+ S = XSAV
+ TO = BJ+BLKLEN-1
+ IF ( TO.LE.R-1 ) THEN
+ DO 23 J = BJ, TO
+ T = S - SIGMA
+ DPLUS = D( J ) + T
+ IF(ABS(DPLUS).LT.PIVMIN)
+ $ DPLUS = -PIVMIN
+ TMP = LLD( J ) / DPLUS
+ IF( DPLUS.LT.ZERO )
+ $ NEG1 = NEG1 + 1
+ S = T*TMP
+ IF( TMP.EQ.ZERO ) S = LLD( J )
+ 23 CONTINUE
+ ELSE
+ DO 24 J = BJ, R-1
+ T = S - SIGMA
+ DPLUS = D( J ) + T
+ IF(ABS(DPLUS).LT.PIVMIN)
+ $ DPLUS = -PIVMIN
+ TMP = LLD( J ) / DPLUS
+ IF( DPLUS.LT.ZERO ) NEG1=NEG1+1
+ S = T*TMP
+ IF( TMP.EQ.ZERO ) S = LLD( J )
+ 24 CONTINUE
+ ENDIF
+ 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
+ XSAV = P
+ TO = BJ-BLKLEN+1
+ IF ( TO.GE.R ) THEN
+ DO 25 J = BJ, TO, -1
+ DMINUS = LLD( J ) + P
+ IF( DMINUS.LT.ZERO ) NEG2=NEG2+1
+ TMP = P / DMINUS
+ P = TMP * D( J ) - SIGMA
+ 25 CONTINUE
+ ELSE
+ DO 26 J = BJ, R, -1
+ DMINUS = LLD( J ) + P
+ IF( DMINUS.LT.ZERO ) NEG2=NEG2+1
+ TMP = P / DMINUS
+ P = TMP * D( J ) - SIGMA
+ 26 CONTINUE
+ ENDIF
+ SAWNAN = SISNAN( P )
+*
+ IF( SAWNAN ) THEN
+ NEG2 = 0
+ P = XSAV
+ TO = BJ-BLKLEN+1
+ IF ( TO.GE.R ) THEN
+ DO 27 J = BJ, TO, -1
+ DMINUS = LLD( J ) + P
+ IF(ABS(DMINUS).LT.PIVMIN)
+ $ DMINUS = -PIVMIN
+ TMP = D( J ) / DMINUS
+ IF( DMINUS.LT.ZERO )
+ $ NEG2 = NEG2 + 1
+ P = P*TMP - SIGMA
+ IF( TMP.EQ.ZERO )
+ $ P = D( J ) - SIGMA
+ 27 CONTINUE
+ ELSE
+ DO 28 J = BJ, R, -1
+ DMINUS = LLD( J ) + P
+ IF(ABS(DMINUS).LT.PIVMIN)
+ $ DMINUS = -PIVMIN
+ TMP = D( J ) / DMINUS
+ IF( DMINUS.LT.ZERO )
+ $ NEG2 = NEG2 + 1
+ P = P*TMP - SIGMA
+ IF( TMP.EQ.ZERO )
+ $ P = D( J ) - SIGMA
+ 28 CONTINUE
+ ENDIF
+ END IF
+ NEGCNT = NEGCNT + NEG2
+ 230 CONTINUE
+*
+* III) Twist index
+*
+ GAMMA = S + P
+ IF( GAMMA.LT.ZERO ) NEGCNT = NEGCNT+1
+
+ SLANEG2 = NEGCNT
+ END
+*
+*
+*
+ FUNCTION SLANEG2A( N, DLLD, SIGMA, PIVMIN, R )
+*
+ IMPLICIT NONE
+*
+ INTEGER SLANEG2A
+*
+* .. Scalar Arguments ..
+ INTEGER N, R
+ REAL PIVMIN, SIGMA
+* ..
+* .. Array Arguments ..
+ REAL DLLD( * )
+*
+ REAL ZERO
+ PARAMETER ( ZERO = 0.0E0 )
+
+ INTEGER BLKLEN
+ PARAMETER ( BLKLEN = 512 )
+*
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC INT
+* ..
+* .. Local Scalars ..
+ INTEGER BJ, I, J, NB, NEG1, NEG2, NEGCNT, NX
+ REAL DMINUS, DPLUS, GAMMA, P, S, T, TMP, XSAV
+ LOGICAL SAWNAN
+* ..
+* .. External Functions ..
+ LOGICAL SISNAN
+ EXTERNAL SISNAN
+
+ NEGCNT = 0
+*
+* I) upper part: L D L^T - SIGMA I = L+ D+ L+^T
+* run dstqds block-wise to avoid excessive work when NaNs occur,
+* first in chunks of size BLKLEN and then the remainder
+*
+ NB = INT((R-1)/BLKLEN)
+ NX = NB*BLKLEN
+ S = ZERO
+ DO 210 BJ = 1, NX, BLKLEN
+ NEG1 = 0
+ XSAV = S
+ DO 21 J = BJ, BJ+BLKLEN-1
+ I = 2*J
+ T = S - SIGMA
+ DPLUS = DLLD( I-1 ) + T
+ IF( DPLUS.LT.ZERO ) NEG1=NEG1 + 1
+ S = T*DLLD( I ) / DPLUS
+ 21 CONTINUE
+ SAWNAN = SISNAN( S )
+*
+ IF( SAWNAN ) THEN
+ NEG1 = 0
+ S = XSAV
+ DO 23 J = BJ, BJ+BLKLEN-1
+ I = 2*J
+ T = S - SIGMA
+ DPLUS = DLLD( I-1 ) + T
+ IF(ABS(DPLUS).LT.PIVMIN)
+ $ DPLUS = -PIVMIN
+ TMP = DLLD( I ) / DPLUS
+ IF( DPLUS.LT.ZERO )
+ $ NEG1 = NEG1 + 1
+ S = T*TMP
+ IF( TMP.EQ.ZERO ) S = DLLD( I )
+ 23 CONTINUE
+ END IF
+ NEGCNT = NEGCNT + NEG1
+ 210 CONTINUE
+*
+ NEG1 = 0
+ XSAV = S
+ DO 22 J = NX+1, R-1
+ I = 2*J
+ T = S - SIGMA
+ DPLUS = DLLD( I-1 ) + T
+ IF( DPLUS.LT.ZERO ) NEG1=NEG1 + 1
+ S = T*DLLD( I ) / DPLUS
+ 22 CONTINUE
+ SAWNAN = SISNAN( S )
+*
+ IF( SAWNAN ) THEN
+ NEG1 = 0
+ S = XSAV
+ DO 24 J = NX+1, R-1
+ I = 2*J
+ T = S - SIGMA
+ DPLUS = DLLD( I-1 ) + T
+ IF(ABS(DPLUS).LT.PIVMIN)
+ $ DPLUS = -PIVMIN
+ TMP = DLLD( I ) / DPLUS
+ IF( DPLUS.LT.ZERO ) NEG1=NEG1+1
+ S = T*TMP
+ IF( TMP.EQ.ZERO ) S = DLLD( I )
+ 24 CONTINUE
+ ENDIF
+ NEGCNT = NEGCNT + NEG1
+*
+* II) lower part: L D L^T - SIGMA I = U- D- U-^T
+*
+ NB = INT((N-R)/BLKLEN)
+ NX = N-NB*BLKLEN
+ P = DLLD( 2*N-1 ) - SIGMA
+ DO 230 BJ = N-1, NX, -BLKLEN
+ NEG2 = 0
+ XSAV = P
+ DO 25 J = BJ, BJ-BLKLEN+1, -1
+ I = 2*J
+ DMINUS = DLLD( I ) + P
+ IF( DMINUS.LT.ZERO ) NEG2=NEG2+1
+ TMP = P / DMINUS
+ P = TMP * DLLD( I-1 ) - SIGMA
+ 25 CONTINUE
+ SAWNAN = SISNAN( P )
+*
+ IF( SAWNAN ) THEN
+ NEG2 = 0
+ P = XSAV
+ DO 27 J = BJ, BJ-BLKLEN+1, -1
+ I = 2*J
+ DMINUS = DLLD( I ) + P
+ IF(ABS(DMINUS).LT.PIVMIN)
+ $ DMINUS = -PIVMIN
+ TMP = DLLD( I-1 ) / DMINUS
+ IF( DMINUS.LT.ZERO )
+ $ NEG2 = NEG2 + 1
+ P = P*TMP - SIGMA
+ IF( TMP.EQ.ZERO )
+ $ P = DLLD( I-1 ) - SIGMA
+ 27 CONTINUE
+ END IF
+ NEGCNT = NEGCNT + NEG2
+ 230 CONTINUE
+
+ NEG2 = 0
+ XSAV = P
+ DO 26 J = NX-1, R, -1
+ I = 2*J
+ DMINUS = DLLD( I ) + P
+ IF( DMINUS.LT.ZERO ) NEG2=NEG2+1
+ TMP = P / DMINUS
+ P = TMP * DLLD( I-1 ) - SIGMA
+ 26 CONTINUE
+ SAWNAN = SISNAN( P )
+*
+ IF( SAWNAN ) THEN
+ NEG2 = 0
+ P = XSAV
+ DO 28 J = NX-1, R, -1
+ I = 2*J
+ DMINUS = DLLD( I ) + P
+ IF(ABS(DMINUS).LT.PIVMIN)
+ $ DMINUS = -PIVMIN
+ TMP = DLLD( I-1 ) / DMINUS
+ IF( DMINUS.LT.ZERO )
+ $ NEG2 = NEG2 + 1
+ P = P*TMP - SIGMA
+ IF( TMP.EQ.ZERO )
+ $ P = DLLD( I-1 ) - SIGMA
+ 28 CONTINUE
+ END IF
+ NEGCNT = NEGCNT + NEG2
+*
+* III) Twist index
+*
+ GAMMA = S + P
+ IF( GAMMA.LT.ZERO ) NEGCNT = NEGCNT+1
+
+ SLANEG2A = NEGCNT
+ END
+
diff --git a/SRC/slarrd2.f b/SRC/slarrd2.f
new file mode 100644
index 0000000..6298a9c
--- /dev/null
+++ b/SRC/slarrd2.f
@@ -0,0 +1,678 @@
+ SUBROUTINE SLARRD2( RANGE, ORDER, N, VL, VU, IL, IU, GERS,
+ $ RELTOL, D, E, E2, PIVMIN, NSPLIT, ISPLIT,
+ $ M, W, WERR, WL, WU, IBLOCK, INDEXW,
+ $ WORK, IWORK, DOL, DOU, INFO )
+*
+* -- ScaLAPACK auxiliary routine (version 2.0) --
+* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver
+* July 4, 2010
+*
+* .. Scalar Arguments ..
+ CHARACTER ORDER, RANGE
+ INTEGER DOL, DOU, IL, INFO, IU, M, N, NSPLIT
+ REAL PIVMIN, RELTOL, VL, VU, WL, WU
+* ..
+* .. Array Arguments ..
+ INTEGER IBLOCK( * ), INDEXW( * ),
+ $ ISPLIT( * ), IWORK( * )
+ REAL D( * ), E( * ), E2( * ),
+ $ GERS( * ), W( * ), WERR( * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* SLARRD2 computes the eigenvalues of a symmetric tridiagonal
+* matrix T to limited initial accuracy. This is an auxiliary code to be
+* called from SLARRE2A.
+*
+* SLARRD2 has been created using the LAPACK code SLARRD
+* which itself stems from SSTEBZ. The motivation for creating
+* SLARRD2 is efficiency: When computing eigenvalues in parallel
+* and the input tridiagonal matrix splits into blocks, SLARRD2
+* can skip over blocks which contain none of the eigenvalues from
+* DOL to DOU for which the processor responsible. In extreme cases (such
+* as large matrices consisting of many blocks of small size, e.g. 2x2,
+* the gain can be substantial.
+*
+* Arguments
+* =========
+*
+* RANGE (input) CHARACTER
+* = 'A': ("All") all eigenvalues will be found.
+* = 'V': ("Value") all eigenvalues in the half-open interval
+* (VL, VU] will be found.
+* = 'I': ("Index") the IL-th through IU-th eigenvalues (of the
+* entire matrix) will be found.
+*
+* ORDER (input) CHARACTER
+* = 'B': ("By Block") the eigenvalues will be grouped by
+* split-off block (see IBLOCK, ISPLIT) and
+* ordered from smallest to largest within
+* the block.
+* = 'E': ("Entire matrix")
+* the eigenvalues for the entire matrix
+* will be ordered from smallest to
+* largest.
+*
+* N (input) INTEGER
+* The order of the tridiagonal matrix T. N >= 0.
+*
+* VL (input) REAL
+* VU (input) REAL
+* If RANGE='V', the lower and upper bounds of the interval to
+* be searched for eigenvalues. Eigenvalues less than or equal
+* to VL, or greater than VU, will not be returned. VL < VU.
+* Not referenced if RANGE = 'A' or 'I'.
+*
+* IL (input) INTEGER
+* IU (input) INTEGER
+* If RANGE='I', the indices (in ascending order) of the
+* smallest and largest eigenvalues to be returned.
+* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.
+* Not referenced if RANGE = 'A' or 'V'.
+*
+* GERS (input) REAL array, dimension (2*N)
+* The N Gerschgorin intervals (the i-th Gerschgorin interval
+* is (GERS(2*i-1), GERS(2*i)).
+*
+* RELTOL (input) REAL
+* The minimum relative width of an interval. When an interval
+* is narrower than RELTOL times the larger (in
+* magnitude) endpoint, then it is considered to be
+* sufficiently small, i.e., converged. Note: this should
+* always be at least radix*machine epsilon.
+*
+* D (input) REAL array, dimension (N)
+* The n diagonal elements of the tridiagonal matrix T.
+*
+* E (input) REAL array, dimension (N-1)
+* The (n-1) off-diagonal elements of the tridiagonal matrix T.
+*
+* E2 (input) REAL array, dimension (N-1)
+* The (n-1) squared off-diagonal elements of the tridiagonal matrix T.
+*
+* PIVMIN (input) REAL
+* The minimum pivot allowed in the sturm sequence for T.
+*
+* NSPLIT (input) INTEGER
+* The number of diagonal blocks in the matrix T.
+* 1 <= NSPLIT <= N.
+*
+* ISPLIT (input) INTEGER array, dimension (N)
+* The splitting points, at which T breaks up into submatrices.
+* The first submatrix consists of rows/columns 1 to ISPLIT(1),
+* the second of rows/columns ISPLIT(1)+1 through ISPLIT(2),
+* etc., and the NSPLIT-th consists of rows/columns
+* ISPLIT(NSPLIT-1)+1 through ISPLIT(NSPLIT)=N.
+* (Only the first NSPLIT elements will actually be used, but
+* since the user cannot know a priori what value NSPLIT will
+* have, N words must be reserved for ISPLIT.)
+*
+* M (output) INTEGER
+* The actual number of eigenvalues found. 0 <= M <= N.
+* (See also the description of INFO=2,3.)
+*
+* W (output) REAL array, dimension (N)
+* On exit, the first M elements of W will contain the
+* eigenvalue approximations. SLARRD2 computes an interval
+* I_j = (a_j, b_j] that includes eigenvalue j. The eigenvalue
+* approximation is given as the interval midpoint
+* W(j)= ( a_j + b_j)/2. The corresponding error is bounded by
+* WERR(j) = abs( a_j - b_j)/2
+*
+* WERR (output) REAL array, dimension (N)
+* The error bound on the corresponding eigenvalue approximation
+* in W.
+*
+* WL (output) REAL
+* WU (output) REAL
+* The interval (WL, WU] contains all the wanted eigenvalues.
+* If RANGE='V', then WL=VL and WU=VU.
+* If RANGE='A', then WL and WU are the global Gerschgorin bounds
+* on the spectrum.
+* If RANGE='I', then WL and WU are computed by SLAEBZ from the
+* index range specified.
+*
+* IBLOCK (output) INTEGER array, dimension (N)
+* At each row/column j where E(j) is zero or small, the
+* matrix T is considered to split into a block diagonal
+* matrix. On exit, if INFO = 0, IBLOCK(i) specifies to which
+* block (from 1 to the number of blocks) the eigenvalue W(i)
+* belongs. (SLARRD2 may use the remaining N-M elements as
+* workspace.)
+*
+* INDEXW (output) INTEGER array, dimension (N)
+* The indices of the eigenvalues within each block (submatrix);
+* for example, INDEXW(i)= j and IBLOCK(i)=k imply that the
+* i-th eigenvalue W(i) is the j-th eigenvalue in block k.
+*
+* WORK (workspace) REAL array, dimension (4*N)
+*
+* IWORK (workspace) INTEGER array, dimension (3*N)
+*
+* DOL (input) INTEGER
+* DOU (input) INTEGER
+* If the user wants to work on only a selected part of the
+* representation tree, he can specify an index range DOL:DOU.
+* Otherwise, the setting DOL=1, DOU=N should be applied.
+* Note that DOL and DOU refer to the order in which the eigenvalues
+* are stored in W.
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+* > 0: some or all of the eigenvalues failed to converge or
+* were not computed:
+* =1 or 3: Bisection failed to converge for some
+* eigenvalues; these eigenvalues are flagged by a
+* negative block number. The effect is that the
+* eigenvalues may not be as accurate as the
+* absolute and relative tolerances. This is
+* generally caused by unexpectedly inaccurate
+* arithmetic.
+* =2 or 3: RANGE='I' only: Not all of the eigenvalues
+* IL:IU were found.
+* Effect: M < IU+1-IL
+* Cause: non-monotonic arithmetic, causing the
+* Sturm sequence to be non-monotonic.
+* Cure: recalculate, using RANGE='A', and pick
+* out eigenvalues IL:IU. In some cases,
+* increasing the PARAMETER "FUDGE" may
+* make things work.
+* = 4: RANGE='I', and the Gershgorin interval
+* initially used was too small. No eigenvalues
+* were computed.
+* Probable cause: your machine has sloppy
+* floating-point arithmetic.
+* Cure: Increase the PARAMETER "FUDGE",
+* recompile, and try again.
+*
+* Internal Parameters
+* ===================
+*
+* FUDGE REAL , default = 2 originally, increased to 10.
+* A "fudge factor" to widen the Gershgorin intervals. Ideally,
+* a value of 1 should work, but on machines with sloppy
+* arithmetic, this needs to be larger. The default for
+* publicly released versions should be large enough to handle
+* the worst machine around. Note that this has no effect
+* on accuracy of the solution.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ZERO, ONE, TWO, HALF, FUDGE
+ PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0,
+ $ TWO = 2.0E0, HALF = ONE/TWO,
+ $ FUDGE = 10.0E0 )
+
+* ..
+* .. Local Scalars ..
+ LOGICAL NCNVRG, TOOFEW
+ INTEGER I, IB, IBEGIN, IDISCL, IDISCU, IE, IEND, IINFO,
+ $ IM, IN, IOFF, IORDER, IOUT, IRANGE, ITMAX,
+ $ ITMP1, ITMP2, IW, IWOFF, J, JBLK, JDISC, JE,
+ $ JEE, NB, NWL, NWU
+ REAL ATOLI, EPS, GL, GU, RTOLI, SPDIAM, TMP1, TMP2,
+ $ TNORM, UFLOW, WKILL, WLU, WUL
+
+* ..
+* .. Local Arrays ..
+ INTEGER IDUMMA( 1 )
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ INTEGER ILAENV
+ REAL SLAMCH
+ EXTERNAL LSAME, ILAENV, SLAMCH
+* ..
+* .. External Subroutines ..
+ EXTERNAL SLAEBZ
+* ..
+* .. 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
+ 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.3 .AND. IL.EQ.1 .AND. IU.EQ.N ) IRANGE = 1
+
+* Get machine constants
+ EPS = SLAMCH( 'P' )
+ UFLOW = SLAMCH( 'U' )
+
+
+* Special Case when N=1
+* Treat case of 1x1 matrix for quick return
+ IF( N.EQ.1 ) THEN
+ IF( (IRANGE.EQ.1).OR.
+ $ ((IRANGE.EQ.2).AND.(D(1).GT.VL).AND.(D(1).LE.VU)).OR.
+ $ ((IRANGE.EQ.3).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, 'SSTEBZ', ' ', 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
+ SPDIAM = GU - GL
+* Input arguments for SLAEBZ:
+* The relative tolerance. An interval (a,b] lies within
+* "relative tolerance" if b-a < RELTOL*max(|a|,|b|),
+ RTOLI = RELTOL
+ ATOLI = FUDGE*TWO*UFLOW + FUDGE*TWO*PIVMIN
+
+ IF( IRANGE.EQ.3 ) 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 SLAEBZ.
+ 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 SLAEBZ( 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.2 ) THEN
+ WL = VL
+ WU = VU
+
+ ELSEIF( IRANGE.EQ.1 ) 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( IRANGE.EQ.1 ) THEN
+ IF( (IEND.LT.DOL).OR.(IBEGIN.GT.DOU) ) THEN
+* the local block contains none of eigenvalues that matter
+* to this processor
+ NWU = NWU + IN
+ DO 30 J = 1, IN
+ M = M + 1
+ IBLOCK( M ) = JBLK
+ 30 CONTINUE
+ GO TO 70
+ END IF
+ END IF
+
+ 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.1 .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
+ ELSE
+* General Case - block of size IN > 2
+* Compute local Gerschgorin interval and use it as the initial
+* interval for SLAEBZ
+ GU = D( IBEGIN )
+ GL = D( IBEGIN )
+ TMP1 = ZERO
+
+ DO 40 J = IBEGIN, IEND
+ GL = MIN( GL, GERS( 2*J - 1))
+ GU = MAX( GU, GERS(2*J) )
+ 40 CONTINUE
+ SPDIAM = GU - GL
+ 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 SLAEBZ( 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 SLAEBZ( 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 SLAEBZ
+ 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.3 ) 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.1 .AND. M.NE.N ).OR.
+ $ ( IRANGE.EQ.3 .AND. M.NE.IU-IL+1 ) ) THEN
+ TOOFEW = .TRUE.
+ END IF
+
+* If ORDER='B',(IBLOCK = 2), do nothing the eigenvalues are already sorted
+* by block.
+* If ORDER='E',(IBLOCK = 1), 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
+ 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 SLARRD2
+*
+ END
diff --git a/SRC/slarre2.f b/SRC/slarre2.f
new file mode 100644
index 0000000..7dc37e1
--- /dev/null
+++ b/SRC/slarre2.f
@@ -0,0 +1,764 @@
+ SUBROUTINE SLARRE2( RANGE, N, VL, VU, IL, IU, D, E, E2,
+ $ RTOL1, RTOL2, SPLTOL, NSPLIT, ISPLIT,
+ $ M, DOL, DOU,
+ $ W, WERR, WGAP, IBLOCK, INDEXW, GERS, PIVMIN,
+ $ WORK, IWORK, INFO )
+*
+* -- ScaLAPACK auxiliary routine (version 2.0) --
+* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver
+* July 4, 2010
+*
+* .. Scalar Arguments ..
+ CHARACTER RANGE
+ INTEGER DOL, DOU, IL, INFO, IU, M, N, NSPLIT
+ REAL PIVMIN, RTOL1, RTOL2, SPLTOL, VL, VU
+* ..
+* .. Array Arguments ..
+ INTEGER IBLOCK( * ), ISPLIT( * ), IWORK( * ),
+ $ INDEXW( * )
+ REAL D( * ), E( * ), E2( * ), GERS( * ),
+ $ W( * ),WERR( * ), WGAP( * ), WORK( * )
+*
+* Purpose
+* =======
+*
+* To find the desired eigenvalues of a given real symmetric
+* tridiagonal matrix T, SLARRE2 sets, via SLARRA,
+* "small" off-diagonal elements to zero. For each block T_i, it finds
+* (a) a suitable shift at one end of the block's spectrum,
+* (b) the root RRR, 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 returned to
+* SSTEGR2 to compute the eigenvectors T.
+*
+* SLARRE2 is more suitable for parallel computation than the
+* original LAPACK code for computing the root RRR and its eigenvalues.
+* When computing eigenvalues in parallel and the input tridiagonal
+* matrix splits into blocks, SLARRE2
+* can skip over blocks which contain none of the eigenvalues from
+* DOL to DOU for which the processor responsible. In extreme cases (such
+* as large matrices consisting of many blocks of small size, e.g. 2x2,
+* the gain can be substantial.
+*
+* Arguments
+* =========
+*
+* RANGE (input) CHARACTER
+* = 'A': ("All") all eigenvalues will be found.
+* = 'V': ("Value") all eigenvalues in the half-open interval
+* (VL, VU] will be found.
+* = 'I': ("Index") the IL-th through IU-th eigenvalues (of the
+* entire matrix) will be found.
+*
+* N (input) INTEGER
+* The order of the matrix. N > 0.
+*
+* VL (input/output) REAL
+* VU (input/output) REAL
+* If RANGE='V', the lower and upper bounds for the eigenvalues.
+* Eigenvalues less than or equal to VL, or greater than VU,
+* will not be returned. VL < VU.
+* If RANGE='I' or ='A', SLARRE2 computes bounds on the desired
+* part of the spectrum.
+*
+* IL (input) INTEGER
+* IU (input) INTEGER
+* If RANGE='I', the indices (in ascending order) of the
+* smallest and largest eigenvalues to be returned.
+* 1 <= IL <= IU <= N.
+*
+* D (input/output) REAL array, dimension (N)
+* On entry, the N diagonal elements of the tridiagonal
+* matrix T.
+* On exit, the N diagonal elements of the diagonal
+* matrices D_i.
+*
+* E (input/output) REAL array, dimension (N)
+* On entry, the first (N-1) entries contain the subdiagonal
+* elements of the tridiagonal matrix T; E(N) need not be set.
+* On exit, E contains the subdiagonal elements of the unit
+* bidiagonal matrices L_i. The entries E( ISPLIT( I ) ),
+* 1 <= I <= NSPLIT, contain the base points sigma_i on output.
+*
+* E2 (input/output) REAL array, dimension (N)
+* On entry, the first (N-1) entries contain the SQUARES of the
+* subdiagonal elements of the tridiagonal matrix T;
+* E2(N) need not be set.
+* On exit, the entries E2( ISPLIT( I ) ),
+* 1 <= I <= NSPLIT, have been set to zero
+*
+* RTOL1 (input) REAL
+* RTOL2 (input) REAL
+* Parameters for bisection.
+* An interval [LEFT,RIGHT] has converged if
+* RIGHT-LEFT.LT.MAX( RTOL1*GAP, RTOL2*MAX(|LEFT|,|RIGHT|) )
+*
+* SPLTOL (input) REAL
+* The threshold for splitting.
+*
+* NSPLIT (output) INTEGER
+* The number of blocks T splits into. 1 <= NSPLIT <= N.
+*
+* ISPLIT (output) INTEGER array, dimension (N)
+* The splitting points, at which T breaks up into blocks.
+* The first block consists of rows/columns 1 to ISPLIT(1),
+* the second of rows/columns ISPLIT(1)+1 through ISPLIT(2),
+* etc., and the NSPLIT-th consists of rows/columns
+* ISPLIT(NSPLIT-1)+1 through ISPLIT(NSPLIT)=N.
+*
+* M (output) INTEGER
+* The total number of eigenvalues (of all L_i D_i L_i^T)
+* found.
+*
+* DOL (input) INTEGER
+* DOU (input) INTEGER
+* If the user wants to work on only a selected part of the
+* representation tree, he can specify an index range DOL:DOU.
+* Otherwise, the setting DOL=1, DOU=N should be applied.
+* Note that DOL and DOU refer to the order in which the eigenvalues
+* are stored in W.
+*
+* W (output) REAL array, dimension (N)
+* The first M elements contain the eigenvalues. The
+* eigenvalues of each of the blocks, L_i D_i L_i^T, are
+* sorted in ascending order ( SLARRE2 may use the
+* remaining N-M elements as workspace).
+* Note that immediately after exiting this routine, only
+* the eigenvalues from position DOL:DOU in W might be
+* reliable on this processor
+* when the eigenvalue computation is done in parallel.
+*
+* WERR (output) REAL array, dimension (N)
+* The error bound on the corresponding eigenvalue in W.
+* Note that immediately after exiting this routine, only
+* the uncertainties from position DOL:DOU in WERR might be
+* reliable on this processor
+* when the eigenvalue computation is done in parallel.
+*
+* WGAP (output) REAL array, dimension (N)
+* The separation from the right neighbor eigenvalue in W.
+* The gap is only with respect to the eigenvalues of the same block
+* as each block has its own representation tree.
+* Exception: at the right end of a block we store the left gap
+* Note that immediately after exiting this routine, only
+* the gaps from position DOL:DOU in WGAP might be
+* reliable on this processor
+* when the eigenvalue computation is done in parallel.
+*
+* IBLOCK (output) INTEGER array, dimension (N)
+* The indices of the blocks (submatrices) associated with the
+* corresponding eigenvalues in W; IBLOCK(i)=1 if eigenvalue
+* W(i) belongs to the first block from the top, =2 if W(i)
+* belongs to the second block, etc.
+*
+* INDEXW (output) INTEGER array, dimension (N)
+* The indices of the eigenvalues within each block (submatrix);
+* for example, INDEXW(i)= 10 and IBLOCK(i)=2 imply that the
+* i-th eigenvalue W(i) is the 10-th eigenvalue in block 2
+*
+* GERS (output) REAL array, dimension (2*N)
+* The N Gerschgorin intervals (the i-th Gerschgorin interval
+* is (GERS(2*i-1), GERS(2*i)).
+*
+* PIVMIN (output) DOUBLE PRECISION
+* The minimum pivot in the sturm sequence for T.
+*
+* WORK (workspace) REAL array, dimension (6*N)
+* Workspace.
+*
+* IWORK (workspace) INTEGER array, dimension (5*N)
+* Workspace.
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* > 0: A problem occured in SLARRE2.
+* < 0: One of the called subroutines signaled an internal problem.
+* Needs inspection of the corresponding parameter IINFO
+* for further information.
+*
+* =-1: Problem in SLARRD.
+* = 2: No base representation could be found in MAXTRY iterations.
+* Increasing MAXTRY and recompilation might be a remedy.
+* =-3: Problem in SLARRB when computing the refined root
+* representation for SLASQ2.
+* =-4: Problem in SLARRB when preforming bisection on the
+* desired part of the spectrum.
+* =-5: Problem in SLASQ2.
+* =-6: Problem in SLASQ2.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL FAC, FOUR, FOURTH, FUDGE, HALF, HNDRD,
+ $ MAXGROWTH, ONE, PERT, TWO, ZERO
+ PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0,
+ $ TWO = 2.0E0, FOUR=4.0E0,
+ $ HNDRD = 100.0E0,
+ $ PERT = 4.0E0,
+ $ HALF = ONE/TWO, FOURTH = ONE/FOUR, FAC= HALF,
+ $ MAXGROWTH = 64.0E0, FUDGE = 2.0E0 )
+ INTEGER MAXTRY
+ PARAMETER ( MAXTRY = 6 )
+* ..
+* .. Local Scalars ..
+ LOGICAL FORCEB, NOREP, RNDPRT, USEDQD
+ INTEGER CNT, CNT1, CNT2, I, IBEGIN, IDUM, IEND, IINFO,
+ $ IN, INDL, INDU, IRANGE, J, JBLK, MB, MM,
+ $ WBEGIN, WEND
+ REAL 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
+ REAL SLAMCH
+ EXTERNAL SLAMCH, LSAME
+
+* ..
+* .. External Subroutines ..
+ EXTERNAL SCOPY, SLARNV, SLARRA, SLARRB, SLARRC,
+ $ SLARRD, SLASQ2
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX, MIN
+
+* ..
+* .. Executable Statements ..
+*
+
+ INFO = 0
+
+* Dis-/Enable a small random perturbation of the root representation
+ RNDPRT = .TRUE.
+*
+* 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
+ END IF
+
+ M = 0
+
+* Get machine constants
+ SAFMIN = SLAMCH( 'S' )
+ EPS = SLAMCH( 'P' )
+
+* Set parameters
+ RTL = HNDRD*EPS
+ BSRTOL = 1.0E-1
+
+* Treat case of 1x1 matrix for quick return
+ IF( N.EQ.1 ) THEN
+ IF( (IRANGE.EQ.1).OR.
+ $ ((IRANGE.EQ.2).AND.(D(1).GT.VL).AND.(D(1).LE.VU)).OR.
+ $ ((IRANGE.EQ.3).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 SLARRA( N, D, E, E2, SPLTOL, SPDIAM,
+ $ NSPLIT, ISPLIT, IINFO )
+
+* Can force use of bisection instead of faster DQDS
+ FORCEB = .FALSE.
+
+ IF( (IRANGE.EQ.1) .AND. (.NOT. FORCEB) ) THEN
+* Set interval [VL,VU] that contains all eigenvalues
+ VL = GL
+ VU = GU
+ ELSE
+* We call SLARRD to find crude approximations to the eigenvalues
+* in the desired range. In case IRANGE = 3, we also obtain the
+* interval (VL,VU] that contains all the wanted eigenvalues.
+* An interval [LEFT,RIGHT] has converged if
+* RIGHT-LEFT.LT.RTOL*MAX(ABS(LEFT),ABS(RIGHT))
+* SLARRD needs a WORK of size 4*N, IWORK of size 3*N
+ CALL SLARRD( 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.1).OR.( (IRANGE.EQ.2).AND.
+ $ ( D( IBEGIN ).GT.VL ).AND.( D( IBEGIN ).LE.VU ) )
+ $ .OR. ( (IRANGE.EQ.3).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.1).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
+ ELSE
+* MB = number of eigenvalues to compute
+ MB = IN
+ WEND = WBEGIN + MB - 1
+ INDL = 1
+ INDU = IN
+ ENDIF
+
+ IF( (WEND.LT.DOL).OR.(WBEGIN.GT.DOU) ) THEN
+* if this subblock contains no desired eigenvalues,
+* skip the computation of this representation tree
+ IBEGIN = IEND + 1
+ WBEGIN = WEND + 1
+ M = M + INDU - INDL + 1
+ GO TO 170
+ END IF
+
+* Find approximations to the extremal eigenvalues of the block
+ CALL SLARRK( 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 SLARRK( 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))
+ IF(( (IRANGE.EQ.1) .AND. (.NOT. FORCEB) ).OR.USEDQD) THEN
+* Case of DQDS
+* 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 SLARRE2 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.1 ) .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
+* SLARRD 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 SLARRC( '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.1 ) .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.1 ) .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
+ TAU = SPDIAM*EPS*N + TWO*PIVMIN
+ TAU = MAX(TAU,EPS*ABS(SIGMA))
+ ELSE
+ IF(MB.GT.1) THEN
+ CLWDTH = W(WEND) + WERR(WEND) - W(WBEGIN) - WERR(WBEGIN)
+ AVGAP = ABS(CLWDTH / REAL(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(NOREP) THEN
+* Note that in the case of IRANGE=1, we use the Gerschgorin
+* shift which makes the matrix definite. So we should end up
+* here really only in the case of IRANGE = 2,3
+ 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 SCOPY( IN, WORK, 1, D( IBEGIN ), 1 )
+ CALL SCOPY( IN-1, WORK( IN+1 ), 1, E( IBEGIN ), 1 )
+
+
+ IF(RNDPRT .AND. 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 SLARNV(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 SLARRV.
+* We update W instead and use it to locate the proper Gerschgorin
+* intervals.
+
+* Compute the required eigenvalues of L D L' by bisection or dqds
+ IF ( .NOT.USEDQD ) THEN
+* If SLARRD has been used, shift the eigenvalue approximations
+* according to their representation. This is necessary for
+* a uniform SLARRV since dqds computes eigenvalues of the
+* shifted representation. In SLARRV, W will always hold the
+* UNshifted eigenvalue approximation.
+ DO 134 J=WBEGIN,WEND
+ W(J) = W(J) - SIGMA
+ WERR(J) = WERR(J) + ABS(W(J)) * EPS
+ 134 CONTINUE
+* call SLARRB to reduce eigenvalue error of the approximations
+* from SLARRD
+ 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 SLARRB(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
+* SLARRB 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 SLASQ2
+* This is an ESTIMATED error, the worst case bound is 4*N*EPS
+* which is usually too large and requires unnecessary work to be
+* done by bisection when computing the eigenvectors
+ RTOL = LOG(REAL(IN)) * 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 SLASQ2( 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 SLASQ2
+ 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 SLARRE2
+*
+ END
diff --git a/SRC/slarre2a.f b/SRC/slarre2a.f
new file mode 100644
index 0000000..10c6d79
--- /dev/null
+++ b/SRC/slarre2a.f
@@ -0,0 +1,774 @@
+ SUBROUTINE SLARRE2A( RANGE, N, VL, VU, IL, IU, D, E, E2,
+ $ RTOL1, RTOL2, SPLTOL, NSPLIT, ISPLIT,
+ $ M, DOL, DOU, NEEDIL, NEEDIU,
+ $ W, WERR, WGAP, IBLOCK, INDEXW, GERS,
+ $ SDIAM, PIVMIN, WORK, IWORK, MINRGP, INFO )
+*
+* -- ScaLAPACK auxiliary routine (version 2.0) --
+* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver
+* July 4, 2010
+*
+ IMPLICIT NONE
+*
+* .. Scalar Arguments ..
+ CHARACTER RANGE
+ INTEGER DOL, DOU, IL, INFO, IU, M, N, NSPLIT,
+ $ NEEDIL, NEEDIU
+ REAL MINRGP, PIVMIN, RTOL1, RTOL2, SPLTOL, VL, VU
+* ..
+* .. Array Arguments ..
+ INTEGER IBLOCK( * ), ISPLIT( * ), IWORK( * ),
+ $ INDEXW( * )
+ REAL D( * ), E( * ), E2( * ), GERS( * ),
+ $ SDIAM( * ), W( * ),WERR( * ),
+ $ WGAP( * ), WORK( * )
+*
+* Purpose
+* =======
+*
+* To find the desired eigenvalues of a given real symmetric
+* tridiagonal matrix T, SLARRE2 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.
+*
+* NOTE:
+* The algorithm obtains a crude picture of all the wanted eigenvalues
+* (as selected by RANGE). However, to reduce work and improve scalability,
+* only the eigenvalues DOL to DOU are refined. Furthermore, if the matrix
+* splits into blocks, RRRs for blocks that do not contain eigenvalues
+* from DOL to DOU are skipped.
+* The DQDS algorithm (subroutine SLASQ2) is not used, unlike in
+* the sequential case. Instead, eigenvalues are computed in parallel to some
+* figures using bisection.
+
+*
+* Arguments
+* =========
+*
+* RANGE (input) CHARACTER
+* = 'A': ("All") all eigenvalues will be found.
+* = 'V': ("Value") all eigenvalues in the half-open interval
+* (VL, VU] will be found.
+* = 'I': ("Index") the IL-th through IU-th eigenvalues (of the
+* entire matrix) will be found.
+*
+* N (input) INTEGER
+* The order of the matrix. N > 0.
+*
+* VL (input/output) REAL
+* VU (input/output) REAL
+* If RANGE='V', the lower and upper bounds for the eigenvalues.
+* Eigenvalues less than or equal to VL, or greater than VU,
+* will not be returned. VL < VU.
+* If RANGE='I' or ='A', SLARRE2A computes bounds on the desired
+* part of the spectrum.
+*
+* IL (input) INTEGER
+* IU (input) INTEGER
+* If RANGE='I', the indices (in ascending order) of the
+* smallest and largest eigenvalues to be returned.
+* 1 <= IL <= IU <= N.
+*
+* D (input/output) REAL array, dimension (N)
+* On entry, the N diagonal elements of the tridiagonal
+* matrix T.
+* On exit, the N diagonal elements of the diagonal
+* matrices D_i.
+*
+* E (input/output) REAL array, dimension (N)
+* On entry, the first (N-1) entries contain the subdiagonal
+* elements of the tridiagonal matrix T; E(N) need not be set.
+* On exit, E contains the subdiagonal elements of the unit
+* bidiagonal matrices L_i. The entries E( ISPLIT( I ) ),
+* 1 <= I <= NSPLIT, contain the base points sigma_i on output.
+*
+* E2 (input/output) REAL array, dimension (N)
+* On entry, the first (N-1) entries contain the SQUARES of the
+* subdiagonal elements of the tridiagonal matrix T;
+* E2(N) need not be set.
+* On exit, the entries E2( ISPLIT( I ) ),
+* 1 <= I <= NSPLIT, have been set to zero
+*
+* RTOL1 (input) REAL
+* RTOL2 (input) REAL
+* Parameters for bisection.
+* An interval [LEFT,RIGHT] has converged if
+* RIGHT-LEFT.LT.MAX( RTOL1*GAP, RTOL2*MAX(|LEFT|,|RIGHT|) )
+*
+* SPLTOL (input) REAL
+* The threshold for splitting.
+*
+* NSPLIT (output) INTEGER
+* The number of blocks T splits into. 1 <= NSPLIT <= N.
+*
+* ISPLIT (output) INTEGER array, dimension (N)
+* The splitting points, at which T breaks up into blocks.
+* The first block consists of rows/columns 1 to ISPLIT(1),
+* the second of rows/columns ISPLIT(1)+1 through ISPLIT(2),
+* etc., and the NSPLIT-th consists of rows/columns
+* ISPLIT(NSPLIT-1)+1 through ISPLIT(NSPLIT)=N.
+*
+* M (output) INTEGER
+* The total number of eigenvalues (of all L_i D_i L_i^T)
+* found.
+*
+* DOL (input) INTEGER
+* DOU (input) INTEGER
+* If the user wants to work on only a selected part of the
+* representation tree, he can specify an index range DOL:DOU.
+* Otherwise, the setting DOL=1, DOU=N should be applied.
+* Note that DOL and DOU refer to the order in which the eigenvalues
+* are stored in W.
+*
+* NEEDIL (output) INTEGER
+* NEEDIU (output) INTEGER
+* The indices of the leftmost and rightmost eigenvalues
+* of the root node RRR which are
+* needed to accurately compute the relevant part of the
+* representation tree.
+*
+* W (output) REAL array, dimension (N)
+* The first M elements contain the eigenvalues. The
+* eigenvalues of each of the blocks, L_i D_i L_i^T, are
+* sorted in ascending order ( SLARRE2A may use the
+* remaining N-M elements as workspace).
+* Note that immediately after exiting this routine, only
+* the eigenvalues from position DOL:DOU in W are
+* reliable on this processor
+* because the eigenvalue computation is done in parallel.
+*
+* WERR (output) REAL array, dimension (N)
+* The error bound on the corresponding eigenvalue in W.
+* Note that immediately after exiting this routine, only
+* the uncertainties from position DOL:DOU in WERR are
+* reliable on this processor
+* because the eigenvalue computation is done in parallel.
+*
+* WGAP (output) REAL array, dimension (N)
+* The separation from the right neighbor eigenvalue in W.
+* The gap is only with respect to the eigenvalues of the same block
+* as each block has its own representation tree.
+* Exception: at the right end of a block we store the left gap
+* Note that immediately after exiting this routine, only
+* the gaps from position DOL:DOU in WGAP are
+* reliable on this processor
+* because the eigenvalue computation is done in parallel.
+*
+* IBLOCK (output) INTEGER array, dimension (N)
+* The indices of the blocks (submatrices) associated with the
+* corresponding eigenvalues in W; IBLOCK(i)=1 if eigenvalue
+* W(i) belongs to the first block from the top, =2 if W(i)
+* belongs to the second block, etc.
+*
+* INDEXW (output) INTEGER array, dimension (N)
+* The indices of the eigenvalues within each block (submatrix);
+* for example, INDEXW(i)= 10 and IBLOCK(i)=2 imply that the
+* i-th eigenvalue W(i) is the 10-th eigenvalue in block 2
+*
+* GERS (output) REAL array, dimension (2*N)
+* The N Gerschgorin intervals (the i-th Gerschgorin interval
+* is (GERS(2*i-1), GERS(2*i)).
+*
+* PIVMIN (output) DOUBLE PRECISION
+* The minimum pivot in the sturm sequence for T.
+*
+* WORK (workspace) REAL array, dimension (6*N)
+* Workspace.
+*
+* IWORK (workspace) INTEGER array, dimension (5*N)
+* Workspace.
+*
+* MINRGP (input) REAL
+* The minimum relativ gap threshold to decide whether an eigenvalue
+* or a cluster boundary is reached.
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* > 0: A problem occured in SLARRE2A.
+* < 0: One of the called subroutines signaled an internal problem.
+* Needs inspection of the corresponding parameter IINFO
+* for further information.
+*
+* =-1: Problem in SLARRD2.
+* = 2: No base representation could be found in MAXTRY iterations.
+* Increasing MAXTRY and recompilation might be a remedy.
+* =-3: Problem in SLARRB2 when computing the refined root
+* representation
+* =-4: Problem in SLARRB2 when preforming bisection on the
+* desired part of the spectrum.
+* = -9 Problem: M < DOU-DOL+1, that is the code found fewer
+* eigenvalues than it was supposed to
+*
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL FAC, FOUR, FOURTH, FUDGE, HALF, HNDRD,
+ $ MAXGROWTH, ONE, PERT, TWO, ZERO
+ PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0,
+ $ TWO = 2.0E0, FOUR=4.0E0,
+ $ HNDRD = 100.0E0,
+ $ PERT = 4.0E0,
+ $ HALF = ONE/TWO, FOURTH = ONE/FOUR, FAC= HALF,
+ $ MAXGROWTH = 64.0E0, FUDGE = 2.0E0 )
+ INTEGER MAXTRY
+ PARAMETER ( MAXTRY = 6 )
+* ..
+* .. Local Scalars ..
+ LOGICAL NOREP, RNDPRT, USEDQD
+ INTEGER CNT, CNT1, CNT2, I, IBEGIN, IDUM, IEND, IINFO,
+ $ IN, INDL, INDU, IRANGE, J, JBLK, MB, MM,
+ $ MYINDL, MYINDU, MYWBEG, MYWEND, WBEGIN, WEND
+ REAL AVGAP, BSRTOL, CLWDTH, DMAX, DPIVOT, EABS,
+ $ EMAX, EOLD, EPS, GL, GU, ISLEFT, ISRGHT,
+ $ LGPVMN, LGSPDM, RTL, S1, S2, SAFMIN, SGNDEF,
+ $ SIGMA, SPDIAM, TAU, TMP, TMP1, TMP2
+
+
+* ..
+* .. Local Arrays ..
+ INTEGER ISEED( 4 )
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ REAL SLAMCH
+ EXTERNAL SLAMCH, LSAME
+
+* ..
+* .. External Subroutines ..
+ EXTERNAL SCOPY, SLARNV, SLARRA, SLARRB2,
+ $ SLARRC, SLARRD2
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX, MIN
+
+* ..
+* .. Executable Statements ..
+*
+
+ INFO = 0
+
+* Dis-/Enable a small random perturbation of the root representation
+ RNDPRT = .TRUE.
+*
+* 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
+ END IF
+
+ M = 0
+
+* Get machine constants
+ SAFMIN = SLAMCH( 'S' )
+ EPS = SLAMCH( 'P' )
+
+* Set parameters
+ RTL = HNDRD*EPS
+ BSRTOL = 1.0E-1
+
+* Treat case of 1x1 matrix for quick return
+ IF( N.EQ.1 ) THEN
+ IF( (IRANGE.EQ.1).OR.
+ $ ((IRANGE.EQ.2).AND.(D(1).GT.VL).AND.(D(1).LE.VU)).OR.
+ $ ((IRANGE.EQ.3).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.
+ DO 1 I =1,N
+ WERR(I) = ZERO
+ 1 CONTINUE
+ DO 2 I =1,N
+ WGAP(I) = ZERO
+ 2 CONTINUE
+
+* 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
+ EABS = ABS( E(I) )
+ IF( EABS .GE. EMAX ) THEN
+ EMAX = EABS
+ END IF
+ TMP = EABS + EOLD
+ EOLD = EABS
+ TMP1 = D(I) - TMP
+ TMP2 = D(I) + TMP
+ GL = MIN( GL, TMP1 )
+ GU = MAX( GU, TMP2 )
+ GERS( 2*I-1) = TMP1
+ GERS( 2*I ) = TMP2
+ 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 SLARRA( N, D, E, E2, SPLTOL, SPDIAM,
+ $ NSPLIT, ISPLIT, IINFO )
+
+ IF( IRANGE.EQ.1 ) THEN
+* Set interval [VL,VU] that contains all eigenvalues
+ VL = GL
+ VU = GU
+ ENDIF
+
+* We call SLARRD2 to find crude approximations to the eigenvalues
+* in the desired range. In case IRANGE = 3, 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))
+* SLARRD2 needs a WORK of size 4*N, IWORK of size 3*N
+ CALL SLARRD2( RANGE, 'B', N, VL, VU, IL, IU, GERS,
+ $ BSRTOL, D, E, E2, PIVMIN, NSPLIT, ISPLIT,
+ $ MM, W, WERR, VL, VU, IBLOCK, INDEXW,
+ $ WORK, IWORK, DOL, DOU, 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
+
+
+***
+* 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.1).OR.( (IRANGE.EQ.2).AND.
+ $ ( D( IBEGIN ).GT.VL ).AND.( D( IBEGIN ).LE.VU ) )
+ $ .OR. ( (IRANGE.EQ.3).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
+
+ IF( ( IRANGE.EQ.1 ) .OR.
+ $ ((IRANGE.EQ.3).AND.(IL.EQ.1.AND.IU.EQ.N)) ) THEN
+* MB = number of eigenvalues to compute
+ MB = IN
+ WEND = WBEGIN + MB - 1
+ INDL = 1
+ INDU = IN
+ ELSE
+* 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
+ ENDIF
+*
+ WEND = WBEGIN + MB - 1
+* Find local index of the first and last desired evalue.
+ INDL = INDEXW(WBEGIN)
+ INDU = INDEXW( WEND )
+ ENDIF
+*
+ IF( (WEND.LT.DOL).OR.(WBEGIN.GT.DOU) ) THEN
+* if this subblock contains no desired eigenvalues,
+* skip the computation of this representation tree
+ IBEGIN = IEND + 1
+ WBEGIN = WEND + 1
+ M = M + MB
+ GO TO 170
+ END IF
+*
+ IF(.NOT. ( IRANGE.EQ.1 ) ) THEN
+
+* At this point, the sequential code decides
+* whether dqds or bisection is more efficient.
+* Note: in the parallel code, we do not use dqds.
+* However, we do not change the shift strategy
+* if USEDQD is TRUE, then the same shift is used as for
+* the sequential code when it uses dqds.
+*
+ USEDQD = ( MB .GT. FAC*IN )
+*
+* 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 )))
+ ENDIF
+
+*
+* 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
+* Save local spectral diameter for later use
+ SDIAM(JBLK) = SPDIAM
+
+* Find approximations to the extremal eigenvalues of the block
+ CALL SLARRK( 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 SLARRK( 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))
+ IF( ( IRANGE.EQ.1 ).OR.USEDQD ) THEN
+* Case of DQDS shift
+* 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"
+ IF( IRANGE.EQ.1 ) 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
+* SLARRD2 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.2) THEN
+ CALL SLARRC( 'T', IN, S1, S2, D(IBEGIN),
+ $ E(IBEGIN), PIVMIN, CNT, CNT1, CNT2, IINFO)
+ ENDIF
+
+ IF(MB.LE.2) THEN
+ SIGMA = GL
+ SGNDEF = ONE
+ ELSEIF( CNT1 - INDL .GE. INDU - CNT2 ) THEN
+ IF( IRANGE.EQ.1 ) THEN
+ SIGMA = MAX(ISLEFT,GL)
+ ELSEIF( USEDQD ) THEN
+* use Gerschgorin bound as shift to get pos def matrix
+ 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.1 ) 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
+ TAU = SPDIAM*EPS*N + TWO*PIVMIN
+ TAU = MAX(TAU,EPS*ABS(SIGMA))
+ ELSE
+ IF(MB.GT.1) THEN
+ CLWDTH = W(WEND) + WERR(WEND) - W(WBEGIN) - WERR(WBEGIN)
+ AVGAP = ABS(CLWDTH / REAL(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(NOREP) THEN
+* Note that in the case of IRANGE=1, we use the Gerschgorin
+* shift which makes the matrix definite. So we should end up
+* here really only in the case of IRANGE = 2,3
+ 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 SCOPY( IN, WORK, 1, D( IBEGIN ), 1 )
+ CALL SCOPY( IN-1, WORK( IN+1 ), 1, E( IBEGIN ), 1 )
+
+
+ IF(RNDPRT .AND. 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 SLARNV(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(2*I-1))
+ E(IBEGIN+I-1) = E(IBEGIN+I-1)*(ONE+EPS*PERT*WORK(2*I))
+ 125 CONTINUE
+ D(IEND) = D(IEND)*(ONE+EPS*PERT*WORK(2*IN-1))
+*
+ ENDIF
+*
+* Compute the required eigenvalues of L D L' by bisection
+* Shift the eigenvalue approximations
+* according to the shift of their representation.
+ DO 134 J=WBEGIN,WEND
+ W(J) = W(J) - SIGMA
+ WERR(J) = WERR(J) + ABS(W(J)) * EPS
+ 134 CONTINUE
+* call SLARRB2 to reduce eigenvalue error of the approximations
+* from SLARRD2
+ DO 135 I = IBEGIN, IEND-1
+ WORK( I ) = D( I ) * E( I )**2
+ 135 CONTINUE
+* use bisection to find EV from INDL to INDU
+ INDL = INDEXW( WBEGIN )
+ INDU = INDEXW( WEND )
+*
+* Indicate that the current block contains eigenvalues that
+* are potentially needed later.
+*
+ NEEDIL = MIN(NEEDIL,WBEGIN)
+ NEEDIU = MAX(NEEDIU,WEND)
+*
+* For the parallel distributed case, only compute
+* those eigenvalues that have to be computed as indicated by DOL, DOU
+*
+ MYWBEG = MAX(WBEGIN,DOL)
+ MYWEND = MIN(WEND,DOU)
+*
+ IF(MYWBEG.GT.WBEGIN) THEN
+* This is the leftmost block containing wanted eigenvalues
+* as well as unwanted ones. To save on communication,
+* check if NEEDIL can be increased even further:
+* on the left end, only the eigenvalues of the cluster
+* including MYWBEG are needed
+ DO 136 I = WBEGIN, MYWBEG-1
+ IF ( WGAP(I).GE.MINRGP*ABS(W(I)) ) THEN
+ NEEDIL = MAX(I+1,NEEDIL)
+ ENDIF
+ 136 CONTINUE
+ ENDIF
+ IF(MYWEND.LT.WEND) THEN
+* This is the rightmost block containing wanted eigenvalues
+* as well as unwanted ones. To save on communication,
+* Check if NEEDIU can be decreased even further.
+ DO 137 I = MYWEND,WEND-1
+ IF ( WGAP(I).GE.MINRGP*ABS(W(I)) ) THEN
+ NEEDIU = MIN(I,NEEDIU)
+ GOTO 138
+ ENDIF
+ 137 CONTINUE
+ 138 CONTINUE
+ ENDIF
+*
+* Only compute eigenvalues from MYINDL to MYINDU
+* instead of INDL to INDU
+*
+ MYINDL = INDEXW( MYWBEG )
+ MYINDU = INDEXW( MYWEND )
+*
+ LGPVMN = LOG( PIVMIN )
+ LGSPDM = LOG( SPDIAM + PIVMIN )
+
+ CALL SLARRB2(IN, D(IBEGIN), WORK(IBEGIN),
+ $ MYINDL, MYINDU, RTOL1, RTOL2, MYINDL-1,
+ $ W(MYWBEG), WGAP(MYWBEG), WERR(MYWBEG),
+ $ WORK( 2*N+1 ), IWORK, PIVMIN,
+ $ LGPVMN, LGSPDM, IN, IINFO )
+ IF( IINFO .NE. 0 ) THEN
+ INFO = -4
+ RETURN
+ END IF
+* SLARRB2 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 140 I = INDL, INDU
+ M = M + 1
+ IBLOCK(M) = JBLK
+ INDEXW(M) = I
+ 140 CONTINUE
+*
+* proceed with next block
+ IBEGIN = IEND + 1
+ WBEGIN = WEND + 1
+ 170 CONTINUE
+*
+ IF (M.LT.DOU-DOL+1) THEN
+ INFO = -9
+ ENDIF
+
+
+ RETURN
+*
+* end of SLARRE2A
+*
+ END
diff --git a/SRC/slarrf2.f b/SRC/slarrf2.f
new file mode 100644
index 0000000..be11515
--- /dev/null
+++ b/SRC/slarrf2.f
@@ -0,0 +1,354 @@
+ SUBROUTINE SLARRF2( N, D, L, LD, CLSTRT, CLEND,
+ $ CLMID1, CLMID2, W, WGAP, WERR, TRYMID,
+ $ SPDIAM, CLGAPL, CLGAPR, PIVMIN, SIGMA,
+ $ DPLUS, LPLUS, WORK, INFO )
+*
+* -- ScaLAPACK computational routine (version 2.0) --
+* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver
+* July 4, 2010
+*
+ IMPLICIT NONE
+*
+* .. Scalar Arguments ..
+ INTEGER CLSTRT, CLEND, CLMID1, CLMID2, INFO, N
+ REAL CLGAPL, CLGAPR, PIVMIN, SIGMA, SPDIAM
+ LOGICAL TRYMID
+* ..
+* .. Array Arguments ..
+ REAL D( * ), DPLUS( * ), L( * ), LD( * ),
+ $ LPLUS( * ), W( * ), WGAP( * ), WERR( * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* Given the initial representation L D L^T and its cluster of close
+* eigenvalues (in a relative measure), W( CLSTRT ), W( CLSTRT+1 ), ...
+* W( CLEND ), SLARRF2 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.
+*
+* This is an enhanced version of SLARRF that also tries shifts in
+* the middle of the cluster, should there be a large gap, in order to
+* break large clusters into at least two pieces.
+*
+* Arguments
+* =========
+*
+* N (input) INTEGER
+* The order of the matrix (subblock, if the matrix splitted).
+*
+* D (input) REAL array, dimension (N)
+* The N diagonal elements of the diagonal matrix D.
+*
+* L (input) REAL array, dimension (N-1)
+* The (N-1) subdiagonal elements of the unit bidiagonal
+* matrix L.
+*
+* LD (input) REAL array, dimension (N-1)
+* The (N-1) elements L(i)*D(i).
+*
+* CLSTRT (input) INTEGER
+* The index of the first eigenvalue in the cluster.
+*
+* CLEND (input) INTEGER
+* The index of the last eigenvalue in the cluster.
+*
+* CLMID1,2(input) INTEGER
+* The index of a middle eigenvalue pair with large gap
+*
+* W (input) REAL array, dimension >= (CLEND-CLSTRT+1)
+* The eigenvalue APPROXIMATIONS of L D L^T in ascending order.
+* W( CLSTRT ) through W( CLEND ) form the cluster of relatively
+* close eigenalues.
+*
+* WGAP (input/output) REAL array, dimension >= (CLEND-CLSTRT+1)
+* The separation from the right neighbor eigenvalue in W.
+*
+* WERR (input) REAL array, dimension >= (CLEND-CLSTRT+1)
+* WERR contain the semiwidth of the uncertainty
+* interval of the corresponding eigenvalue APPROXIMATION in W
+*
+* SPDIAM (input) estimate of the spectral diameter obtained from the
+* Gerschgorin intervals
+*
+* CLGAPL, CLGAPR (input) absolute gap on each end of the cluster.
+* Set by the calling routine to protect against shifts too close
+* to eigenvalues outside the cluster.
+*
+* PIVMIN (input) DOUBLE PRECISION
+* The minimum pivot allowed in the sturm sequence.
+*
+* SIGMA (output) REAL
+* The shift used to form L(+) D(+) L(+)^T.
+*
+* DPLUS (output) REAL array, dimension (N)
+* The N diagonal elements of the diagonal matrix D(+).
+*
+* LPLUS (output) REAL array, dimension (N-1)
+* The first (N-1) elements of LPLUS contain the subdiagonal
+* elements of the unit bidiagonal matrix L(+).
+*
+* WORK (workspace) REAL array, dimension (2*N)
+* Workspace.
+*
+* Further Details
+* ===============
+*
+* Based on contributions by
+* Beresford Parlett, University of California, Berkeley, USA
+* Jim Demmel, University of California, Berkeley, USA
+* Inderjit Dhillon, University of Texas, Austin, USA
+* Osni Marques, LBNL/NERSC, USA
+* Christof Voemel, University of California, Berkeley, USA
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL FOUR, MAXGROWTH1, MAXGROWTH2, ONE, QUART, TWO
+ PARAMETER ( ONE = 1.0E0, TWO = 2.0E0,
+ $ FOUR = 4.0E0, QUART = 0.25E0,
+ $ MAXGROWTH1 = 8.E0,
+ $ MAXGROWTH2 = 8.E0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL DORRR1, NOFAIL, SAWNAN1, SAWNAN2, TRYRRR1
+ INTEGER BI,I,J,KTRY,KTRYMAX,SLEFT,SRIGHT,SMID,SHIFT
+ PARAMETER ( KTRYMAX = 1, SMID =0, SLEFT = 1, SRIGHT = 2 )
+
+* DSTQDS loops will be blocked to detect NaNs earlier if they occur
+ INTEGER BLKLEN
+ PARAMETER ( BLKLEN = 512 )
+
+
+ REAL AVGAP, BESTSHIFT, CLWDTH, EPS, FACT, FAIL,
+ $ FAIL2, GROWTHBOUND, LDELTA, LDMAX, LEASTGROWTH,
+ $ LSIGMA, MAX1, MAX2, MINGAP, MSIGMA1, MSIGMA2,
+ $ OLDP, PROD, RDELTA, RDMAX, RRR1, RRR2, RSIGMA,
+ $ S, TMP, ZNM2
+* ..
+* .. External Functions ..
+ LOGICAL SISNAN
+ REAL SLAMCH
+ EXTERNAL SISNAN, SLAMCH
+* ..
+* .. External Subroutines ..
+ EXTERNAL SCOPY
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS
+* ..
+* .. Executable Statements ..
+*
+ INFO = 0
+ FACT = REAL(2**KTRYMAX)
+ EPS = SLAMCH( 'Precision' )
+ SHIFT = 0
+
+* Decide whether the code should accept the best among all
+* representations despite large element growth or signal INFO=1
+ NOFAIL = .TRUE.
+*
+
+* Compute the average gap length of the cluster
+ CLWDTH = ABS(W(CLEND)-W(CLSTRT)) + WERR(CLEND) + WERR(CLSTRT)
+ AVGAP = CLWDTH / REAL(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 )
+ MSIGMA1 = W( CLMID1 ) + WERR( CLMID1 )
+ MSIGMA2 = W( CLMID2 ) - WERR( CLMID2 )
+
+* Use a small fudge to make sure that we really shift to the outside
+ LSIGMA = LSIGMA - ABS(LSIGMA)* TWO * EPS
+ RSIGMA = RSIGMA + ABS(RSIGMA)* TWO * 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 = SLAMCH( 'S' )
+ LEASTGROWTH = ONE / S
+ FAIL = REAL(N-1)*MINGAP/(SPDIAM*EPS)
+ FAIL2 = REAL(N-1)*MINGAP/(SPDIAM*SQRT(EPS))
+ GROWTHBOUND = MAXGROWTH1*SPDIAM
+
+*
+* Set default best shift
+*
+ BESTSHIFT = LSIGMA
+
+
+ IF(.NOT.TRYMID) GOTO 4
+*
+* Try shifts in the middle
+*
+ SHIFT = SMID
+
+ DO 3 J=1,2
+ SAWNAN1 = .FALSE.
+ IF(J.EQ.1) THEN
+* Try left middle point
+ SIGMA = MSIGMA1
+ ELSE
+* Try left middle point
+ SIGMA = MSIGMA2
+ ENDIF
+
+ S = -SIGMA
+ DPLUS( 1 ) = D( 1 ) + S
+ MAX1 = ABS( DPLUS( 1 ) )
+ DO 2 BI = 1, N-1, BLKLEN
+ DO 1 I = BI, MIN( BI+BLKLEN-1, N-1)
+ LPLUS( I ) = LD( I ) / DPLUS( I )
+ S = S*LPLUS( I )*L( I ) - SIGMA
+ DPLUS( I+1 ) = D( I+1 ) + S
+ MAX1 = MAX( MAX1,ABS(DPLUS(I+1)) )
+ 1 CONTINUE
+ SAWNAN1=SAWNAN1 .OR. SISNAN(MAX1)
+ IF (SAWNAN1) GOTO 3
+ 2 CONTINUE
+
+ IF( .NOT.SAWNAN1 ) THEN
+ IF( MAX1.LE.GROWTHBOUND ) THEN
+ GOTO 100
+ ELSE IF( MAX1.LE.LEASTGROWTH ) THEN
+ LEASTGROWTH = MAX1
+ BESTSHIFT = SIGMA
+ ENDIF
+ ENDIF
+ 3 CONTINUE
+
+
+ 4 CONTINUE
+*
+* Shifts in the middle not tried or not succeeded
+* Find best shift on the outside of the cluster
+*
+* while (KTRY <= KTRYMAX)
+ KTRY = 0
+*
+*
+*
+ 5 CONTINUE
+
+* Compute element growth when shifting to both ends of the cluster
+* accept shift if there is no element growth at one of the two ends
+
+* Left end
+ SAWNAN1 = .FALSE.
+ S = -LSIGMA
+ DPLUS( 1 ) = D( 1 ) + S
+ MAX1 = ABS( DPLUS( 1 ) )
+ DO 12 BI = 1, N-1, BLKLEN
+ DO 11 I = BI, MIN( BI+BLKLEN-1, N-1)
+ LPLUS( I ) = LD( I ) / DPLUS( I )
+ S = S*LPLUS( I )*L( I ) - LSIGMA
+ DPLUS( I+1 ) = D( I+1 ) + S
+ MAX1 = MAX( MAX1,ABS(DPLUS(I+1)) )
+ 11 CONTINUE
+ SAWNAN1=SAWNAN1 .OR. SISNAN(MAX1)
+ IF (SAWNAN1) GOTO 13
+ 12 CONTINUE
+ IF( .NOT.SAWNAN1 ) THEN
+ IF( MAX1.LE.GROWTHBOUND ) THEN
+ SIGMA = LSIGMA
+ SHIFT = SLEFT
+ GOTO 100
+ ELSE IF( MAX1.LE.LEASTGROWTH ) THEN
+ LEASTGROWTH = MAX1
+ BESTSHIFT = LSIGMA
+ ENDIF
+ ENDIF
+ 13 CONTINUE
+
+* Right end
+ SAWNAN2 = .FALSE.
+ S = -RSIGMA
+ WORK( 1 ) = D( 1 ) + S
+ MAX2 = ABS( WORK( 1 ) )
+ DO 22 BI = 1, N-1, BLKLEN
+ DO 21 I = BI, MIN( BI+BLKLEN-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
+ MAX2 = MAX( MAX2,ABS(WORK(I+1)) )
+ 21 CONTINUE
+ SAWNAN2=SAWNAN2 .OR. SISNAN(MAX2)
+ IF (SAWNAN2) GOTO 23
+ 22 CONTINUE
+ IF( .NOT.SAWNAN2 ) THEN
+ IF( MAX2.LE.GROWTHBOUND ) THEN
+ SIGMA = RSIGMA
+ SHIFT = SRIGHT
+ GOTO 100
+ ELSE IF( MAX2.LE.LEASTGROWTH ) THEN
+ LEASTGROWTH = MAX2
+ BESTSHIFT = RSIGMA
+ ENDIF
+ ENDIF
+ 23 CONTINUE
+
+* If we are at this point, both shifts led to too much element growth
+
+ 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
+* Ensure that we do not back off too much of the initial shifts
+ LDELTA = MIN(LDMAX,LDELTA)
+ RDELTA = MIN(RDMAX,RDELTA)
+ KTRY = KTRY + 1
+ GOTO 5
+ ELSE
+* None of the representations investigated satisfied our
+* criteria. Take the best one we found.
+ IF((LEASTGROWTH.LT.FAIL).OR.NOFAIL) THEN
+ LSIGMA = BESTSHIFT
+ SAWNAN1 = .FALSE.
+ S = -LSIGMA
+ DPLUS( 1 ) = D( 1 ) + S
+ 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
+ ENDIF
+ 6 CONTINUE
+ SIGMA = LSIGMA
+ SHIFT = SLEFT
+ GOTO 100
+ ELSE
+ INFO = 1
+ RETURN
+ ENDIF
+ END IF
+
+ 100 CONTINUE
+ IF (SHIFT.EQ.SLEFT .OR. SHIFT.EQ.SMID ) THEN
+ ELSEIF (SHIFT.EQ.SRIGHT) THEN
+* store new L and D back into DPLUS, LPLUS
+ CALL SCOPY( N, WORK, 1, DPLUS, 1 )
+ CALL SCOPY( N-1, WORK(N+1), 1, LPLUS, 1 )
+ ENDIF
+
+ RETURN
+*
+* End of SLARRF2
+*
+ END
diff --git a/SRC/slarrv2.f b/SRC/slarrv2.f
new file mode 100644
index 0000000..93a08a2
--- /dev/null
+++ b/SRC/slarrv2.f
@@ -0,0 +1,1166 @@
+ SUBROUTINE SLARRV2( N, VL, VU, D, L, PIVMIN,
+ $ ISPLIT, M, DOL, DOU, NEEDIL, NEEDIU,
+ $ MINRGP, RTOL1, RTOL2, W, WERR, WGAP,
+ $ IBLOCK, INDEXW, GERS, SDIAM,
+ $ Z, LDZ, ISUPPZ,
+ $ WORK, IWORK, VSTART, FINISH,
+ $ MAXCLS, NDEPTH, PARITY, ZOFFSET, INFO )
+
+* -- ScaLAPACK auxiliary routine (version 2.0) --
+* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver
+* July 4, 2010
+*
+ IMPLICIT NONE
+*
+* .. Scalar Arguments ..
+ INTEGER DOL, DOU, INFO, LDZ, M, N, MAXCLS,
+ $ NDEPTH, NEEDIL, NEEDIU, PARITY, ZOFFSET
+ REAL MINRGP, PIVMIN, RTOL1, RTOL2, VL, VU
+ LOGICAL VSTART, FINISH
+* ..
+* .. Array Arguments ..
+ INTEGER IBLOCK( * ), INDEXW( * ), ISPLIT( * ),
+ $ ISUPPZ( * ), IWORK( * )
+ REAL D( * ), GERS( * ), L( * ), SDIAM( * ),
+ $ W( * ), WERR( * ),
+ $ WGAP( * ), WORK( * )
+ REAL Z( LDZ, * )
+*
+* Purpose
+* =======
+*
+* SLARRV2 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 SLARRE2A
+* or by precious calls to SLARRV2.
+*
+* The major difference between the parallel and the sequential construction
+* of the representation tree is that in the parallel case, not all eigenvalues
+* of a given cluster might be computed locally. Other processors might "own"
+* and refine part of an eigenvalue cluster. This is crucial for scalability.
+* Thus there might be communication necessary before the current level of the
+* representation tree can be parsed.
+*
+* Please note:
+* 1. The calling sequence has two additional INTEGER parameters,
+* DOL and DOU, that should satisfy M>=DOU>=DOL>=1.
+* These parameters are only relevant for the case JOBZ = 'V'.
+* SLARRV2 ONLY computes the eigenVECTORS
+* corresponding to eigenvalues DOL through DOU in W. (That is,
+* instead of computing the eigenvectors belonging to W(1)
+* through W(M), only the eigenvectors belonging to eigenvalues
+* W(DOL) through W(DOU) are computed. In this case, only the
+* eigenvalues DOL:DOU are guaranteed to be accurately refined
+* to all figures by Rayleigh-Quotient iteration.
+*
+* 2. The additional arguments VSTART, FINISH, NDEPTH, PARITY, ZOFFSET
+* are included as a thread-safe implementation equivalent to SAVE variables.
+* These variables store details about the local representation tree which is
+* computed layerwise. For scalability reasons, eigenvalues belonging to the
+* locally relevant representation tree might be computed on other processors.
+* These need to be communicated before the inspection of the RRRs can proceed
+* on any given layer.
+* Note that only when the variable FINISH is true, the computation has ended
+* All eigenpairs between DOL and DOU have been computed. M is set = DOU - DOL + 1.
+*
+* 3. SLARRV2 needs more workspace in Z than the sequential SLARRV.
+* It is used to store the conformal embedding of the local representation tree.
+*
+* Arguments
+* =========
+*
+* N (input) INTEGER
+* The order of the matrix. N >= 0.
+*
+* VL (input) REAL
+* VU (input) REAL
+* Lower and upper bounds of the interval that contains the desired
+* eigenvalues. VL < VU. Needed to compute gaps on the left or right
+* end of the extremal eigenvalues in the desired RANGE.
+* VU is currently not used but kept as parameter in case needed.
+*
+* D (input/output) REAL array, dimension (N)
+* On entry, the N diagonal elements of the diagonal matrix D.
+* On exit, D is overwritten.
+*
+* L (input/output) REAL array, dimension (N)
+* On entry, the (N-1) subdiagonal elements of the unit
+* bidiagonal matrix L are in elements 1 to N-1 of L
+* (if the matrix is not splitted.) At the end of each block
+* is stored the corresponding shift as given by SLARRE.
+* On exit, L is overwritten.
+*
+* PIVMIN (in) DOUBLE PRECISION
+* The minimum pivot allowed in the sturm sequence.
+*
+* ISPLIT (input) INTEGER array, dimension (N)
+* The splitting points, at which T breaks up into blocks.
+* The first block consists of rows/columns 1 to
+* ISPLIT( 1 ), the second of rows/columns ISPLIT( 1 )+1
+* through ISPLIT( 2 ), etc.
+*
+* M (input) INTEGER
+* The total number of input eigenvalues. 0 <= M <= N.
+*
+* DOL (input) INTEGER
+* DOU (input) INTEGER
+* If the user wants to compute only selected eigenvectors from all
+* the eigenvalues supplied, he can specify an index range DOL:DOU.
+* Or else the setting DOL=1, DOU=M should be applied.
+* Note that DOL and DOU refer to the order in which the eigenvalues
+* are stored in W.
+* If the user wants to compute only selected eigenpairs, then
+* the columns DOL-1 to DOU+1 of the eigenvector space Z contain the
+* computed eigenvectors. All other columns of Z are set to zero.
+* If DOL > 1, then Z(:,DOL-1-ZOFFSET) is used.
+* If DOU < M, then Z(:,DOU+1-ZOFFSET) is used.
+*
+*
+* NEEDIL (input/output) INTEGER
+* NEEDIU (input/output) INTEGER
+* Describe which are the left and right outermost eigenvalues
+* that still need to be included in the computation. These indices
+* indicate whether eigenvalues from other processors are needed to
+* correctly compute the conformally embedded representation tree.
+* When DOL<=NEEDIL<=NEEDIU<=DOU, all required eigenvalues are local
+* to the processor and no communication is required to compute its
+* part of the representation tree.
+*
+* MINRGP (input) REAL
+* The minimum relativ gap threshold to decide whether an eigenvalue
+* or a cluster boundary is reached.
+*
+* RTOL1 (input) REAL
+* RTOL2 (input) REAL
+* Parameters for bisection.
+* An interval [LEFT,RIGHT] has converged if
+* RIGHT-LEFT.LT.MAX( RTOL1*GAP, RTOL2*MAX(|LEFT|,|RIGHT|) )
+*
+* W (input/output) REAL array, dimension (N)
+* The first M elements of W contain the APPROXIMATE eigenvalues for
+* which eigenvectors are to be computed. The eigenvalues
+* should be grouped by split-off block and ordered from
+* smallest to largest within the block. (The output array
+* W from SSTEGR2A is expected here.) Furthermore, they are with
+* respect to the shift of the corresponding root representation
+* for their block. On exit,
+* W holds those UNshifted eigenvalues
+* for which eigenvectors have already been computed.
+*
+* WERR (input/output) REAL array, dimension (N)
+* The first M elements contain the semiwidth of the uncertainty
+* interval of the corresponding eigenvalue in W
+*
+* WGAP (input/output) REAL array, dimension (N)
+* The separation from the right neighbor eigenvalue in W.
+*
+* IBLOCK (input) INTEGER array, dimension (N)
+* The indices of the blocks (submatrices) associated with the
+* corresponding eigenvalues in W; IBLOCK(i)=1 if eigenvalue
+* W(i) belongs to the first block from the top, =2 if W(i)
+* belongs to the second block, etc.
+*
+* INDEXW (input) INTEGER array, dimension (N)
+* The indices of the eigenvalues within each block (submatrix);
+* for example, INDEXW(i)= 10 and IBLOCK(i)=2 imply that the
+* i-th eigenvalue W(i) is the 10-th eigenvalue in the second block.
+*
+* GERS (input) REAL array, dimension (2*N)
+* The N Gerschgorin intervals (the i-th Gerschgorin interval
+* is (GERS(2*i-1), GERS(2*i)). The Gerschgorin intervals should
+* be computed from the original UNshifted matrix.
+* Currently NOT used but kept as parameter in case it becomes
+* needed in the future.
+*
+* SDIAM (input) REAL array, dimension (N)
+* The spectral diameters for all unreduced blocks.
+*
+* Z (output) REAL array, dimension (LDZ, max(1,M) )
+* If INFO = 0, the first M columns of Z contain the
+* orthonormal eigenvectors of the matrix T
+* corresponding to the input eigenvalues, with the i-th
+* column of Z holding the eigenvector associated with W(i).
+* In the distributed version, only a subset of columns
+* is accessed, see DOL,DOU and ZOFFSET.
+*
+* LDZ (input) INTEGER
+* The leading dimension of the array Z. LDZ >= 1, and if
+* JOBZ = 'V', LDZ >= max(1,N).
+*
+* ISUPPZ (output) INTEGER array, dimension ( 2*max(1,M) )
+* The support of the eigenvectors in Z, i.e., the indices
+* indicating the nonzero elements in Z. The I-th eigenvector
+* is nonzero only in elements ISUPPZ( 2*I-1 ) through
+* ISUPPZ( 2*I ).
+*
+* WORK (workspace) REAL array, dimension (12*N)
+*
+* IWORK (workspace) INTEGER array, dimension (7*N)
+*
+* VSTART (input/output) LOGICAL
+* .TRUE. on initialization, set to .FALSE. afterwards.
+*
+* FINISH (input/output) LOGICAL
+* A flag that indicates whether all eigenpairs have been computed.
+*
+* MAXCLS (input/output) INTEGER
+* The largest cluster worked on by this processor in the
+* representation tree.
+*
+* NDEPTH (input/output) INTEGER
+* The current depth of the representation tree. Set to
+* zero on initial pass, changed when the deeper levels of
+* the representation tree are generated.
+*
+* PARITY (input/output) INTEGER
+* An internal parameter needed for the storage of the
+* clusters on the current level of the representation tree.
+*
+* ZOFFSET (input) INTEGER
+* Offset for storing the eigenpairs when Z is distributed
+* in 1D-cyclic fashion.
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+*
+* > 0: A problem occured in SLARRV2.
+* < 0: One of the called subroutines signaled an internal problem.
+* Needs inspection of the corresponding parameter IINFO
+* for further information.
+*
+* =-1: Problem in SLARRB2 when refining a child's eigenvalues.
+* =-2: Problem in SLARRF2 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 SLARRB2 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.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ INTEGER MAXITR, USE30, USE31, USE32A, USE32B
+ PARAMETER ( MAXITR = 10, USE30=30, USE31=31,
+ $ USE32A=3210, USE32B = 3211 )
+ REAL ZERO, ONE, TWO, THREE, FOUR, HALF
+ PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0,
+ $ TWO = 2.0E0, THREE = 3.0E0,
+ $ FOUR = 4.0E0, HALF = 0.5E0)
+* ..
+* .. Local Arrays ..
+ INTEGER SPLACE( 4 )
+* ..
+* .. Local Scalars ..
+ LOGICAL DELREF, ESKIP, NEEDBS, ONLYLC, STP2II, TRYMID,
+ $ TRYRQC, USEDBS, USEDRQ
+ INTEGER I, IBEGIN, IEND, II, IINCLS, IINDC1, IINDC2,
+ $ IINDWK, IINFO, IM, IN, INDEIG, INDLD, INDLLD,
+ $ INDWRK, ISUPMN, ISUPMX, ITER, ITMP1, ITWIST, J,
+ $ JBLK, K, KK, MINIWSIZE, MINWSIZE, MYWFST,
+ $ MYWLST, NCLUS, NEGCNT, NEWCLS, NEWFST, NEWFTT,
+ $ NEWLST, NEWSIZ, OFFSET, OLDCLS, OLDFST, OLDIEN,
+ $ OLDLST, OLDNCL, P, Q, VRTREE, WBEGIN, WEND,
+ $ WINDEX, WINDMN, WINDPL, ZFROM, ZINDEX, ZTO,
+ $ ZUSEDL, ZUSEDU, ZUSEDW
+ REAL AVGAP, BSTRES, BSTW, ENUFGP, EPS, FUDGE, GAP,
+ $ GAPTOL, LAMBDA, LEFT, LGAP, LGPVMN, LGSPDM,
+ $ LOG_IN, MGAP, MINGMA, MYERR, NRMINV, NXTERR,
+ $ ORTOL, RESID, RGAP, RIGHT, RLTL30, RQCORR,
+ $ RQTOL, SAVEGP, SGNDEF, SIGMA, SPDIAM, SSIGMA,
+ $ TAU, TMP, TOL, ZTZ
+* ..
+* .. External Functions ..
+ REAL SLAMCH
+ REAL SDOT, SNRM2
+ EXTERNAL SDOT, SLAMCH, SNRM2
+* ..
+* .. External Subroutines ..
+ EXTERNAL SAXPY, SCOPY, SLAR1VA, SLARRB2,
+ $ SLARRF2, SLASET, SSCAL
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, REAL, MAX, MIN, SQRT
+* ..
+* .. 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
+
+* IWORK(IINCLS+JBLK) holds the number of clusters on the current level
+* of the reptree for block JBLK
+ IINCLS = 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
+
+ EPS = SLAMCH( 'Precision' )
+ RQTOL = TWO * EPS
+
+ TRYRQC = .TRUE.
+* Decide which representation tree criterion to use
+* USE30 = Lapack 3.0 criterion
+* USE31 = LAPACK 3.1 criterion
+* USE32A = two criteria, determines singletons with USE31, and groups with avgap.
+* USE32B = two criteria, determines singletons with USE31, and groups with USE30.
+ VRTREE = USE32A
+*
+ LGPVMN = LOG( PIVMIN )
+
+
+ IF(VSTART) THEN
+*
+* PREPROCESSING, DONE ONLY IN THE FIRST CALL
+*
+ VSTART = .FALSE.
+*
+ MAXCLS = 1
+
+* Set delayed eigenvalue refinement
+* In order to enable more parallelism, refinement
+* must be done immediately and cannot be delayed until
+* the next representation tree level.
+ DELREF = .FALSE.
+
+ DO 1 I= 1,MINWSIZE
+ WORK( I ) = ZERO
+ 1 CONTINUE
+
+ DO 2 I= 1,MINIWSIZE
+ IWORK( I ) = 0
+ 2 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 SLASET( 'Full', N, ZUSEDW, ZERO, ZERO,
+ $ Z(1,(ZUSEDL-ZOFFSET)), LDZ )
+
+* Initialize NDEPTH, the current depth of the representation tree
+ NDEPTH = 0
+* Initialize parity
+ PARITY = 1
+
+* Go through blocks, initialize data structures
+ IBEGIN = 1
+ WBEGIN = 1
+ DO 10 JBLK = 1, IBLOCK( M )
+ IEND = ISPLIT( JBLK )
+ SIGMA = L( IEND )
+ WEND = WBEGIN - 1
+ 3 CONTINUE
+ IF( WEND.LT.M ) THEN
+ IF( IBLOCK( WEND+1 ).EQ.JBLK ) THEN
+ WEND = WEND + 1
+ GO TO 3
+ END IF
+ END IF
+ IF( WEND.LT.WBEGIN ) THEN
+ IWORK( IINCLS + JBLK ) = 0
+ IBEGIN = IEND + 1
+ GO TO 10
+ ELSEIF( (WEND.LT.DOL).OR.(WBEGIN.GT.DOU) ) THEN
+ IWORK( IINCLS + JBLK ) = 0
+ IBEGIN = IEND + 1
+ WBEGIN = WEND + 1
+ GO TO 10
+ END IF
+* The number of eigenvalues in the current block
+ IM = WEND - WBEGIN + 1
+* This is for a 1x1 block
+ IF( IBEGIN.EQ.IEND ) THEN
+ IWORK( IINCLS + JBLK ) = 0
+ Z( IBEGIN, (WBEGIN-ZOFFSET) ) = 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 10
+ END IF
+ CALL SCOPY( IM, W( WBEGIN ), 1,
+ & WORK( WBEGIN ), 1 )
+* We store in W the eigenvalue approximations w.r.t. the original
+* matrix T.
+ DO 5 I=1,IM
+ W(WBEGIN+I-1) = W(WBEGIN+I-1)+SIGMA
+ 5 CONTINUE
+
+* Initialize cluster counter for this block
+ IWORK( IINCLS + JBLK ) = 1
+ IWORK( IINDC1+IBEGIN ) = 1
+ IWORK( IINDC1+IBEGIN+1 ) = IM
+*
+ IBEGIN = IEND + 1
+ WBEGIN = WEND + 1
+10 CONTINUE
+*
+ ENDIF
+
+* Init NEEDIL and NEEDIU
+ NEEDIL = DOU
+ NEEDIU = DOL
+
+* Here starts the main loop
+* Only one pass through the loop is done until no collaboration
+* with other processors is needed.
+ 40 CONTINUE
+
+ PARITY = 1 - PARITY
+
+* For each block, build next level of representation tree
+* if there are still remaining clusters
+ 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.
+ IF(M.EQ.N) THEN
+* all eigenpairs are computed
+ WEND = IEND
+ ELSE
+* count how many wanted eigenpairs are in this block
+ 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
+ ENDIF
+
+ OLDNCL = IWORK( IINCLS + JBLK )
+ IF( OLDNCL.EQ.0 ) THEN
+ IBEGIN = IEND + 1
+ WBEGIN = WEND + 1
+ GO TO 170
+ END IF
+* 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
+
+* Find local spectral diameter of the block
+ SPDIAM = SDIAM(JBLK)
+ LGSPDM = LOG( SPDIAM + PIVMIN )
+* Compute ORTOL parameter, similar to SSTEIN
+ ORTOL = SPDIAM*1.0E-3
+* Compute average gap
+ AVGAP = SPDIAM/REAL(IN-1)
+* Compute the minimum of average gap and ORTOL parameter
+* This can used as a lower bound for acceptable separation
+* between eigenvalues
+ ENUFGP = MIN(ORTOL,AVGAP)
+
+* Any 1x1 block has been treated before
+
+* loop while( OLDNCLS.GT.0 )
+* generate the next representation tree level for the current block
+ IF( OLDNCL.GT.0 ) 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
+* NCLUS is the number of clusters for the next level of the reptree
+* reset NCLUS to count the number of child clusters
+ NCLUS = 0
+*
+ LOG_IN = LOG(REAL(IN))
+*
+ RLTL30 = MIN( 1.0E-2, ONE / REAL( IN ) )
+*
+ IF( PARITY.EQ.0 ) THEN
+ OLDCLS = IINDC1+IBEGIN-1
+ NEWCLS = IINDC2+IBEGIN-1
+ ELSE
+ OLDCLS = IINDC2+IBEGIN-1
+ NEWCLS = IINDC1+IBEGIN-1
+ 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 SCOPY( IN, Z( IBEGIN, (J-ZOFFSET) ),
+ $ 1, D( IBEGIN ), 1 )
+ CALL SCOPY( IN-1, Z( IBEGIN, (J+1-ZOFFSET) ),
+ $ 1, L( IBEGIN ),1 )
+ SIGMA = Z( IEND, (J+1-ZOFFSET) )
+* Set the corresponding entries in Z to zero
+ CALL SLASET( 'Full', IN, 2, ZERO, ZERO,
+ $ Z( IBEGIN, (J-ZOFFSET) ), 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 .AND. DELREF ) 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., th P-OFFSET
+* thru' Q-OFFSET elements of these arrays are to be used.
+C OFFSET = P-OLDFST
+ OFFSET = INDEXW( WBEGIN ) - 1
+* perform limited bisection (if necessary) to get approximate
+* eigenvalues to the precision needed.
+ CALL SLARRB2( IN, D( IBEGIN ),
+ $ WORK(INDLLD+IBEGIN-1),
+ $ P, Q, RTOL1, RTOL2, OFFSET,
+ $ WORK(WBEGIN),WGAP(WBEGIN),WERR(WBEGIN),
+ $ WORK( INDWRK ), IWORK( IINDWK ),
+ $ PIVMIN, LGPVMN, LGSPDM, 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 SLARRB2.
+* 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
+ ELSEIF( (NDEPTH.EQ.0) .OR. (.NOT.DELREF) ) THEN
+* Some of the eigenvalues might have been computed on
+* other processors
+* Recompute gaps for this cluster
+* (all eigenvalues have the same
+* representation, i.e. the same shift, so this is easy)
+ DO 54 J = OLDFST, OLDLST-1
+ MYERR = WERR(WBEGIN + J - 1)
+ NXTERR = WERR(WBEGIN + J )
+ WGAP(WBEGIN+J-1) = MAX(WGAP(WBEGIN+J-1),
+ $ ( WORK(WBEGIN+J) - NXTERR )
+ $ - ( WORK(WBEGIN+J-1) + MYERR )
+ $ )
+ 54 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 (VRTREE.EQ.USE30) THEN
+ IF(WGAP( WBEGIN + J -1).GE.
+ $ RLTL30 * ABS(WORK(WBEGIN + J -1)) ) THEN
+* the right relgap is big enough by the Lapack 3.0 criterion
+ NEWLST = J
+ ELSE
+* inside a child cluster, the relative gap is not
+* big enough.
+ GOTO 140
+ ENDIF
+ ELSE IF (VRTREE.EQ.USE31) THEN
+ IF ( WGAP( WBEGIN + J -1).GE.
+ $ MINRGP* ABS( WORK(WBEGIN + J -1) ) ) THEN
+* the right relgap is big enough by the Lapack 3.1 criterion
+* (NEWFST,..,NEWLST) is well separated from the following
+ NEWLST = J
+ ELSE
+* inside a child cluster, the relative gap is not
+* big enough.
+ GOTO 140
+ ENDIF
+ ELSE IF (VRTREE.EQ.USE32A) THEN
+ IF( (J.EQ.OLDFST).AND.( WGAP(WBEGIN+J-1).GE.
+ $ MINRGP* ABS(WORK(WBEGIN+J-1)) ) ) THEN
+* the right relgap is big enough by the Lapack 3.1 criterion
+* Found a singleton
+ NEWLST = J
+ ELSE IF( (J.GT.OLDFST).AND.(J.EQ.NEWFST).AND.
+ $ ( WGAP(WBEGIN+J-2).GE.
+ $ MINRGP* ABS(WORK(WBEGIN+J-1)) ).AND.
+ $ ( WGAP(WBEGIN+J-1).GE.
+ $ MINRGP* ABS(WORK(WBEGIN+J-1)) )
+ $ ) THEN
+* Found a singleton
+ NEWLST = J
+ ELSE IF( (J.GT.NEWFST).AND.WGAP(WBEGIN+J-1).GE.
+ $ (MINRGP*ABS(WORK(WBEGIN+J-1)) ) )
+ $ THEN
+* the right relgap is big enough by the Lapack 3.1 criterion
+ NEWLST = J
+ ELSE IF((J.GT.NEWFST).AND.(J+1.LT.OLDLST).AND.
+ $ (WGAP(WBEGIN+J-1).GE.ENUFGP))
+ $ THEN
+* the right gap is bigger than ENUFGP
+* Care needs to be taken with this criterion to make
+* sure it does not create a remaining `false' singleton
+ NEWLST = J
+ ELSE
+* inside a child cluster, the relative gap is not
+* big enough.
+ GOTO 140
+ ENDIF
+ ELSE IF (VRTREE.EQ.USE32B) THEN
+ IF( (J.EQ.OLDFST).AND.( WGAP(WBEGIN+J-1).GE.
+ $ MINRGP* ABS(WORK(WBEGIN+J-1)) ) ) THEN
+* the right relgap is big enough by the Lapack 3.1 criterion
+* Found a singleton
+ NEWLST = J
+ ELSE IF( (J.GT.OLDFST).AND.(J.EQ.NEWFST).AND.
+ $ ( WGAP(WBEGIN+J-2).GE.
+ $ MINRGP* ABS(WORK(WBEGIN+J-1)) ).AND.
+ $ ( WGAP(WBEGIN+J-1).GE.
+ $ MINRGP* ABS(WORK(WBEGIN+J-1)) )
+ $ ) THEN
+* Found a singleton
+ NEWLST = J
+ ELSE IF( (J.GT.NEWFST).AND.WGAP(WBEGIN+J-1).GE.
+ $ (MINRGP*ABS(WORK(WBEGIN+J-1)) ) )
+ $ THEN
+* the right relgap is big enough by the Lapack 3.1 criterion
+ NEWLST = J
+ ELSE IF((J.GT.NEWFST).AND.(J+1.LT.OLDLST).AND.
+ $ (WGAP( WBEGIN + J -1).GE.
+ $ RLTL30 * ABS(WORK(WBEGIN + J -1)) ))
+ $ THEN
+* the right relgap is big enough by the Lapack 3.0 criterion
+* Care needs to be taken with this criterion to make
+* sure it does not create a remaining `false' singleton
+ NEWLST = J
+ ELSE
+* inside a child cluster, the relative gap is not
+* big enough.
+ GOTO 140
+ ENDIF
+ END IF
+ END IF
+
+* Compute size of child cluster found
+ NEWSIZ = NEWLST - NEWFST + 1
+ MAXCLS = MAX( NEWSIZ, MAXCLS )
+
+* 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
+* FOR 1D-DISTRIBUTED Z, COMPUTE NEWFTT SHIFTED BY ZOFFSET
+ NEWFTT = NEWFTT - ZOFFSET
+
+ IF( NEWSIZ.GT.1) THEN
+*
+* Current child is not a singleton but a cluster.
+*
+*
+ 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
+ GOTO 139
+ ENDIF
+
+* Compute left and right cluster gap.
+*
+ 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 )
+*
+* For larger clusters, record the largest gap observed
+* somewhere near the middle of the cluster as a possible
+* alternative position for a shift when TRYMID is TRUE
+*
+ MGAP = ZERO
+ IF(NEWSIZ.GE.50) THEN
+ KK = NEWFST
+ DO 545 K =NEWFST+NEWSIZ/3,NEWLST-NEWSIZ/3
+ IF(MGAP.LT.WGAP( WBEGIN+K-1 )) THEN
+ KK = K
+ MGAP = WGAP( WBEGIN+K-1 )
+ ENDIF
+ 545 CONTINUE
+ ENDIF
+
+*
+* Record the left- and right-most eigenvalues needed
+* for the next level of the representation tree
+ NEEDIL = MIN(NEEDIL,WBEGIN+NEWFST-1)
+ NEEDIU = MAX(NEEDIU,WBEGIN+NEWLST-1)
+
+*
+* Check if middle gap is large enough to shift there
+*
+ GAP = MIN(LGAP,RGAP)
+ TRYMID = (MGAP.GT.GAP)
+
+ SPLACE(1) = NEWFST
+ SPLACE(2) = NEWLST
+ IF(TRYMID) THEN
+ SPLACE(3) = KK
+ SPLACE(4) = KK+1
+ ELSE
+ SPLACE(3) = NEWFST
+ SPLACE(4) = NEWLST
+ ENDIF
+*
+* 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,4
+ P = INDEXW( WBEGIN-1+SPLACE(K) )
+ OFFSET = INDEXW( WBEGIN ) - 1
+ CALL SLARRB2( IN, D(IBEGIN),
+ $ WORK( INDLLD+IBEGIN-1 ),P,P,
+ $ RQTOL, RQTOL, OFFSET,
+ $ WORK(WBEGIN),WGAP(WBEGIN),
+ $ WERR(WBEGIN),WORK( INDWRK ),
+ $ IWORK( IINDWK ),
+ $ PIVMIN, LGPVMN, LGSPDM, IN, IINFO )
+ 55 CONTINUE
+*
+* Compute RRR of child cluster.
+* Note that the new RRR is stored in Z
+*
+C SLARRF2 needs LWORK = 2*N
+ CALL SLARRF2( IN, D( IBEGIN ), L( IBEGIN ),
+ $ WORK(INDLD+IBEGIN-1),
+ $ SPLACE(1), SPLACE(2),
+ $ SPLACE(3), SPLACE(4), WORK(WBEGIN),
+ $ WGAP(WBEGIN), WERR(WBEGIN), TRYMID,
+ $ 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 SLARRF2
+* 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
+ 116 CONTINUE
+
+ NCLUS = NCLUS + 1
+ K = NEWCLS + 2*NCLUS
+ IWORK( K-1 ) = NEWFST
+ IWORK( K ) = NEWLST
+*
+ IF(.NOT.DELREF) THEN
+ ONLYLC = .TRUE.
+*
+ IF(ONLYLC) THEN
+ MYWFST = MAX(WBEGIN-1+NEWFST,DOL-1)
+ MYWLST = MIN(WBEGIN-1+NEWLST,DOU+1)
+ ELSE
+ MYWFST = WBEGIN-1+NEWFST
+ MYWLST = WBEGIN-1+NEWLST
+ ENDIF
+
+* Compute LLD of new RRR
+ DO 5000 K = IBEGIN, IEND-1
+ WORK( INDWRK-1+K ) =
+ $ Z(K,NEWFTT)*
+ $ (Z(K,NEWFTT+1)**2)
+ 5000 CONTINUE
+* P and Q are index of the first and last
+* eigenvalue to compute within the new cluster
+ P = INDEXW( MYWFST )
+ Q = INDEXW( MYWLST )
+* Offset for the arrays WORK, WGAP and WERR
+ OFFSET = INDEXW( WBEGIN ) - 1
+* perform limited bisection (if necessary) to get approximate
+* eigenvalues to the precision needed.
+ CALL SLARRB2( IN,
+ $ Z(IBEGIN, NEWFTT ),
+ $ WORK(INDWRK+IBEGIN-1),
+ $ P, Q, RTOL1, RTOL2, OFFSET,
+ $ WORK(WBEGIN),WGAP(WBEGIN),WERR(WBEGIN),
+ $ WORK( INDWRK+N ), IWORK( IINDWK ),
+ $ PIVMIN, LGPVMN, LGSPDM, IN, IINFO )
+ IF( IINFO.NE.0 ) THEN
+ INFO = -1
+ RETURN
+ ENDIF
+* Each time the eigenvalues in WORK get refined, we store
+* the newly found approximation with all shifts applied in W
+ DO 5003 K=NEWFST,NEWLST
+ W(WBEGIN+K-1) = WORK(WBEGIN+K-1)+SSIGMA
+ 5003 CONTINUE
+ ENDIF
+*
+ ELSE
+ INFO = -2
+ RETURN
+ ENDIF
+ ELSE
+*
+* Compute eigenvector of singleton
+*
+ ITER = 0
+*
+ TOL = FOUR * LOG_IN * EPS
+*
+ K = NEWFST
+ WINDEX = WBEGIN + K - 1
+ ZINDEX = WINDEX - ZOFFSET
+ WINDMN = MAX(WINDEX - 1,1)
+ WINDPL = MIN(WINDEX + 1,M)
+ LAMBDA = WORK( WINDEX )
+* 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 )
+ IF( K .EQ. 1) THEN
+ LGAP = EPS*MAX(ABS(LEFT),ABS(RIGHT))
+ ELSE
+ LGAP = WGAP(WINDMN)
+ ENDIF
+ IF( K .EQ. IM) THEN
+ 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
+ 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.
+ SAVEGP = 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
+* Reset ITWIST
+ ITWIST = 0
+ 120 CONTINUE
+* Check if bisection should be used to refine eigenvalue
+ IF(NEEDBS) THEN
+* Take the bisection as new iterate
+ USEDBS = .TRUE.
+* Temporary copy of twist index needed
+ ITMP1 = ITWIST
+ OFFSET = INDEXW( WBEGIN ) - 1
+ CALL SLARRB2( IN, D(IBEGIN),
+ $ WORK(INDLLD+IBEGIN-1),INDEIG,INDEIG,
+ $ ZERO, TWO*EPS, OFFSET,
+ $ WORK(WBEGIN),WGAP(WBEGIN),
+ $ WERR(WBEGIN),WORK( INDWRK ),
+ $ IWORK( IINDWK ),
+ $ PIVMIN, LGPVMN, LGSPDM, 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
+ ITWIST = 0
+ ENDIF
+* Given LAMBDA, compute the eigenvector.
+ CALL SLAR1VA( IN, 1, IN, LAMBDA, D(IBEGIN),
+ $ L( IBEGIN ), WORK(INDLD+IBEGIN-1),
+ $ WORK(INDLLD+IBEGIN-1),
+ $ PIVMIN, GAPTOL, Z( IBEGIN, ZINDEX),
+ $ .NOT.USEDBS, NEGCNT, ZTZ, MINGMA,
+ $ ITWIST, 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
+*
+* 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
+ ELSE
+* The current LAMBDA is on the right of the true
+* eigenvalue
+ RIGHT = LAMBDA
+ 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
+ CALL SLAR1VA( IN, 1, IN, LAMBDA,
+ $ D( IBEGIN ), L( IBEGIN ),
+ $ WORK(INDLD+IBEGIN-1),
+ $ WORK(INDLLD+IBEGIN-1),
+ $ PIVMIN, GAPTOL,
+ $ Z( IBEGIN, ZINDEX ),
+ $ .NOT.USEDBS, NEGCNT, ZTZ, MINGMA,
+ $ ITWIST,
+ $ 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, ZINDEX ) = ZERO
+ 122 CONTINUE
+ ENDIF
+ IF(ISUPMX.GT.ZTO) THEN
+ DO 123 II = ZTO+1,ISUPMX
+ Z( II, ZINDEX ) = ZERO
+ 123 CONTINUE
+ ENDIF
+ CALL SSCAL( ZTO-ZFROM+1, NRMINV,
+ $ Z( ZFROM, ZINDEX ), 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( SAVEGP,
+ $ W( WINDPL )-WERR( WINDPL )
+ $ - W( WINDEX )-WERR( WINDEX) )
+ ENDIF
+ ENDIF
+ ENDIF
+* here ends the code for the current child
+*
+ 139 CONTINUE
+* Proceed to any remaining child nodes
+ NEWFST = J + 1
+ 140 CONTINUE
+ 150 CONTINUE
+* Store number of clusters
+ IWORK( IINCLS + JBLK ) = NCLUS
+*
+ END IF
+ IBEGIN = IEND + 1
+ WBEGIN = WEND + 1
+ 170 CONTINUE
+*
+* Check if everything is done: no clusters left for
+* this processor in any block
+*
+ FINISH = .TRUE.
+ DO 180 JBLK = 1, IBLOCK( M )
+ FINISH = FINISH .AND. (IWORK(IINCLS + JBLK).EQ.0)
+ 180 CONTINUE
+
+ IF(.NOT.FINISH) THEN
+ NDEPTH = NDEPTH + 1
+ IF((NEEDIL.GE.DOL).AND.(NEEDIU.LE.DOU)) THEN
+* Once this processor's part of the
+* representation tree consists exclusively of eigenvalues
+* between DOL and DOU, it can work independently from all
+* others.
+ GOTO 40
+ ENDIF
+ ENDIF
+*
+
+ RETURN
+*
+* End of SLARRV2
+*
+ END
diff --git a/SRC/spttrsv.f b/SRC/spttrsv.f
index be17bb3..fea6ae4 100644
--- a/SRC/spttrsv.f
+++ b/SRC/spttrsv.f
@@ -1,6 +1,9 @@
SUBROUTINE SPTTRSV( TRANS, N, NRHS, D, E, B, LDB,
$ INFO )
*
+* -- ScaLAPACK auxiliary routine (version 2.0) --
+* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver
+*
* Written by Andrew J. Cleary, University of Tennessee.
* November, 1996.
* Modified from SPTTRS:
diff --git a/SRC/sstegr2.f b/SRC/sstegr2.f
new file mode 100644
index 0000000..3d8e106
--- /dev/null
+++ b/SRC/sstegr2.f
@@ -0,0 +1,522 @@
+ SUBROUTINE SSTEGR2( JOBZ, RANGE, N, D, E, VL, VU, IL, IU,
+ $ M, W, Z, LDZ, NZC, ISUPPZ, WORK, LWORK, IWORK,
+ $ LIWORK, DOL, DOU, ZOFFSET, INFO )
+*
+* -- ScaLAPACK auxiliary routine (version 2.0) --
+* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver
+* July 4, 2010
+*
+* .. Scalar Arguments ..
+ CHARACTER JOBZ, RANGE
+ INTEGER DOL, DOU, IL, INFO, IU,
+ $ LDZ, NZC, LIWORK, LWORK, M, N, ZOFFSET
+ REAL VL, VU
+
+* ..
+* .. Array Arguments ..
+ INTEGER ISUPPZ( * ), IWORK( * )
+ REAL D( * ), E( * ), W( * ), WORK( * )
+ REAL Z( LDZ, * )
+* ..
+*
+* Purpose
+* =======
+*
+* SSTEGR2 computes selected eigenvalues and, optionally, eigenvectors
+* of a real symmetric tridiagonal matrix T. It is invoked in the
+* ScaLAPACK MRRR driver PSSYEVR and the corresponding Hermitian
+* version either when only eigenvalues are to be computed, or when only
+* a single processor is used (the sequential-like case).
+*
+* SSTEGR2 has been adapted from LAPACK's SSTEGR. Please note the
+* following crucial changes.
+*
+* 1. The calling sequence has two additional INTEGER parameters,
+* DOL and DOU, that should satisfy M>=DOU>=DOL>=1.
+* SSTEGR2 ONLY computes the eigenpairs
+* corresponding to eigenvalues DOL through DOU in W. (That is,
+* instead of computing the eigenpairs belonging to W(1)
+* through W(M), only the eigenvectors belonging to eigenvalues
+* W(DOL) through W(DOU) are computed. In this case, only the
+* eigenvalues DOL:DOU are guaranteed to be fully accurate.
+*
+* 2. M is NOT the number of eigenvalues specified by RANGE, but is
+* M = DOU - DOL + 1. This concerns the case where only eigenvalues
+* are computed, but on more than one processor. Thus, in this case
+* M refers to the number of eigenvalues computed on this processor.
+*
+* 3. The arrays W and Z might not contain all the wanted eigenpairs
+* locally, instead this information is distributed over other
+* processors.
+*
+* Arguments
+* =========
+*
+* JOBZ (input) CHARACTER*1
+* = 'N': Compute eigenvalues only;
+* = 'V': Compute eigenvalues and eigenvectors.
+*
+* RANGE (input) CHARACTER*1
+* = 'A': all eigenvalues will be found.
+* = 'V': all eigenvalues in the half-open interval (VL,VU]
+* will be found.
+* = 'I': the IL-th through IU-th eigenvalues will be found.
+*
+* N (input) INTEGER
+* The order of the matrix. N >= 0.
+*
+* D (input/output) REAL array, dimension (N)
+* On entry, the N diagonal elements of the tridiagonal matrix
+* T. On exit, D is overwritten.
+*
+* E (input/output) REAL array, dimension (N)
+* On entry, the (N-1) subdiagonal elements of the tridiagonal
+* matrix T in elements 1 to N-1 of E. E(N) need not be set on
+* input, but is used internally as workspace.
+* On exit, E is overwritten.
+*
+* VL (input) REAL
+* VU (input) REAL
+* If RANGE='V', the lower and upper bounds of the interval to
+* be searched for eigenvalues. VL < VU.
+* Not referenced if RANGE = 'A' or 'I'.
+*
+* IL (input) INTEGER
+* IU (input) INTEGER
+* If RANGE='I', the indices (in ascending order) of the
+* smallest and largest eigenvalues to be returned.
+* 1 <= IL <= IU <= N, if N > 0.
+* Not referenced if RANGE = 'A' or 'V'.
+*
+* M (output) INTEGER
+* Globally summed over all processors, M equals
+* the total number of eigenvalues found. 0 <= M <= N.
+* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.
+* The local output equals M = DOU - DOL + 1.
+*
+* W (output) REAL array, dimension (N)
+* The first M elements contain the selected eigenvalues in
+* ascending order. Note that immediately after exiting this
+* routine, only the eigenvalues from
+* position DOL:DOU are to reliable on this processor
+* because the eigenvalue computation is done in parallel.
+* Other processors will hold reliable information on other
+* parts of the W array. This information is communicated in
+* the ScaLAPACK driver.
+*
+* Z (output) REAL array, dimension (LDZ, max(1,M) )
+* If JOBZ = 'V', and if INFO = 0, then the first M columns of Z
+* contain some of the orthonormal eigenvectors of the matrix T
+* corresponding to the selected eigenvalues, with the i-th
+* column of Z holding the eigenvector associated with W(i).
+* If JOBZ = 'N', then Z is not referenced.
+* Note: the user must ensure that at least max(1,M) columns are
+* supplied in the array Z; if RANGE = 'V', the exact value of M
+* is not known in advance and can be computed with a workspace
+* query by setting NZC = -1, see below.
+*
+* LDZ (input) INTEGER
+* The leading dimension of the array Z. LDZ >= 1, and if
+* JOBZ = 'V', then LDZ >= max(1,N).
+*
+* NZC (input) INTEGER
+* The number of eigenvectors to be held in the array Z.
+* If RANGE = 'A', then NZC >= max(1,N).
+* If RANGE = 'V', then NZC >= the number of eigenvalues in (VL,VU].
+* If RANGE = 'I', then NZC >= IU-IL+1.
+* If NZC = -1, then a workspace query is assumed; the
+* routine calculates the number of columns of the array Z that
+* are needed to hold the eigenvectors.
+* This value is returned as the first entry of the Z array, and
+* no error message related to NZC is issued.
+*
+* ISUPPZ (output) INTEGER ARRAY, dimension ( 2*max(1,M) )
+* The support of the eigenvectors in Z, i.e., the indices
+* indicating the nonzero elements in Z. The i-th computed eigenvector
+* is nonzero only in elements ISUPPZ( 2*i-1 ) through
+* ISUPPZ( 2*i ). This is relevant in the case when the matrix
+* is split. ISUPPZ is only set if N>2.
+*
+* WORK (workspace/output) REAL array, dimension (LWORK)
+* On exit, if INFO = 0, WORK(1) returns the optimal
+* (and minimal) LWORK.
+*
+* LWORK (input) INTEGER
+* The dimension of the array WORK. LWORK >= max(1,18*N)
+* if JOBZ = 'V', and LWORK >= max(1,12*N) if JOBZ = 'N'.
+* If LWORK = -1, then a workspace query is assumed; the routine
+* only calculates the optimal size of the WORK array, returns
+* this value as the first entry of the WORK array, and no error
+* message related to LWORK is issued.
+*
+* IWORK (workspace/output) INTEGER array, dimension (LIWORK)
+* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.
+*
+* LIWORK (input) INTEGER
+* The dimension of the array IWORK. LIWORK >= max(1,10*N)
+* if the eigenvectors are desired, and LIWORK >= max(1,8*N)
+* if only the eigenvalues are to be computed.
+* If LIWORK = -1, then a workspace query is assumed; the
+* routine only calculates the optimal size of the IWORK array,
+* returns this value as the first entry of the IWORK array, and
+* no error message related to LIWORK is issued.
+*
+* DOL (input) INTEGER
+* DOU (input) INTEGER
+* From the eigenvalues W(1:M), only eigenvectors
+* Z(:,DOL) to Z(:,DOU) are computed.
+* If DOL > 1, then Z(:,DOL-1-ZOFFSET) is used and overwritten.
+* If DOU < M, then Z(:,DOU+1-ZOFFSET) is used and overwritten.
+*
+* ZOFFSET (input) INTEGER
+* Offset for storing the eigenpairs when Z is distributed
+* in 1D-cyclic fashion
+*
+* INFO (output) INTEGER
+* On exit, INFO
+* = 0: successful exit
+* other:if INFO = -i, the i-th argument had an illegal value
+* if INFO = 10X, internal error in SLARRE2,
+* if INFO = 20X, internal error in SLARRV.
+* Here, the digit X = ABS( IINFO ) < 10, where IINFO is
+* the nonzero error code returned by SLARRE2 or
+* SLARRV, respectively.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ZERO, ONE, FOUR, MINRGP
+ PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0,
+ $ FOUR = 4.0E0,
+ $ MINRGP = 3.0E-3 )
+* ..
+* .. Local Scalars ..
+ LOGICAL ALLEIG, INDEIG, LQUERY, VALEIG, WANTZ, ZQUERY
+ INTEGER I, IIL, IINDBL, IINDW, IINDWK, IINFO, IINSPL,
+ $ IIU, INDE2, INDERR, INDGP, INDGRS, INDWRK,
+ $ ITMP, ITMP2, J, JJ, LIWMIN, LWMIN, NSPLIT,
+ $ NZCMIN
+ REAL BIGNUM, EPS, PIVMIN, RMAX, RMIN, RTOL1, RTOL2,
+ $ SAFMIN, SCALE, SMLNUM, THRESH, TMP, TNRM, WL,
+ $ WU
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ REAL SLAMCH, SLANST
+ EXTERNAL LSAME, SLAMCH, SLANST
+* ..
+* .. External Subroutines ..
+ EXTERNAL SCOPY, SLAE2, SLAEV2, SLARRC, SLARRE2,
+ $ SLARRV, SLASRT, SSCAL, SSWAP
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, MIN, REAL, 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 )
+
+* SSTEGR2 needs WORK of size 6*N, IWORK of size 3*N.
+* In addition, SLARRE2 needs WORK of size 6*N, IWORK of size 5*N.
+* Furthermore, SLARRV needs WORK of size 12*N, IWORK of size 7*N.
+ IF( WANTZ ) 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
+
+ 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 SLARRE2.
+ 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 = SLAMCH( 'Safe minimum' )
+ EPS = SLAMCH( '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
+ IIL = 1
+ IIU = N
+ ELSE IF( WANTZ .AND. VALEIG ) THEN
+ CALL SLARRC( 'T', N, VL, VU, D, E, SAFMIN,
+ $ NZCMIN, ITMP, ITMP2, INFO )
+ IIL = ITMP+1
+ IIU = ITMP2
+ 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 ( WANTZ ) THEN
+ IF ( DOL.LT.1 .OR. DOL.GT.NZCMIN ) THEN
+ INFO = -20
+ ENDIF
+ IF ( DOU.LT.1 .OR. DOU.GT.NZCMIN .OR. DOU.LT.DOL) THEN
+ INFO = -21
+ ENDIF
+ ENDIF
+
+ IF( INFO.NE.0 ) THEN
+*
+C Disable sequential error handler
+C for parallel case
+C CALL XERBLA( 'SSTEGR2', -INFO )
+*
+ RETURN
+ ELSE IF( LQUERY .OR. ZQUERY ) 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( WL.LT.D( 1 ) .AND. WU.GE.D( 1 ) ) THEN
+ M = 1
+ W( 1 ) = D( 1 )
+ END IF
+ END IF
+ IF( WANTZ )
+ $ Z( 1, 1 ) = ONE
+ RETURN
+ END IF
+*
+ INDGRS = 1
+ INDERR = 2*N + 1
+ INDGP = 3*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.
+*
+ SCALE = ONE
+ TNRM = SLANST( '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 SSCAL( N, SCALE, D, 1 )
+ CALL SSCAL( 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 SLARRE2
+* 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.
+*
+ IINFO = -1
+* Set the splitting criterion
+ IF (IINFO.EQ.0) THEN
+ THRESH = EPS
+ ELSE
+ THRESH = -EPS
+ 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
+* SLARRE2 computes the eigenvalues to full precision.
+ RTOL1 = FOUR * EPS
+ RTOL2 = FOUR * EPS
+ ELSE
+* SLARRE2 computes the eigenvalues to less than full precision.
+* SLARRV will refine the eigenvalue approximations, and we can
+* need less accurate initial bisection in SLARRE2.
+* Note: these settings do only affect the subset case and SLARRE2
+ RTOL1 = SQRT(EPS)
+ RTOL2 = MAX( SQRT(EPS)*5.0E-3, FOUR * EPS )
+ ENDIF
+ CALL SLARRE2( RANGE, N, WL, WU, IIL, IIU, D, E,
+ $ WORK(INDE2), RTOL1, RTOL2, THRESH, NSPLIT,
+ $ IWORK( IINSPL ), M, DOL, DOU,
+ $ W, WORK( INDERR ),
+ $ WORK( INDGP ), IWORK( IINDBL ),
+ $ IWORK( IINDW ), WORK( INDGRS ), PIVMIN,
+ $ WORK( INDWRK ), IWORK( IINDWK ), IINFO )
+ IF( IINFO.NE.0 ) THEN
+ INFO = 100 + ABS( IINFO )
+ RETURN
+ END IF
+* Note that if RANGE .NE. 'V', SLARRE2 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 SLARRV( N, WL, WU, D, E,
+ $ PIVMIN, IWORK( IINSPL ), M,
+ $ DOL, DOU, 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 = 200 + ABS( IINFO )
+ RETURN
+ END IF
+ ELSE
+* SLARRE2 computes eigenvalues of the (shifted) root representation
+* SLARRV returns the eigenvalues of the unshifted matrix.
+* However, if the eigenvectors are not desired by the user, we need
+* to apply the corresponding shifts from SLARRE2 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 matrix was scaled, then rescale eigenvalues appropriately.
+*
+ IF( SCALE.NE.ONE ) THEN
+ CALL SSCAL( M, ONE / SCALE, W, 1 )
+ END IF
+*
+* Correct M if needed
+*
+ IF ( WANTZ ) THEN
+ IF( DOL.NE.1 .OR. DOU.NE.M ) THEN
+ M = DOU - DOL +1
+ ENDIF
+ ENDIF
+*
+* If eigenvalues are not in increasing order, then sort them,
+* possibly along with eigenvectors.
+*
+ IF( NSPLIT.GT.1 ) THEN
+ IF( .NOT. WANTZ ) THEN
+ CALL SLASRT( 'I', DOU - DOL +1, W(DOL), IINFO )
+ IF( IINFO.NE.0 ) THEN
+ INFO = 3
+ RETURN
+ END IF
+ ELSE
+ DO 60 J = DOL, DOU - 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 SSWAP( N, Z( 1, I-ZOFFSET ),
+ $ 1, Z( 1, J-ZOFFSET ), 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 SSTEGR2
+*
+ END
diff --git a/SRC/sstegr2a.f b/SRC/sstegr2a.f
new file mode 100644
index 0000000..779a176
--- /dev/null
+++ b/SRC/sstegr2a.f
@@ -0,0 +1,465 @@
+ SUBROUTINE SSTEGR2A( JOBZ, RANGE, N, D, E, VL, VU, IL, IU,
+ $ M, W, Z, LDZ, NZC, WORK, LWORK, IWORK,
+ $ LIWORK, DOL, DOU, NEEDIL, NEEDIU,
+ $ INDERR, NSPLIT, PIVMIN, SCALE, WL, WU,
+ $ INFO )
+*
+* -- ScaLAPACK auxiliary routine (version 2.0) --
+* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver
+* July 4, 2010
+*
+ IMPLICIT NONE
+*
+* .. Scalar Arguments ..
+ CHARACTER JOBZ, RANGE
+ INTEGER DOL, DOU, IL, INDERR, INFO, IU, LDZ, LIWORK,
+ $ LWORK, M, N, NEEDIL, NEEDIU, NSPLIT, NZC
+ REAL PIVMIN, SCALE, VL, VU, WL, WU
+
+* ..
+* .. Array Arguments ..
+ INTEGER IWORK( * )
+ REAL D( * ), E( * ), W( * ), WORK( * )
+ REAL Z( LDZ, * )
+* ..
+*
+* Purpose
+* =======
+*
+* SSTEGR2A computes selected eigenvalues and initial representations.
+* needed for eigenvector computations in SSTEGR2B. It is invoked in the
+* ScaLAPACK MRRR driver PSSYEVR and the corresponding Hermitian
+* version when both eigenvalues and eigenvectors are computed in parallel.
+* on multiple processors. For this case, SSTEGR2A implements the FIRST
+* part of the MRRR algorithm, parallel eigenvalue computation and finding
+* the root RRR. At the end of SSTEGR2A,
+* other processors might have a part of the spectrum that is needed to
+* continue the computation locally. Once this eigenvalue information has
+* been received by the processor, the computation can then proceed by calling
+* the SECOND part of the parallel MRRR algorithm, SSTEGR2B.
+*
+* Please note:
+* 1. The calling sequence has two additional INTEGER parameters,
+* (compared to LAPACK's SSTEGR), these are
+* DOL and DOU and should satisfy M>=DOU>=DOL>=1.
+* These parameters are only relevant for the case JOBZ = 'V'.
+*
+* Globally invoked over all processors, SSTEGR2A computes
+* ALL the eigenVALUES specified by RANGE.
+* RANGE= 'A': all eigenvalues will be found.
+* = 'V': all eigenvalues in (VL,VU] will be found.
+* = 'I': the IL-th through IU-th eigenvalues will be found.
+*
+* SSTEGR2A LOCALLY only computes the eigenvalues
+* corresponding to eigenvalues DOL through DOU in W. (That is,
+* instead of computing the eigenvectors belonging to W(1)
+* through W(M), only the eigenvectors belonging to eigenvalues
+* W(DOL) through W(DOU) are computed. In this case, only the
+* eigenvalues DOL:DOU are guaranteed to be fully accurate.
+*
+* 2. M is NOT the number of eigenvalues specified by RANGE, but it is
+* M = DOU - DOL + 1. Instead, M refers to the number of eigenvalues computed on
+* this processor.
+*
+* 3. While no eigenvectors are computed in SSTEGR2A itself (this is
+* done later in SSTEGR2B), the interface
+* If JOBZ = 'V' then, depending on RANGE and DOL, DOU, SSTEGR2A
+* might need more workspace in Z then the original SSTEGR.
+* In particular, the arrays W and Z might not contain all the wanted eigenpairs
+* locally, instead this information is distributed over other
+* processors.
+*
+* Arguments
+* =========
+*
+* JOBZ (input) CHARACTER*1
+* = 'N': Compute eigenvalues only;
+* = 'V': Compute eigenvalues and eigenvectors.
+*
+* RANGE (input) CHARACTER*1
+* = 'A': all eigenvalues will be found.
+* = 'V': all eigenvalues in the half-open interval (VL,VU]
+* will be found.
+* = 'I': the IL-th through IU-th eigenvalues will be found.
+*
+* N (input) INTEGER
+* The order of the matrix. N >= 0.
+*
+* D (input/output) REAL array, dimension (N)
+* On entry, the N diagonal elements of the tridiagonal matrix
+* T. On exit, D is overwritten.
+*
+* E (input/output) REAL array, dimension (N)
+* On entry, the (N-1) subdiagonal elements of the tridiagonal
+* matrix T in elements 1 to N-1 of E. E(N) need not be set on
+* input, but is used internally as workspace.
+* On exit, E is overwritten.
+*
+* VL (input) REAL
+* VU (input) REAL
+* If RANGE='V', the lower and upper bounds of the interval to
+* be searched for eigenvalues. VL < VU.
+* Not referenced if RANGE = 'A' or 'I'.
+*
+* IL (input) INTEGER
+* IU (input) INTEGER
+* If RANGE='I', the indices (in ascending order) of the
+* smallest and largest eigenvalues to be returned.
+* 1 <= IL <= IU <= N, if N > 0.
+* Not referenced if RANGE = 'A' or 'V'.
+*
+* M (output) INTEGER
+* Globally summed over all processors, M equals
+* the total number of eigenvalues found. 0 <= M <= N.
+* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.
+* The local output equals M = DOU - DOL + 1.
+*
+* W (output) REAL array, dimension (N)
+* The first M elements contain approximations to the selected
+* eigenvalues in ascending order. Note that immediately after
+* exiting this routine, only the eigenvalues from
+* position DOL:DOU are to reliable on this processor
+* because the eigenvalue computation is done in parallel.
+* The other entries outside DOL:DOU are very crude preliminary
+* approximations. Other processors hold reliable information on
+* these other parts of the W array.
+* This information is communicated in the ScaLAPACK driver.
+*
+* Z (output) REAL array, dimension (LDZ, max(1,M) )
+* SSTEGR2A does not compute eigenvectors, this is done
+* in SSTEGR2B. The argument Z as well as all related
+* other arguments only appear to keep the interface consistent
+* and to signal to the user that this subroutine is meant to
+* be used when eigenvectors are computed.
+*
+* LDZ (input) INTEGER
+* The leading dimension of the array Z. LDZ >= 1, and if
+* JOBZ = 'V', then LDZ >= max(1,N).
+*
+* NZC (input) INTEGER
+* The number of eigenvectors to be held in the array Z.
+* If RANGE = 'A', then NZC >= max(1,N).
+* If RANGE = 'V', then NZC >= the number of eigenvalues in (VL,VU].
+* If RANGE = 'I', then NZC >= IU-IL+1.
+* If NZC = -1, then a workspace query is assumed; the
+* routine calculates the number of columns of the array Z that
+* are needed to hold the eigenvectors.
+* This value is returned as the first entry of the Z array, and
+* no error message related to NZC is issued.
+*
+* WORK (workspace/output) REAL array, dimension (LWORK)
+* On exit, if INFO = 0, WORK(1) returns the optimal
+* (and minimal) LWORK.
+*
+* LWORK (input) INTEGER
+* The dimension of the array WORK. LWORK >= max(1,18*N)
+* if JOBZ = 'V', and LWORK >= max(1,12*N) if JOBZ = 'N'.
+* If LWORK = -1, then a workspace query is assumed; the routine
+* only calculates the optimal size of the WORK array, returns
+* this value as the first entry of the WORK array, and no error
+* message related to LWORK is issued.
+*
+* IWORK (workspace/output) INTEGER array, dimension (LIWORK)
+* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.
+*
+* LIWORK (input) INTEGER
+* The dimension of the array IWORK. LIWORK >= max(1,10*N)
+* if the eigenvectors are desired, and LIWORK >= max(1,8*N)
+* if only the eigenvalues are to be computed.
+* If LIWORK = -1, then a workspace query is assumed; the
+* routine only calculates the optimal size of the IWORK array,
+* returns this value as the first entry of the IWORK array, and
+* no error message related to LIWORK is issued.
+*
+* DOL (input) INTEGER
+* DOU (input) INTEGER
+* From all the eigenvalues W(1:M), only eigenvalues
+* W(DOL:DOU) are computed.
+*
+* NEEDIL (output) INTEGER
+* NEEDIU (output) INTEGER
+* The indices of the leftmost and rightmost eigenvalues
+* needed to accurately compute the relevant part of the
+* representation tree. This information can be used to
+* find out which processors have the relevant eigenvalue
+* information needed so that it can be communicated.
+*
+* INDERR (output) INTEGER
+* INDERR points to the place in the work space where
+* the eigenvalue uncertainties (errors) are stored.
+*
+* NSPLIT (output) INTEGER
+* The number of blocks T splits into. 1 <= NSPLIT <= N.
+*
+* PIVMIN (output) REAL
+* The minimum pivot in the sturm sequence for T.
+*
+* SCALE (output) REAL
+* The scaling factor for the tridiagonal T.
+*
+* WL (output) REAL
+* WU (output) REAL
+* The interval (WL, WU] contains all the wanted eigenvalues.
+* It is either given by the user or computed in SLARRE2A.
+*
+* INFO (output) INTEGER
+* On exit, INFO
+* = 0: successful exit
+* other:if INFO = -i, the i-th argument had an illegal value
+* if INFO = 10X, internal error in SLARRE2A,
+* Here, the digit X = ABS( IINFO ) < 10, where IINFO is
+* the nonzero error code returned by SLARRE2A.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ZERO, ONE, FOUR, MINRGP
+ PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0,
+ $ FOUR = 4.0E0,
+ $ MINRGP = 3.0E-3 )
+* ..
+* .. Local Scalars ..
+ LOGICAL ALLEIG, INDEIG, LQUERY, VALEIG, WANTZ, ZQUERY
+ INTEGER IIL, IINDBL, IINDW, IINDWK, IINFO, IINSPL, IIU,
+ $ INDE2, INDGP, INDGRS, INDSDM, INDWRK, ITMP,
+ $ ITMP2, J, LIWMIN, LWMIN, NZCMIN
+ REAL BIGNUM, EPS, RMAX, RMIN, RTOL1, RTOL2, SAFMIN,
+ $ SMLNUM, THRESH, TNRM
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ REAL SLAMCH, SLANST
+ EXTERNAL LSAME, SLAMCH, SLANST
+* ..
+* .. External Subroutines ..
+ EXTERNAL SLARRC, SLARRE2A, SSCAL
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, MIN, REAL, 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 )
+
+* SSTEGR2A needs WORK of size 6*N, IWORK of size 3*N.
+* In addition, SLARRE2A needs WORK of size 6*N, IWORK of size 5*N.
+* Furthermore, SLARRV2 needs WORK of size 12*N, IWORK of size 7*N.
+* Workspace is kept consistent with SSTEGR2B even though
+* SLARRV2 is not called here.
+ 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
+
+ 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 SLARRE2A.
+ 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 = SLAMCH( 'Safe minimum' )
+ EPS = SLAMCH( '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
+ IIL = 1
+ IIU = N
+ ELSE IF( WANTZ .AND. VALEIG ) THEN
+ CALL SLARRC( 'T', N, VL, VU, D, E, SAFMIN,
+ $ NZCMIN, ITMP, ITMP2, INFO )
+ IIL = ITMP+1
+ IIU = ITMP2
+ 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 ( WANTZ ) THEN
+ IF ( DOL.LT.1 .OR. DOL.GT.NZCMIN ) THEN
+ INFO = -20
+ ENDIF
+ IF ( DOU.LT.1 .OR. DOU.GT.NZCMIN .OR. DOU.LT.DOL) THEN
+ INFO = -21
+ ENDIF
+ ENDIF
+
+ IF( INFO.NE.0 ) THEN
+*
+C Disable sequential error handler
+C for parallel case
+C CALL XERBLA( 'SSTEGR2A', -INFO )
+*
+ RETURN
+ ELSE IF( LQUERY .OR. ZQUERY ) THEN
+ RETURN
+ END IF
+
+* Initialize NEEDIL and NEEDIU, these values are changed in SLARRE2A
+ NEEDIL = DOU
+ NEEDIU = DOL
+*
+* 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( WL.LT.D( 1 ) .AND. WU.GE.D( 1 ) ) THEN
+ M = 1
+ W( 1 ) = D( 1 )
+ END IF
+ END IF
+ IF( WANTZ )
+ $ Z( 1, 1 ) = ONE
+ RETURN
+ END IF
+*
+ INDGRS = 1
+ INDERR = 2*N + 1
+ INDGP = 3*N + 1
+ INDSDM = 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.
+*
+ SCALE = ONE
+ TNRM = SLANST( '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 SSCAL( N, SCALE, D, 1 )
+ CALL SSCAL( 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 SLARRA in SLARRE2A
+* A negative THRESH forces the old splitting criterion based on the
+* size of the off-diagonal.
+ THRESH = -EPS
+ IINFO = 0
+
+* 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
+* SLARRE2A computes the eigenvalues to full precision.
+ RTOL1 = FOUR * EPS
+ RTOL2 = FOUR * EPS
+ ELSE
+* SLARRE2A computes the eigenvalues to less than full precision.
+* SLARRV2 will refine the eigenvalue approximations, and we can
+* need less accurate initial bisection in SLARRE2A.
+ RTOL1 = FOUR*SQRT(EPS)
+ RTOL2 = MAX( SQRT(EPS)*5.0E-3, FOUR * EPS )
+ ENDIF
+ CALL SLARRE2A( RANGE, N, WL, WU, IIL, IIU, D, E,
+ $ WORK(INDE2), RTOL1, RTOL2, THRESH, NSPLIT,
+ $ IWORK( IINSPL ), M, DOL, DOU, NEEDIL, NEEDIU,
+ $ W, WORK( INDERR ),
+ $ WORK( INDGP ), IWORK( IINDBL ),
+ $ IWORK( IINDW ), WORK( INDGRS ),
+ $ WORK( INDSDM ), PIVMIN,
+ $ WORK( INDWRK ), IWORK( IINDWK ),
+ $ MINRGP, IINFO )
+ IF( IINFO.NE.0 ) THEN
+ INFO = 100 + ABS( IINFO )
+ RETURN
+ END IF
+* Note that if RANGE .NE. 'V', SLARRE2A computes bounds on the desired
+* part of the spectrum. All desired eigenvalues are contained in
+* (WL,WU]
+
+
+ RETURN
+*
+* End of SSTEGR2A
+*
+ END
diff --git a/SRC/sstegr2b.f b/SRC/sstegr2b.f
new file mode 100644
index 0000000..f59b3c9
--- /dev/null
+++ b/SRC/sstegr2b.f
@@ -0,0 +1,345 @@
+ SUBROUTINE SSTEGR2B( JOBZ, N, D, E,
+ $ M, W, Z, LDZ, NZC, ISUPPZ, WORK, LWORK, IWORK,
+ $ LIWORK, DOL, DOU, NEEDIL, NEEDIU,
+ $ INDWLC, PIVMIN, SCALE, WL, WU,
+ $ VSTART, FINISH, MAXCLS,
+ $ NDEPTH, PARITY, ZOFFSET, INFO )
+*
+* -- ScaLAPACK auxiliary routine (version 2.0) --
+* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver
+* July 4, 2010
+*
+ IMPLICIT NONE
+*
+* .. Scalar Arguments ..
+ CHARACTER JOBZ
+ INTEGER DOL, DOU, INDWLC, INFO, LDZ, LIWORK, LWORK, M,
+ $ MAXCLS, N, NDEPTH, NEEDIL, NEEDIU, NZC, PARITY,
+ $ ZOFFSET
+
+ REAL PIVMIN, SCALE, WL, WU
+ LOGICAL VSTART, FINISH
+
+* ..
+* .. Array Arguments ..
+ INTEGER ISUPPZ( * ), IWORK( * )
+ REAL D( * ), E( * ), W( * ), WORK( * )
+ REAL Z( LDZ, * )
+* ..
+*
+* Purpose
+* =======
+*
+* SSTEGR2B should only be called after a call to SSTEGR2A.
+* From eigenvalues and initial representations computed by SSTEGR2A,
+* SSTEGR2B computes the selected eigenvalues and eigenvectors
+* of the real symmetric tridiagonal matrix in parallel
+* on multiple processors. It is potentially invoked multiple times
+* on a given processor because the locally relevant representation tree
+* might depend on spectral information that is "owned" by other processors
+* and might need to be communicated.
+*
+* Please note:
+* 1. The calling sequence has two additional INTEGER parameters,
+* DOL and DOU, that should satisfy M>=DOU>=DOL>=1.
+* These parameters are only relevant for the case JOBZ = 'V'.
+* SSTEGR2B ONLY computes the eigenVECTORS
+* corresponding to eigenvalues DOL through DOU in W. (That is,
+* instead of computing the eigenvectors belonging to W(1)
+* through W(M), only the eigenvectors belonging to eigenvalues
+* W(DOL) through W(DOU) are computed. In this case, only the
+* eigenvalues DOL:DOU are guaranteed to be accurately refined
+* to all figures by Rayleigh-Quotient iteration.
+*
+* 2. The additional arguments VSTART, FINISH, NDEPTH, PARITY, ZOFFSET
+* are included as a thread-safe implementation equivalent to SAVE variables.
+* These variables store details about the local representation tree which is
+* computed layerwise. For scalability reasons, eigenvalues belonging to the
+* locally relevant representation tree might be computed on other processors.
+* These need to be communicated before the inspection of the RRRs can proceed
+* on any given layer.
+* Note that only when the variable FINISH is true, the computation has ended
+* All eigenpairs between DOL and DOU have been computed. M is set = DOU - DOL + 1.
+*
+* 3. SSTEGR2B needs more workspace in Z than the sequential SSTEGR.
+* It is used to store the conformal embedding of the local representation tree.
+*
+* Arguments
+* =========
+*
+* JOBZ (input) CHARACTER*1
+* = 'N': Compute eigenvalues only;
+* = 'V': Compute eigenvalues and eigenvectors.
+*
+* N (input) INTEGER
+* The order of the matrix. N >= 0.
+*
+* D (input/output) REAL array, dimension (N)
+* On entry, the N diagonal elements of the tridiagonal matrix
+* T. On exit, D is overwritten.
+*
+* E (input/output) REAL array, dimension (N)
+* On entry, the (N-1) subdiagonal elements of the tridiagonal
+* matrix T in elements 1 to N-1 of E. E(N) need not be set on
+* input, but is used internally as workspace.
+* On exit, E is overwritten.
+*
+* M (input) INTEGER
+* The total number of eigenvalues found
+* in SSTEGR2A. 0 <= M <= N.
+*
+* W (input) REAL array, dimension (N)
+* The first M elements contain approximations to the selected
+* eigenvalues in ascending order. Note that only the eigenvalues from
+* the locally relevant part of the representation tree, that is
+* all the clusters that include eigenvalues from DOL:DOU, are reliable
+* on this processor. (It does not need to know about any others anyway.)
+*
+* Z (output) REAL array, dimension (LDZ, max(1,M) )
+* If JOBZ = 'V', and if INFO = 0, then
+* a subset of 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).
+* See DOL, DOU for more information.
+*
+* LDZ (input) INTEGER
+* The leading dimension of the array Z. LDZ >= 1, and if
+* JOBZ = 'V', then LDZ >= max(1,N).
+*
+* NZC (input) INTEGER
+* The number of eigenvectors to be held in the array Z.
+*
+* ISUPPZ (output) INTEGER ARRAY, dimension ( 2*max(1,M) )
+* The support of the eigenvectors in Z, i.e., the indices
+* indicating the nonzero elements in Z. The i-th computed eigenvector
+* is nonzero only in elements ISUPPZ( 2*i-1 ) through
+* ISUPPZ( 2*i ). This is relevant in the case when the matrix
+* is split. ISUPPZ is only set if N>2.
+*
+* WORK (workspace/output) REAL array, dimension (LWORK)
+* On exit, if INFO = 0, WORK(1) returns the optimal
+* (and minimal) LWORK.
+*
+* LWORK (input) INTEGER
+* The dimension of the array WORK. LWORK >= max(1,18*N)
+* if JOBZ = 'V', and LWORK >= max(1,12*N) if JOBZ = 'N'.
+* If LWORK = -1, then a workspace query is assumed; the routine
+* only calculates the optimal size of the WORK array, returns
+* this value as the first entry of the WORK array, and no error
+* message related to LWORK is issued.
+*
+* IWORK (workspace/output) INTEGER array, dimension (LIWORK)
+* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.
+*
+* LIWORK (input) INTEGER
+* The dimension of the array IWORK. LIWORK >= max(1,10*N)
+* if the eigenvectors are desired, and LIWORK >= max(1,8*N)
+* if only the eigenvalues are to be computed.
+* If LIWORK = -1, then a workspace query is assumed; the
+* routine only calculates the optimal size of the IWORK array,
+* returns this value as the first entry of the IWORK array, and
+* no error message related to LIWORK is issued.
+*
+* DOL (input) INTEGER
+* DOU (input) INTEGER
+* From the eigenvalues W(1:M), only eigenvectors
+* Z(:,DOL) to Z(:,DOU) are computed.
+* If DOL > 1, then Z(:,DOL-1-ZOFFSET) is used and overwritten.
+* If DOU < M, then Z(:,DOU+1-ZOFFSET) is used and overwritten.
+*
+* NEEDIL (input/output) INTEGER
+* NEEDIU (input/output) INTEGER
+* Describes which are the left and right outermost eigenvalues
+* still to be computed. Initially computed by SLARRE2A,
+* modified in the course of the algorithm.
+*
+* INDWLC (output) REAL
+* Pointer into the workspace, location where the local
+* eigenvalue representations are stored. ("Local eigenvalues"
+* are those relative to the individual shifts of the RRRs.)
+*
+* PIVMIN (input) REAL
+* The minimum pivot in the sturm sequence for T.
+*
+* SCALE (input) REAL
+* The scaling factor for T. Used for unscaling the eigenvalues
+* at the very end of the algorithm.
+*
+* WL (input) REAL
+* WU (input) REAL
+* The interval (WL, WU] contains all the wanted eigenvalues.
+*
+* VSTART (input/output) LOGICAL
+* .TRUE. on initialization, set to .FALSE. afterwards.
+*
+* FINISH (input/output) LOGICAL
+* indicates whether all eigenpairs have been computed
+*
+* MAXCLS (input/output) INTEGER
+* The largest cluster worked on by this processor in the
+* representation tree.
+*
+* NDEPTH (input/output) INTEGER
+* The current depth of the representation tree. Set to
+* zero on initial pass, changed when the deeper levels of
+* the representation tree are generated.
+*
+* PARITY (input/output) INTEGER
+* An internal parameter needed for the storage of the
+* clusters on the current level of the representation tree.
+*
+* ZOFFSET (input) INTEGER
+* Offset for storing the eigenpairs when Z is distributed
+* in 1D-cyclic fashion
+*
+* INFO (output) INTEGER
+* On exit, INFO
+* = 0: successful exit
+* other:if INFO = -i, the i-th argument had an illegal value
+* if INFO = 20X, internal error in SLARRV2.
+* Here, the digit X = ABS( IINFO ) < 10, where IINFO is
+* the nonzero error code returned by SLARRV2.
+*
+* .. Parameters ..
+ REAL ONE, FOUR, MINRGP
+ PARAMETER ( ONE = 1.0E0,
+ $ FOUR = 4.0E0,
+ $ MINRGP = 3.0E-3 )
+* ..
+* .. Local Scalars ..
+ LOGICAL LQUERY, WANTZ, ZQUERY
+ INTEGER IINDBL, IINDW, IINDWK, IINFO, IINSPL, INDERR,
+ $ INDGP, INDGRS, INDSDM, INDWRK, ITMP, J, LIWMIN,
+ $ LWMIN
+ REAL EPS, RTOL1, RTOL2
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ REAL SLAMCH, SLANST
+ EXTERNAL LSAME, SLAMCH, SLANST
+* ..
+* .. External Subroutines ..
+ EXTERNAL SLARRV2, SSCAL
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, MIN, REAL, SQRT
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ WANTZ = LSAME( JOBZ, 'V' )
+*
+ LQUERY = ( ( LWORK.EQ.-1 ).OR.( LIWORK.EQ.-1 ) )
+ ZQUERY = ( NZC.EQ.-1 )
+
+* SSTEGR2B needs WORK of size 6*N, IWORK of size 3*N.
+* In addition, SLARRE2A needed WORK of size 6*N, IWORK of size 5*N.
+* Workspace is kept consistent even though SLARRE2A is not called here.
+* Furthermore, SLARRV2 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
+*
+ INFO = 0
+*
+* Get machine constants.
+*
+ EPS = SLAMCH( 'Precision' )
+*
+ IF( (N.EQ.0).OR.(N.EQ.1) ) THEN
+ FINISH = .TRUE.
+ RETURN
+ ENDIF
+
+ IF(ZQUERY.OR.LQUERY)
+ $ RETURN
+*
+ INDGRS = 1
+ INDERR = 2*N + 1
+ INDGP = 3*N + 1
+ INDSDM = 4*N + 1
+ INDWRK = 6*N + 1
+ INDWLC = INDWRK
+*
+ IINSPL = 1
+ IINDBL = N + 1
+ IINDW = 2*N + 1
+ IINDWK = 3*N + 1
+
+* Set the tolerance parameters for bisection
+ RTOL1 = FOUR*SQRT(EPS)
+ RTOL2 = MAX( SQRT(EPS)*5.0E-3, FOUR * EPS )
+
+
+ IF( WANTZ ) THEN
+*
+* Compute the desired eigenvectors corresponding to the computed
+* eigenvalues
+*
+ CALL SLARRV2( N, WL, WU, D, E,
+ $ PIVMIN, IWORK( IINSPL ), M,
+ $ DOL, DOU, NEEDIL, NEEDIU, MINRGP, RTOL1, RTOL2,
+ $ W, WORK( INDERR ), WORK( INDGP ), IWORK( IINDBL ),
+ $ IWORK( IINDW ), WORK( INDGRS ),
+ $ WORK( INDSDM ), Z, LDZ,
+ $ ISUPPZ, WORK( INDWRK ), IWORK( IINDWK ),
+ $ VSTART, FINISH,
+ $ MAXCLS, NDEPTH, PARITY, ZOFFSET, IINFO )
+ IF( IINFO.NE.0 ) THEN
+ INFO = 200 + ABS( IINFO )
+ RETURN
+ END IF
+*
+ ELSE
+* SLARRE2A computed eigenvalues of the (shifted) root representation
+* SLARRV2 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 SLARRE2A to obtain the
+* eigenvalues of the original matrix.
+ DO 30 J = 1, M
+ ITMP = IWORK( IINDBL+J-1 )
+ W( J ) = W( J ) + E( IWORK( IINSPL+ITMP-1 ) )
+ 30 CONTINUE
+*
+ FINISH = .TRUE.
+*
+ END IF
+*
+
+ IF(FINISH) THEN
+* All eigenpairs have been computed
+
+*
+* If matrix was scaled, then rescale eigenvalues appropriately.
+*
+ IF( SCALE.NE.ONE ) THEN
+ CALL SSCAL( M, ONE / SCALE, W, 1 )
+ END IF
+*
+* Correct M if needed
+*
+ IF ( WANTZ ) THEN
+ IF( DOL.NE.1 .OR. DOU.NE.M ) THEN
+ M = DOU - DOL +1
+ ENDIF
+ ENDIF
+*
+* No sorting of eigenpairs is done here, done later in the
+* calling subroutine
+*
+ WORK( 1 ) = LWMIN
+ IWORK( 1 ) = LIWMIN
+ ENDIF
+
+ RETURN
+*
+* End of SSTEGR2B
+*
+ END
diff --git a/SRC/zdbtf2.f b/SRC/zdbtf2.f
index d87e6c5..9fa2a2b 100644
--- a/SRC/zdbtf2.f
+++ b/SRC/zdbtf2.f
@@ -1,5 +1,8 @@
SUBROUTINE ZDBTF2( M, N, KL, KU, AB, LDAB, INFO )
*
+* -- ScaLAPACK auxiliary routine (version 2.0) --
+* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver
+*
* Modified by Andrew J. Cleary in November, 96 from:
* -- LAPACK auxiliary routine (preliminary version) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
diff --git a/SRC/zdbtrf.f b/SRC/zdbtrf.f
index 6b75416..21a80be 100644
--- a/SRC/zdbtrf.f
+++ b/SRC/zdbtrf.f
@@ -1,5 +1,8 @@
SUBROUTINE ZDBTRF( M, N, KL, KU, AB, LDAB, INFO )
*
+* -- ScaLAPACK auxiliary routine (version 2.0) --
+* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver
+*
* Written by Andrew J. Cleary, University of Tennessee.
* August, 1996.
* Modified from ZGBTRF:
diff --git a/SRC/zdttrf.f b/SRC/zdttrf.f
index 4f9816d..f3bcc7a 100644
--- a/SRC/zdttrf.f
+++ b/SRC/zdttrf.f
@@ -1,5 +1,8 @@
SUBROUTINE ZDTTRF( N, DL, D, DU, INFO )
*
+* -- ScaLAPACK auxiliary routine (version 2.0) --
+* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver
+*
* Written by Andrew J. Cleary, November 1996.
* Modified from ZGTTRF:
* -- LAPACK routine (preliminary version) --
diff --git a/SRC/zdttrsv.f b/SRC/zdttrsv.f
index 63ebe02..d98e8df 100644
--- a/SRC/zdttrsv.f
+++ b/SRC/zdttrsv.f
@@ -1,6 +1,9 @@
SUBROUTINE ZDTTRSV( UPLO, TRANS, N, NRHS, DL, D, DU,
$ B, LDB, INFO )
*
+* -- ScaLAPACK auxiliary routine (version 2.0) --
+* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver
+*
* Written by Andrew J. Cleary, University of Tennessee.
* August, 1996.
* Modified from ZGTTRS:
diff --git a/SRC/zlamov.c b/SRC/zlamov.c
new file mode 100644
index 0000000..a35121a
--- /dev/null
+++ b/SRC/zlamov.c
@@ -0,0 +1,11 @@
+//
+// zlamov.c
+//
+// Written by Lee Killough 04/19/2012
+//
+
+#define TYPE complex16
+#define FUNC "ZLAMOV"
+#define LAMOV zlamov_
+#define LACPY zlacpy_
+#include "lamov.h"
diff --git a/SRC/zpttrsv.f b/SRC/zpttrsv.f
index 25e4795..ce4520b 100644
--- a/SRC/zpttrsv.f
+++ b/SRC/zpttrsv.f
@@ -1,6 +1,9 @@
SUBROUTINE ZPTTRSV( UPLO, TRANS, N, NRHS, D, E, B, LDB,
$ INFO )
*
+* -- ScaLAPACK auxiliary routine (version 2.0) --
+* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver
+*
* Written by Andrew J. Cleary, University of Tennessee.
* November, 1996.
* Modified from ZPTTRS:
diff --git a/TESTING/CMakeLists.txt b/TESTING/CMakeLists.txt
new file mode 100644
index 0000000..2a17ce1
--- /dev/null
+++ b/TESTING/CMakeLists.txt
@@ -0,0 +1,110 @@
+add_subdirectory(LIN)
+add_subdirectory(EIG)
+
+set(CMAKE_RUNTIME_OUTPUT_DIRECTORY ${SCALAPACK_BINARY_DIR}/TESTING)
+
+file(COPY BLLT.dat DESTINATION ${CMAKE_RUNTIME_OUTPUT_DIRECTORY})
+file(COPY BLU.dat DESTINATION ${CMAKE_RUNTIME_OUTPUT_DIRECTORY})
+file(COPY BRD.dat DESTINATION ${CMAKE_RUNTIME_OUTPUT_DIRECTORY})
+file(COPY EVC.dat DESTINATION ${CMAKE_RUNTIME_OUTPUT_DIRECTORY})
+file(COPY HRD.dat DESTINATION ${CMAKE_RUNTIME_OUTPUT_DIRECTORY})
+file(COPY INV.dat DESTINATION ${CMAKE_RUNTIME_OUTPUT_DIRECTORY})
+file(COPY LLT.dat DESTINATION ${CMAKE_RUNTIME_OUTPUT_DIRECTORY})
+file(COPY LS.dat DESTINATION ${CMAKE_RUNTIME_OUTPUT_DIRECTORY})
+file(COPY LU.dat DESTINATION ${CMAKE_RUNTIME_OUTPUT_DIRECTORY})
+file(COPY NEP.dat DESTINATION ${CMAKE_RUNTIME_OUTPUT_DIRECTORY})
+file(COPY QR.dat DESTINATION ${CMAKE_RUNTIME_OUTPUT_DIRECTORY})
+file(COPY SEP.dat DESTINATION ${CMAKE_RUNTIME_OUTPUT_DIRECTORY})
+file(COPY SEPR.dat DESTINATION ${CMAKE_RUNTIME_OUTPUT_DIRECTORY})
+file(COPY SVD.dat DESTINATION ${CMAKE_RUNTIME_OUTPUT_DIRECTORY})
+file(COPY TRD.dat DESTINATION ${CMAKE_RUNTIME_OUTPUT_DIRECTORY})
+
+add_test(xslu ${MPIEXEC} ${MPIEXEC_NUMPROC_FLAG} 4 ./xslu)
+add_test(xdlu ${MPIEXEC} ${MPIEXEC_NUMPROC_FLAG} 4 ./xdlu)
+add_test(xclu ${MPIEXEC} ${MPIEXEC_NUMPROC_FLAG} 4 ./xclu)
+add_test(xzlu ${MPIEXEC} ${MPIEXEC_NUMPROC_FLAG} 4 ./xzlu)
+
+add_test(xsdblu ${MPIEXEC} ${MPIEXEC_NUMPROC_FLAG} 4 ./xsdblu)
+add_test(xddblu ${MPIEXEC} ${MPIEXEC_NUMPROC_FLAG} 4 ./xddblu)
+add_test(xcdblu ${MPIEXEC} ${MPIEXEC_NUMPROC_FLAG} 4 ./xcdblu)
+add_test(xzdblu ${MPIEXEC} ${MPIEXEC_NUMPROC_FLAG} 4 ./xzdblu)
+
+add_test(xsdtlu ${MPIEXEC} ${MPIEXEC_NUMPROC_FLAG} 4 ./xsdtlu)
+add_test(xddtlu ${MPIEXEC} ${MPIEXEC_NUMPROC_FLAG} 4 ./xddtlu)
+add_test(xcdtlu ${MPIEXEC} ${MPIEXEC_NUMPROC_FLAG} 4 ./xcdtlu)
+add_test(xzdtlu ${MPIEXEC} ${MPIEXEC_NUMPROC_FLAG} 4 ./xzdtlu)
+
+add_test(xsgblu ${MPIEXEC} ${MPIEXEC_NUMPROC_FLAG} 4 ./xsgblu)
+add_test(xdgblu ${MPIEXEC} ${MPIEXEC_NUMPROC_FLAG} 4 ./xdgblu)
+add_test(xcgblu ${MPIEXEC} ${MPIEXEC_NUMPROC_FLAG} 4 ./xcgblu)
+add_test(xzgblu ${MPIEXEC} ${MPIEXEC_NUMPROC_FLAG} 4 ./xzgblu)
+
+add_test(xsllt ${MPIEXEC} ${MPIEXEC_NUMPROC_FLAG} 4 ./xsllt)
+add_test(xdllt ${MPIEXEC} ${MPIEXEC_NUMPROC_FLAG} 4 ./xdllt)
+add_test(xcllt ${MPIEXEC} ${MPIEXEC_NUMPROC_FLAG} 4 ./xcllt)
+add_test(xzllt ${MPIEXEC} ${MPIEXEC_NUMPROC_FLAG} 4 ./xzllt)
+
+add_test(xspbllt ${MPIEXEC} ${MPIEXEC_NUMPROC_FLAG} 4 ./xspbllt)
+add_test(xdpbllt ${MPIEXEC} ${MPIEXEC_NUMPROC_FLAG} 4 ./xdpbllt)
+add_test(xcpbllt ${MPIEXEC} ${MPIEXEC_NUMPROC_FLAG} 4 ./xcpbllt)
+add_test(xzpbllt ${MPIEXEC} ${MPIEXEC_NUMPROC_FLAG} 4 ./xzpbllt)
+
+add_test(xsptllt ${MPIEXEC} ${MPIEXEC_NUMPROC_FLAG} 4 ./xsptllt)
+add_test(xdptllt ${MPIEXEC} ${MPIEXEC_NUMPROC_FLAG} 4 ./xdptllt)
+add_test(xcptllt ${MPIEXEC} ${MPIEXEC_NUMPROC_FLAG} 4 ./xcptllt)
+add_test(xzptllt ${MPIEXEC} ${MPIEXEC_NUMPROC_FLAG} 4 ./xzptllt)
+
+add_test(xsinv ${MPIEXEC} ${MPIEXEC_NUMPROC_FLAG} 4 ./xsinv)
+add_test(xdinv ${MPIEXEC} ${MPIEXEC_NUMPROC_FLAG} 4 ./xdinv)
+add_test(xcinv ${MPIEXEC} ${MPIEXEC_NUMPROC_FLAG} 4 ./xcinv)
+add_test(xzinv ${MPIEXEC} ${MPIEXEC_NUMPROC_FLAG} 4 ./xzinv)
+
+add_test(xsqr ${MPIEXEC} ${MPIEXEC_NUMPROC_FLAG} 4 ./xsqr)
+add_test(xdqr ${MPIEXEC} ${MPIEXEC_NUMPROC_FLAG} 4 ./xdqr)
+add_test(xcqr ${MPIEXEC} ${MPIEXEC_NUMPROC_FLAG} 4 ./xcqr)
+add_test(xzqr ${MPIEXEC} ${MPIEXEC_NUMPROC_FLAG} 4 ./xzqr)
+
+add_test(xsbrd ${MPIEXEC} ${MPIEXEC_NUMPROC_FLAG} 4 ./xsbrd)
+add_test(xdbrd ${MPIEXEC} ${MPIEXEC_NUMPROC_FLAG} 4 ./xdbrd)
+add_test(xcbrd ${MPIEXEC} ${MPIEXEC_NUMPROC_FLAG} 4 ./xcbrd)
+add_test(xzbrd ${MPIEXEC} ${MPIEXEC_NUMPROC_FLAG} 4 ./xzbrd)
+
+add_test(xshrd ${MPIEXEC} ${MPIEXEC_NUMPROC_FLAG} 4 ./xshrd)
+add_test(xdhrd ${MPIEXEC} ${MPIEXEC_NUMPROC_FLAG} 4 ./xdhrd)
+add_test(xchrd ${MPIEXEC} ${MPIEXEC_NUMPROC_FLAG} 4 ./xchrd)
+add_test(xzhrd ${MPIEXEC} ${MPIEXEC_NUMPROC_FLAG} 4 ./xzhrd)
+
+add_test(xstrd ${MPIEXEC} ${MPIEXEC_NUMPROC_FLAG} 4 ./xstrd)
+add_test(xdtrd ${MPIEXEC} ${MPIEXEC_NUMPROC_FLAG} 4 ./xdtrd)
+add_test(xctrd ${MPIEXEC} ${MPIEXEC_NUMPROC_FLAG} 4 ./xctrd)
+add_test(xztrd ${MPIEXEC} ${MPIEXEC_NUMPROC_FLAG} 4 ./xztrd)
+
+add_test(xssvd ${MPIEXEC} ${MPIEXEC_NUMPROC_FLAG} 4 ./xssvd)
+add_test(xdsvd ${MPIEXEC} ${MPIEXEC_NUMPROC_FLAG} 4 ./xdsvd)
+
+add_test(xssep ${MPIEXEC} ${MPIEXEC_NUMPROC_FLAG} 4 ./xssep)
+add_test(xdsep ${MPIEXEC} ${MPIEXEC_NUMPROC_FLAG} 4 ./xdsep)
+add_test(xcsep ${MPIEXEC} ${MPIEXEC_NUMPROC_FLAG} 4 ./xcsep)
+add_test(xzsep ${MPIEXEC} ${MPIEXEC_NUMPROC_FLAG} 4 ./xzsep)
+
+add_test(xsgsep ${MPIEXEC} ${MPIEXEC_NUMPROC_FLAG} 4 ./xsgsep)
+add_test(xdgsep ${MPIEXEC} ${MPIEXEC_NUMPROC_FLAG} 4 ./xdgsep)
+add_test(xcgsep ${MPIEXEC} ${MPIEXEC_NUMPROC_FLAG} 4 ./xcgsep)
+add_test(xzgsep ${MPIEXEC} ${MPIEXEC_NUMPROC_FLAG} 4 ./xzgsep)
+
+add_test(xsnep ${MPIEXEC} ${MPIEXEC_NUMPROC_FLAG} 4 ./xsnep)
+add_test(xdnep ${MPIEXEC} ${MPIEXEC_NUMPROC_FLAG} 4 ./xdnep)
+add_test(xcnep ${MPIEXEC} ${MPIEXEC_NUMPROC_FLAG} 4 ./xcnep)
+add_test(xznep ${MPIEXEC} ${MPIEXEC_NUMPROC_FLAG} 4 ./xznep)
+
+add_test(xcevc ${MPIEXEC} ${MPIEXEC_NUMPROC_FLAG} 4 ./xcevc)
+add_test(xzevc ${MPIEXEC} ${MPIEXEC_NUMPROC_FLAG} 4 ./xzevc)
+
+add_test(xssyevr ${MPIEXEC} ${MPIEXEC_NUMPROC_FLAG} 4 ./xssyevr)
+add_test(xdsyevr ${MPIEXEC} ${MPIEXEC_NUMPROC_FLAG} 4 ./xdsyevr)
+add_test(xcheevr ${MPIEXEC} ${MPIEXEC_NUMPROC_FLAG} 4 ./xcheevr)
+add_test(xzheevr ${MPIEXEC} ${MPIEXEC_NUMPROC_FLAG} 4 ./xzheevr)
+
+add_test(xshseqr ${MPIEXEC} ${MPIEXEC_NUMPROC_FLAG} 4 ./xshseqr)
+add_test(xdhseqr ${MPIEXEC} ${MPIEXEC_NUMPROC_FLAG} 4 ./xdhseqr)
+
diff --git a/TESTING/EIG/CMakeLists.txt b/TESTING/EIG/CMakeLists.txt
new file mode 100644
index 0000000..97c7036
--- /dev/null
+++ b/TESTING/EIG/CMakeLists.txt
@@ -0,0 +1,99 @@
+set(CMAKE_RUNTIME_OUTPUT_DIRECTORY ${SCALAPACK_BINARY_DIR}/TESTING)
+
+set (smatgen psmatgen.f pmatgeninc.f)
+set (dmatgen pdmatgen.f pmatgeninc.f)
+set (cmatgen pcmatgen.f pmatgeninc.f)
+set (zmatgen pzmatgen.f pmatgeninc.f)
+
+add_executable(xsbrd psbrddriver.f psbrdinfo.f psgebdrv.f pslafchk.f ${smatgen})
+add_executable(xdbrd pdbrddriver.f pdbrdinfo.f pdgebdrv.f pdlafchk.f ${dmatgen})
+add_executable(xcbrd pcbrddriver.f pcbrdinfo.f pcgebdrv.f pclafchk.f ${cmatgen})
+add_executable(xzbrd pzbrddriver.f pzbrdinfo.f pzgebdrv.f pzlafchk.f ${zmatgen})
+
+add_executable(xshrd pshrddriver.f pshrdinfo.f psgehdrv.f pslafchk.f ${smatgen})
+add_executable(xdhrd pdhrddriver.f pdhrdinfo.f pdgehdrv.f pdlafchk.f ${dmatgen})
+add_executable(xchrd pchrddriver.f pchrdinfo.f pcgehdrv.f pclafchk.f ${cmatgen})
+add_executable(xzhrd pzhrddriver.f pzhrdinfo.f pzgehdrv.f pzlafchk.f ${zmatgen})
+
+add_executable(xstrd pstrddriver.f psttrdtester.f pslatran.f pstrdinfo.f pssytdrv.f pslafchk.f xpjlaenv.f ${smatgen})
+add_executable(xdtrd pdtrddriver.f pdttrdtester.f pdlatran.f pdtrdinfo.f pdsytdrv.f pdlafchk.f xpjlaenv.f ${dmatgen})
+add_executable(xctrd pctrddriver.f pcttrdtester.f pclatran.f pctrdinfo.f pchetdrv.f pclafchk.f xpjlaenv.f ${cmatgen})
+add_executable(xztrd pztrddriver.f pzttrdtester.f pzlatran.f pztrdinfo.f pzhetdrv.f pzlafchk.f xpjlaenv.f ${zmatgen})
+
+add_executable(xssvd pssvddriver.f pslagge.f pssvdchk.f pssvdcmp.f pssvdtst.f ${smatgen})
+add_executable(xdsvd pdsvddriver.f pdlagge.f pdsvdchk.f pdsvdcmp.f pdsvdtst.f ${dmatgen})
+
+add_executable(xssep psseptst.f pssepsubtst.f pssepchk.f pssepqtq.f pslagsy.f pslatms.f pslasizesep.f pslasizesyevx.f pssepdriver.f pssepreq.f pssepinfo.f pslasizesyev.f pssqpsubtst.f pslasizesqp.f pssdpsubtst.f ${smatgen})
+add_executable(xdsep pdseptst.f pdsepsubtst.f pdsepchk.f pdsepqtq.f pdlagsy.f pdlatms.f pdlasizesep.f pdlasizesyevx.f pdsepdriver.f pdsepreq.f pdsepinfo.f pdlasizesyev.f pdsqpsubtst.f pdlasizesqp.f pdsdpsubtst.f ${dmatgen})
+add_executable(xcsep pcseptst.f pcsepsubtst.f pcsepchk.f pcsepqtq.f pclagsy.f pclatms.f pclasizesep.f pclasizeheevx.f pcsepdriver.f pcsepreq.f pssepinfo.f pcsdpsubtst.f ${cmatgen})
+add_executable(xzsep pzseptst.f pzsepsubtst.f pzsepchk.f pzsepqtq.f pzlagsy.f pzlatms.f pzlasizesep.f pzlasizeheevx.f pzsepdriver.f pzsepreq.f pdsepinfo.f pzsdpsubtst.f ${zmatgen})
+
+add_executable(xsgsep psgseptst.f psgsepsubtst.f psgsepchk.f pslagsy.f pslatms.f pslasizesyevx.f pslasizegsep.f pslasizesep.f psgsepdriver.f psgsepreq.f pssepinfo.f ${smatgen})
+add_executable(xdgsep pdgseptst.f pdgsepsubtst.f pdgsepchk.f pdlagsy.f pdlatms.f pdlasizesyevx.f pdlasizegsep.f pdlasizesep.f pdgsepdriver.f pdgsepreq.f pdsepinfo.f ${dmatgen})
+add_executable(xcgsep pcgseptst.f pcgsepsubtst.f pcgsepchk.f pclagsy.f pclatms.f pclasizegsep.f pclasizeheevx.f pclasizesep.f pcgsepdriver.f pcgsepreq.f pssepinfo.f ${cmatgen})
+add_executable(xzgsep pzgseptst.f pzgsepsubtst.f pzgsepchk.f pzlagsy.f pzlatms.f pzlasizegsep.f pzlasizeheevx.f pzlasizesep.f pzgsepdriver.f pzgsepreq.f pdsepinfo.f ${zmatgen})
+
+add_executable(xsnep psnepdriver.f psnepinfo.f psnepfchk.f ${smatgen})
+add_executable(xdnep pdnepdriver.f pdnepinfo.f pdnepfchk.f ${dmatgen})
+add_executable(xcnep pcnepdriver.f pcnepinfo.f pcnepfchk.f ${cmatgen})
+add_executable(xznep pznepdriver.f pznepinfo.f pznepfchk.f ${zmatgen})
+
+add_executable(xcevc pcevcdriver.f pcevcinfo.f pcget22.f ${cmatgen})
+add_executable(xzevc pzevcdriver.f pzevcinfo.f pzget22.f ${zmatgen})
+
+add_executable(xssyevr pslasizesepr.f pslasizesyevr.f psseprdriver.f psseprreq.f psseprsubtst.f
+pssepchk.f pssepqtq.f pslatms.f psseprtst.f pssepinfo.f pslagsy.f pslasizesep.f ${smatgen})
+add_executable(xdsyevr pdlasizesepr.f pdlasizesyevr.f pdseprdriver.f pdseprreq.f pdseprsubtst.f
+pdsepchk.f pdsepqtq.f pdlatms.f pdseprtst.f pdsepinfo.f pdlagsy.f pdlasizesep.f ${dmatgen})
+add_executable(xcheevr pclasizesepr.f pclasizeheevr.f pcseprdriver.f pcseprreq.f pcseprsubtst.f
+pcsepchk.f pcsepqtq.f pclatms.f pcseprtst.f pssepinfo.f pclagsy.f pclasizesep.f ${cmatgen})
+add_executable(xzheevr pzlasizesepr.f pzlasizeheevr.f pzseprdriver.f pzseprreq.f pzseprsubtst.f
+pzsepchk.f pzsepqtq.f pzlatms.f pzseprtst.f pdsepinfo.f pzlagsy.f pzlasizesep.f ${zmatgen})
+
+add_executable(xshseqr pshseqrdriver.f psmatgen2.f ${cmatgen})
+add_executable(xdhseqr pdhseqrdriver.f pdmatgen2.f ${cmatgen})
+
+target_link_libraries(xsbrd scalapack ${LAPACK_LIBRARIES} ${BLAS_LIBRARIES})
+target_link_libraries(xdbrd scalapack ${LAPACK_LIBRARIES} ${BLAS_LIBRARIES})
+target_link_libraries(xcbrd scalapack ${LAPACK_LIBRARIES} ${BLAS_LIBRARIES})
+target_link_libraries(xzbrd scalapack ${LAPACK_LIBRARIES} ${BLAS_LIBRARIES})
+
+target_link_libraries(xshrd scalapack ${LAPACK_LIBRARIES} ${BLAS_LIBRARIES})
+target_link_libraries(xdhrd scalapack ${LAPACK_LIBRARIES} ${BLAS_LIBRARIES})
+target_link_libraries(xchrd scalapack ${LAPACK_LIBRARIES} ${BLAS_LIBRARIES})
+target_link_libraries(xzhrd scalapack ${LAPACK_LIBRARIES} ${BLAS_LIBRARIES})
+
+target_link_libraries(xstrd scalapack ${LAPACK_LIBRARIES} ${BLAS_LIBRARIES})
+target_link_libraries(xdtrd scalapack ${LAPACK_LIBRARIES} ${BLAS_LIBRARIES})
+target_link_libraries(xctrd scalapack ${LAPACK_LIBRARIES} ${BLAS_LIBRARIES})
+target_link_libraries(xztrd scalapack ${LAPACK_LIBRARIES} ${BLAS_LIBRARIES})
+
+target_link_libraries(xssvd scalapack ${LAPACK_LIBRARIES} ${BLAS_LIBRARIES})
+target_link_libraries(xdsvd scalapack ${LAPACK_LIBRARIES} ${BLAS_LIBRARIES})
+
+target_link_libraries(xssep scalapack ${LAPACK_LIBRARIES} ${BLAS_LIBRARIES})
+target_link_libraries(xdsep scalapack ${LAPACK_LIBRARIES} ${BLAS_LIBRARIES})
+target_link_libraries(xcsep scalapack ${LAPACK_LIBRARIES} ${BLAS_LIBRARIES})
+target_link_libraries(xzsep scalapack ${LAPACK_LIBRARIES} ${BLAS_LIBRARIES})
+
+target_link_libraries(xsgsep scalapack ${LAPACK_LIBRARIES} ${BLAS_LIBRARIES})
+target_link_libraries(xdgsep scalapack ${LAPACK_LIBRARIES} ${BLAS_LIBRARIES})
+target_link_libraries(xcgsep scalapack ${LAPACK_LIBRARIES} ${BLAS_LIBRARIES})
+target_link_libraries(xzgsep scalapack ${LAPACK_LIBRARIES} ${BLAS_LIBRARIES})
+
+target_link_libraries(xsnep scalapack ${LAPACK_LIBRARIES} ${BLAS_LIBRARIES})
+target_link_libraries(xdnep scalapack ${LAPACK_LIBRARIES} ${BLAS_LIBRARIES})
+target_link_libraries(xcnep scalapack ${LAPACK_LIBRARIES} ${BLAS_LIBRARIES})
+target_link_libraries(xznep scalapack ${LAPACK_LIBRARIES} ${BLAS_LIBRARIES})
+
+target_link_libraries(xcevc scalapack ${LAPACK_LIBRARIES} ${BLAS_LIBRARIES})
+target_link_libraries(xzevc scalapack ${LAPACK_LIBRARIES} ${BLAS_LIBRARIES})
+
+target_link_libraries(xssyevr scalapack ${LAPACK_LIBRARIES} ${BLAS_LIBRARIES})
+target_link_libraries(xdsyevr scalapack ${LAPACK_LIBRARIES} ${BLAS_LIBRARIES})
+target_link_libraries(xcheevr scalapack ${LAPACK_LIBRARIES} ${BLAS_LIBRARIES})
+target_link_libraries(xzheevr scalapack ${LAPACK_LIBRARIES} ${BLAS_LIBRARIES})
+
+target_link_libraries(xshseqr scalapack ${LAPACK_LIBRARIES} ${BLAS_LIBRARIES})
+target_link_libraries(xdhseqr scalapack ${LAPACK_LIBRARIES} ${BLAS_LIBRARIES})
+
diff --git a/TESTING/EIG/Makefile b/TESTING/EIG/Makefile
index 36f6564..629ed24 100644
--- a/TESTING/EIG/Makefile
+++ b/TESTING/EIG/Makefile
@@ -8,7 +8,7 @@
#
# Creation date: February 20, 2000
#
-# Modified:
+# Modified: November, 2011
#
# Send bug reports, comments or suggestions to scalapack at cs.utk.edu
#
@@ -16,42 +16,50 @@
include ../../SLmake.inc
-shrdexe = $(TESTINGdir)/xshrd
-dhrdexe = $(TESTINGdir)/xdhrd
-chrdexe = $(TESTINGdir)/xchrd
-zhrdexe = $(TESTINGdir)/xzhrd
+shrdexe = ../xshrd
+dhrdexe = ../xdhrd
+chrdexe = ../xchrd
+zhrdexe = ../xzhrd
-strdexe = $(TESTINGdir)/xstrd
-dtrdexe = $(TESTINGdir)/xdtrd
-ctrdexe = $(TESTINGdir)/xctrd
-ztrdexe = $(TESTINGdir)/xztrd
+strdexe = ../xstrd
+dtrdexe = ../xdtrd
+ctrdexe = ../xctrd
+ztrdexe = ../xztrd
-sbrdexe = $(TESTINGdir)/xsbrd
-dbrdexe = $(TESTINGdir)/xdbrd
-cbrdexe = $(TESTINGdir)/xcbrd
-zbrdexe = $(TESTINGdir)/xzbrd
+sbrdexe = ../xsbrd
+dbrdexe = ../xdbrd
+cbrdexe = ../xcbrd
+zbrdexe = ../xzbrd
-ssepexe = $(TESTINGdir)/xssep
-dsepexe = $(TESTINGdir)/xdsep
-csepexe = $(TESTINGdir)/xcsep
-zsepexe = $(TESTINGdir)/xzsep
+ssepexe = ../xssep
+dsepexe = ../xdsep
+csepexe = ../xcsep
+zsepexe = ../xzsep
-sgsepexe = $(TESTINGdir)/xsgsep
-dgsepexe = $(TESTINGdir)/xdgsep
-cgsepexe = $(TESTINGdir)/xcgsep
-zgsepexe = $(TESTINGdir)/xzgsep
+sgsepexe = ../xsgsep
+dgsepexe = ../xdgsep
+cgsepexe = ../xcgsep
+zgsepexe = ../xzgsep
-ssvdexe = $(TESTINGdir)/xssvd
-dsvdexe = $(TESTINGdir)/xdsvd
+ssvdexe = ../xssvd
+dsvdexe = ../xdsvd
-snepexe = $(TESTINGdir)/xsnep
-dnepexe = $(TESTINGdir)/xdnep
-cnepexe = $(TESTINGdir)/xcnep
-znepexe = $(TESTINGdir)/xznep
+snepexe = ../xsnep
+dnepexe = ../xdnep
+cnepexe = ../xcnep
+znepexe = ../xznep
-cevcexe = $(TESTINGdir)/xcevc
-zevcexe = $(TESTINGdir)/xzevc
+cevcexe = ../xcevc
+zevcexe = ../xzevc
+
+ssyevrexe = ../xssyevr
+dsyevrexe = ../xdsyevr
+cheevrexe = ../xcheevr
+zheevrexe = ../xzheevr
+
+shseqrexe = ../xshseqr
+dhseqrexe = ../xdhseqr
smatgen = psmatgen.o pmatgeninc.o
dmatgen = pdmatgen.o pmatgeninc.o
@@ -116,235 +124,129 @@ znep = pznepdriver.o pznepinfo.o pznepfchk.o $(zmatgen)
cevc = pcevcdriver.o pcevcinfo.o pcget22.o $(cmatgen)
zevc = pzevcdriver.o pzevcinfo.o pzget22.o $(zmatgen)
+ssyevr = pslasizesepr.o pslasizesyevr.o psseprdriver.o psseprreq.o psseprsubtst.o \
+pssepchk.o pssepqtq.o pslatms.o psseprtst.o pssepinfo.o pslagsy.o pslasizesep.o $(smatgen)
+dsyevr = pdlasizesepr.o pdlasizesyevr.o pdseprdriver.o pdseprreq.o pdseprsubtst.o \
+pdsepchk.o pdsepqtq.o pdlatms.o pdseprtst.o pdsepinfo.o pdlagsy.o pdlasizesep.o $(dmatgen)
+cheevr = pclasizesepr.o pclasizeheevr.o pcseprdriver.o pcseprreq.o pcseprsubtst.o \
+pcsepchk.o pcsepqtq.o pclatms.o pcseprtst.o pssepinfo.o pclagsy.o pclasizesep.o $(cmatgen)
+zheevr = pzlasizesepr.o pzlasizeheevr.o pzseprdriver.o pzseprreq.o pzseprsubtst.o \
+pzsepchk.o pzsepqtq.o pzlatms.o pzseprtst.o pdsepinfo.o pzlagsy.o pzlasizesep.o $(zmatgen)
+
+shseqr = pshseqrdriver.o psmatgen2.o $(smatgen)
+dhseqr = pdhseqrdriver.o pdmatgen2.o $(dmatgen)
+
all : single double complex complex16
-single: $(shrdexe) $(strdexe) $(sbrdexe) $(ssepexe) $(sgsepexe) \
- $(snepexe) $(ssvdexe)
-double: $(dhrdexe) $(dtrdexe) $(dbrdexe) $(dsepexe) $(dgsepexe) \
- $(dnepexe) $(dsvdexe)
-complex: $(chrdexe) $(ctrdexe) $(cbrdexe) $(csepexe) $(cgsepexe) \
- $(cnepexe) $(cevcexe)
-complex16: $(zhrdexe) $(ztrdexe) $(zbrdexe) $(zsepexe) $(zgsepexe) \
- $(znepexe) $(zevcexe)
-
-$(TESTINGdir)/BRD.dat: ../BRD.dat
- cp ../BRD.dat $(TESTINGdir)
-
-$(sbrdexe) : $(SCALAPACKLIB) $(sbrd)
- $(F77LOADER) $(F77LOADFLAGS) -o $(sbrdexe) $(sbrd) $(LIBS)
- $(MAKE) $(TESTINGdir)/BRD.dat
-$(dbrdexe) : $(SCALAPACKLIB) $(dbrd)
- $(F77LOADER) $(F77LOADFLAGS) -o $(dbrdexe) $(dbrd) $(LIBS)
- $(MAKE) $(TESTINGdir)/BRD.dat
-$(cbrdexe) : $(SCALAPACKLIB) $(cbrd)
- $(F77LOADER) $(F77LOADFLAGS) -o $(cbrdexe) $(cbrd) $(LIBS)
- $(MAKE) $(TESTINGdir)/BRD.dat
-$(zbrdexe) : $(SCALAPACKLIB) $(zbrd)
- $(F77LOADER) $(F77LOADFLAGS) -o $(zbrdexe) $(zbrd) $(LIBS)
- $(MAKE) $(TESTINGdir)/BRD.dat
-
-$(TESTINGdir)/HRD.dat: ../HRD.dat
- cp ../HRD.dat $(TESTINGdir)
-
-$(shrdexe) : $(SCALAPACKLIB) $(shrd)
- $(F77LOADER) $(F77LOADFLAGS) -o $(shrdexe) $(shrd) $(LIBS)
- $(MAKE) $(TESTINGdir)/HRD.dat
-$(dhrdexe) : $(SCALAPACKLIB) $(dhrd)
- $(F77LOADER) $(F77LOADFLAGS) -o $(dhrdexe) $(dhrd) $(LIBS)
- $(MAKE) $(TESTINGdir)/HRD.dat
-$(chrdexe) : $(SCALAPACKLIB) $(chrd)
- $(F77LOADER) $(F77LOADFLAGS) -o $(chrdexe) $(chrd) $(LIBS)
- $(MAKE) $(TESTINGdir)/HRD.dat
-$(zhrdexe) : $(SCALAPACKLIB) $(zhrd)
- $(F77LOADER) $(F77LOADFLAGS) -o $(zhrdexe) $(zhrd) $(LIBS)
- $(MAKE) $(TESTINGdir)/HRD.dat
-
-$(TESTINGdir)/TRD.dat: ../TRD.dat
- cp ../TRD.dat $(TESTINGdir)
-
-$(strdexe) : $(SCALAPACKLIB) $(strd)
- $(F77LOADER) $(F77LOADFLAGS) -o $(strdexe) $(strd) $(LIBS)
- $(MAKE) $(TESTINGdir)/TRD.dat
-$(dtrdexe) : $(SCALAPACKLIB) $(dtrd)
- $(F77LOADER) $(F77LOADFLAGS) -o $(dtrdexe) $(dtrd) $(LIBS)
- $(MAKE) $(TESTINGdir)/TRD.dat
-$(ctrdexe) : $(SCALAPACKLIB) $(ctrd)
- $(F77LOADER) $(F77LOADFLAGS) -o $(ctrdexe) $(ctrd) $(LIBS)
- $(MAKE) $(TESTINGdir)/TRD.dat
-$(ztrdexe) : $(SCALAPACKLIB) $(ztrd)
- $(F77LOADER) $(F77LOADFLAGS) -o $(ztrdexe) $(ztrd) $(LIBS)
- $(MAKE) $(TESTINGdir)/TRD.dat
-
-
-$(TESTINGdir)/SVD.dat: ../SVD.dat
- cp ../SVD.dat $(TESTINGdir)
-
-$(ssvdexe) : $(SCALAPACKLIB) $(ssvd)
- $(F77LOADER) $(F77LOADFLAGS) -o $(ssvdexe) $(ssvd) $(RLIBS)
- $(MAKE) $(TESTINGdir)/SVD.dat
-$(dsvdexe) : $(SCALAPACKLIB) $(dsvd)
- $(F77LOADER) $(F77LOADFLAGS) -o $(dsvdexe) $(dsvd) $(RLIBS)
- $(MAKE) $(TESTINGdir)/SVD.dat
-
-$(TESTINGdir)/SEP.dat: ../SEP.dat
- cp ../SEP.dat $(TESTINGdir)
-
-$(ssepexe) : $(SCALAPACKLIB) $(ssep)
- $(F77LOADER) $(F77LOADFLAGS) -o $(ssepexe) $(ssep) $(RLIBS)
- $(MAKE) $(TESTINGdir)/SEP.dat
-$(dsepexe) : $(SCALAPACKLIB) $(dsep)
- $(F77LOADER) $(F77LOADFLAGS) -o $(dsepexe) $(dsep) $(RLIBS)
- $(MAKE) $(TESTINGdir)/SEP.dat
-$(csepexe) : $(SCALAPACKLIB) $(csep)
- $(F77LOADER) $(F77LOADFLAGS) -o $(csepexe) $(csep) $(LIBS)
- $(MAKE) $(TESTINGdir)/SEP.dat
-$(zsepexe) : $(SCALAPACKLIB) $(zsep)
- $(F77LOADER) $(F77LOADFLAGS) -o $(zsepexe) $(zsep) $(LIBS)
- $(MAKE) $(TESTINGdir)/SEP.dat
-
-$(sgsepexe) : $(SCALAPACKLIB) $(sgsep)
- $(F77LOADER) $(F77LOADFLAGS) -o $(sgsepexe) $(sgsep) $(LIBS)
- $(MAKE) $(TESTINGdir)/SEP.dat
-$(dgsepexe) : $(SCALAPACKLIB) $(dgsep)
- $(F77LOADER) $(F77LOADFLAGS) -o $(dgsepexe) $(dgsep) $(LIBS)
- $(MAKE) $(TESTINGdir)/SEP.dat
-$(cgsepexe) : $(SCALAPACKLIB) $(cgsep)
- $(F77LOADER) $(F77LOADFLAGS) -o $(cgsepexe) $(cgsep) $(LIBS)
- $(MAKE) $(TESTINGdir)/SEP.dat
-$(zgsepexe) : $(SCALAPACKLIB) $(zgsep)
- $(F77LOADER) $(F77LOADFLAGS) -o $(zgsepexe) $(zgsep) $(LIBS)
- $(MAKE) $(TESTINGdir)/SEP.dat
-
-$(TESTINGdir)/NEP.dat: ../NEP.dat
- cp ../NEP.dat $(TESTINGdir)
-
-$(snepexe) : $(SCALAPACKLIB) $(snep)
- $(F77LOADER) $(F77LOADFLAGS) -o $(snepexe) $(snep) $(LIBS)
- $(MAKE) $(TESTINGdir)/NEP.dat
-$(dnepexe) : $(SCALAPACKLIB) $(dnep)
- $(F77LOADER) $(F77LOADFLAGS) -o $(dnepexe) $(dnep) $(LIBS)
- $(MAKE) $(TESTINGdir)/NEP.dat
-$(cnepexe) : $(SCALAPACKLIB) $(cnep)
- $(F77LOADER) $(F77LOADFLAGS) -o $(cnepexe) $(cnep) $(LIBS)
- $(MAKE) $(TESTINGdir)/NEP.dat
-$(znepexe) : $(SCALAPACKLIB) $(znep)
- $(F77LOADER) $(F77LOADFLAGS) -o $(znepexe) $(znep) $(LIBS)
- $(MAKE) $(TESTINGdir)/NEP.dat
-
-$(TESTINGdir)/EVC.dat: ../EVC.dat
- cp ../EVC.dat $(TESTINGdir)
-
-$(cevcexe) : $(SCALAPACKLIB) $(cevc)
- $(F77LOADER) $(F77LOADFLAGS) -o $(cevcexe) $(cevc) $(LIBS)
- $(MAKE) $(TESTINGdir)/EVC.dat
-$(zevcexe) : $(SCALAPACKLIB) $(zevc)
- $(F77LOADER) $(F77LOADFLAGS) -o $(zevcexe) $(zevc) $(LIBS)
- $(MAKE) $(TESTINGdir)/EVC.dat
-
-$(sbrd): $(FRC)
-$(dbrd): $(FRC)
-$(cbrd): $(FRC)
-$(zbrd): $(FRC)
-
-$(shrd): $(FRC)
-$(dhrd): $(FRC)
-$(chrd): $(FRC)
-$(zhrd): $(FRC)
-
-$(strd): $(FRC)
-$(dtrd): $(FRC)
-$(ctrd): $(FRC)
-$(ztrd): $(FRC)
-
-$(ssvd): $(FRC)
-$(dsvd): $(FRC)
-
-$(ssep): $(FRC)
-$(dsep): $(FRC)
-$(csep): $(FRC)
-$(zsep): $(FRC)
-
-$(sgsep): $(FRC)
-$(dgsep): $(FRC)
-$(cgsep): $(FRC)
-$(zgsep): $(FRC)
-
-$(snep): $(FRC)
-$(dnep): $(FRC)
-$(cnep): $(FRC)
-$(znep): $(FRC)
-
-$(cevc): $(FRC)
-$(zevc): $(FRC)
-
-FRC:
- @FRC=$(FRC)
-
-clean :
+single: $(shrdexe) $(strdexe) $(sbrdexe) $(ssepexe) $(sgsepexe) $(snepexe) $(ssvdexe) $(ssyevrexe) $(shseqrexe)
+double: $(dhrdexe) $(dtrdexe) $(dbrdexe) $(dsepexe) $(dgsepexe) $(dnepexe) $(dsvdexe) $(dsyevrexe) $(dhseqrexe)
+complex: $(chrdexe) $(ctrdexe) $(cbrdexe) $(csepexe) $(cgsepexe) $(cnepexe) $(cevcexe) $(cheevrexe)
+complex16: $(zhrdexe) $(ztrdexe) $(zbrdexe) $(zsepexe) $(zgsepexe) $(znepexe) $(zevcexe) $(zheevrexe)
+
+$(sbrdexe) : ../../$(SCALAPACKLIB) $(sbrd)
+ $(FCLOADER) $(FCLOADFLAGS) -o $(sbrdexe) $(sbrd) ../../$(SCALAPACKLIB) $(LIBS)
+
+$(dbrdexe) : ../../$(SCALAPACKLIB) $(dbrd)
+ $(FCLOADER) $(FCLOADFLAGS) -o $(dbrdexe) $(dbrd) ../../$(SCALAPACKLIB) $(LIBS)
+
+$(cbrdexe) : ../../$(SCALAPACKLIB) $(cbrd)
+ $(FCLOADER) $(FCLOADFLAGS) -o $(cbrdexe) $(cbrd) ../../$(SCALAPACKLIB) $(LIBS)
+
+$(zbrdexe) : ../../$(SCALAPACKLIB) $(zbrd)
+ $(FCLOADER) $(FCLOADFLAGS) -o $(zbrdexe) $(zbrd) ../../$(SCALAPACKLIB) $(LIBS)
+
+$(shrdexe) : ../../$(SCALAPACKLIB) $(shrd)
+ $(FCLOADER) $(FCLOADFLAGS) -o $(shrdexe) $(shrd) ../../$(SCALAPACKLIB) $(LIBS)
+
+$(dhrdexe) : ../../$(SCALAPACKLIB) $(dhrd)
+ $(FCLOADER) $(FCLOADFLAGS) -o $(dhrdexe) $(dhrd) ../../$(SCALAPACKLIB) $(LIBS)
+
+$(chrdexe) : ../../$(SCALAPACKLIB) $(chrd)
+ $(FCLOADER) $(FCLOADFLAGS) -o $(chrdexe) $(chrd) ../../$(SCALAPACKLIB) $(LIBS)
+
+$(zhrdexe) : ../../$(SCALAPACKLIB) $(zhrd)
+ $(FCLOADER) $(FCLOADFLAGS) -o $(zhrdexe) $(zhrd) ../../$(SCALAPACKLIB) $(LIBS)
+
+$(strdexe) : ../../$(SCALAPACKLIB) $(strd)
+ $(FCLOADER) $(FCLOADFLAGS) -o $(strdexe) $(strd) ../../$(SCALAPACKLIB) $(LIBS)
+
+$(dtrdexe) : ../../$(SCALAPACKLIB) $(dtrd)
+ $(FCLOADER) $(FCLOADFLAGS) -o $(dtrdexe) $(dtrd) ../../$(SCALAPACKLIB) $(LIBS)
+
+$(ctrdexe) : ../../$(SCALAPACKLIB) $(ctrd)
+ $(FCLOADER) $(FCLOADFLAGS) -o $(ctrdexe) $(ctrd) ../../$(SCALAPACKLIB) $(LIBS)
+
+$(ztrdexe) : ../../$(SCALAPACKLIB) $(ztrd)
+ $(FCLOADER) $(FCLOADFLAGS) -o $(ztrdexe) $(ztrd) ../../$(SCALAPACKLIB) $(LIBS)
+
+$(ssvdexe) : ../../$(SCALAPACKLIB) $(ssvd)
+ $(FCLOADER) $(FCLOADFLAGS) -o $(ssvdexe) $(ssvd) ../../$(SCALAPACKLIB) $(LIBS)
+
+$(dsvdexe) : ../../$(SCALAPACKLIB) $(dsvd)
+ $(FCLOADER) $(FCLOADFLAGS) -o $(dsvdexe) $(dsvd) ../../$(SCALAPACKLIB) $(LIBS)
+
+$(ssepexe) : ../../$(SCALAPACKLIB) $(ssep)
+ $(FCLOADER) $(FCLOADFLAGS) -o $(ssepexe) $(ssep) ../../$(SCALAPACKLIB) $(LIBS)
+
+$(dsepexe) : ../../$(SCALAPACKLIB) $(dsep)
+ $(FCLOADER) $(FCLOADFLAGS) -o $(dsepexe) $(dsep) ../../$(SCALAPACKLIB) $(LIBS)
+
+$(csepexe) : ../../$(SCALAPACKLIB) $(csep)
+ $(FCLOADER) $(FCLOADFLAGS) -o $(csepexe) $(csep) ../../$(SCALAPACKLIB) $(LIBS)
+
+$(zsepexe) : ../../$(SCALAPACKLIB) $(zsep)
+ $(FCLOADER) $(FCLOADFLAGS) -o $(zsepexe) $(zsep) ../../$(SCALAPACKLIB) $(LIBS)
+
+$(sgsepexe) : ../../$(SCALAPACKLIB) $(sgsep)
+ $(FCLOADER) $(FCLOADFLAGS) -o $(sgsepexe) $(sgsep) ../../$(SCALAPACKLIB) $(LIBS)
+
+$(dgsepexe) : ../../$(SCALAPACKLIB) $(dgsep)
+ $(FCLOADER) $(FCLOADFLAGS) -o $(dgsepexe) $(dgsep) ../../$(SCALAPACKLIB) $(LIBS)
+
+$(cgsepexe) : ../../$(SCALAPACKLIB) $(cgsep)
+ $(FCLOADER) $(FCLOADFLAGS) -o $(cgsepexe) $(cgsep) ../../$(SCALAPACKLIB) $(LIBS)
+
+$(zgsepexe) : ../../$(SCALAPACKLIB) $(zgsep)
+ $(FCLOADER) $(FCLOADFLAGS) -o $(zgsepexe) $(zgsep) ../../$(SCALAPACKLIB) $(LIBS)
+
+$(snepexe) : ../../$(SCALAPACKLIB) $(snep)
+ $(FCLOADER) $(FCLOADFLAGS) -o $(snepexe) $(snep) ../../$(SCALAPACKLIB) $(LIBS)
+
+$(dnepexe) : ../../$(SCALAPACKLIB) $(dnep)
+ $(FCLOADER) $(FCLOADFLAGS) -o $(dnepexe) $(dnep) ../../$(SCALAPACKLIB) $(LIBS)
+
+$(cnepexe) : ../../$(SCALAPACKLIB) $(cnep)
+ $(FCLOADER) $(FCLOADFLAGS) -o $(cnepexe) $(cnep) ../../$(SCALAPACKLIB) $(LIBS)
+
+$(znepexe) : ../../$(SCALAPACKLIB) $(znep)
+ $(FCLOADER) $(FCLOADFLAGS) -o $(znepexe) $(znep) ../../$(SCALAPACKLIB) $(LIBS)
+
+$(cevcexe): ../../$(SCALAPACKLIB) $(cevc)
+ $(FCLOADER) $(FCLOADFLAGS) -o $(cevcexe) $(cevc) ../../$(SCALAPACKLIB) $(LIBS)
+
+$(zevcexe): ../../$(SCALAPACKLIB) $(zevc)
+ $(FCLOADER) $(FCLOADFLAGS) -o $(zevcexe) $(zevc) ../../$(SCALAPACKLIB) $(LIBS)
+
+$(ssyevrexe): ../../$(SCALAPACKLIB) $(ssyevr)
+ $(FCLOADER) $(FCLOADFLAGS) -o $(ssyevrexe) $(ssyevr) ../../$(SCALAPACKLIB) $(LIBS)
+
+$(dsyevrexe): ../../$(SCALAPACKLIB) $(dsyevr)
+ $(FCLOADER) $(FCLOADFLAGS) -o $(dsyevrexe) $(dsyevr) ../../$(SCALAPACKLIB) $(LIBS)
+
+$(cheevrexe): ../../$(SCALAPACKLIB) $(cheevr)
+ $(FCLOADER) $(FCLOADFLAGS) -o $(cheevrexe) $(cheevr) ../../$(SCALAPACKLIB) $(LIBS)
+
+$(zheevrexe): ../../$(SCALAPACKLIB) $(zheevr)
+ $(FCLOADER) $(FCLOADFLAGS) -o $(zheevrexe) $(zheevr) ../../$(SCALAPACKLIB) $(LIBS)
+
+$(shseqrexe): ../../$(SCALAPACKLIB) $(shseqr)
+ $(FCLOADER) $(FCLOADFLAGS) -o $(shseqrexe) $(shseqr) ../../$(SCALAPACKLIB) $(LIBS)
+
+$(dhseqrexe): ../../$(SCALAPACKLIB) $(dhseqr)
+ $(FCLOADER) $(FCLOADFLAGS) -o $(dhseqrexe) $(dhseqr) ../../$(SCALAPACKLIB) $(LIBS)
+
+clean:
rm -f *.o
-psbrddriver.o: psbrddriver.f
- $(F77) $(DRVOPTS) -c $<
-pdbrddriver.o: pdbrddriver.f
- $(F77) $(DRVOPTS) -c $<
-pcbrddriver.o: pcbrddriver.f
- $(F77) $(DRVOPTS) -c $<
-pzbrddriver.o: pzbrddriver.f
- $(F77) $(DRVOPTS) -c $<
-
-pshrddriver.o: pshrddriver.f
- $(F77) $(DRVOPTS) -c $<
-pdhrddriver.o: pdhrddriver.f
- $(F77) $(DRVOPTS) -c $<
-pchrddriver.o: pchrddriver.f
- $(F77) $(DRVOPTS) -c $<
-pzhrddriver.o: pzhrddriver.f
- $(F77) $(DRVOPTS) -c $<
-
-pstrddriver.o: pstrddriver.f
- $(F77) $(DRVOPTS) -c $<
-pdtrddriver.o: pdtrddriver.f
- $(F77) $(DRVOPTS) -c $<
-pctrddriver.o: pctrddriver.f
- $(F77) $(DRVOPTS) -c $<
-pztrddriver.o: pztrddriver.f
- $(F77) $(DRVOPTS) -c $<
-
-pssvddriver.o: pssvddriver.f
- $(F77) $(DRVOPTS) -c $<
-pdsvddriver.o: pdsvddriver.f
- $(F77) $(DRVOPTS) -c $<
-
-pssepdriver.o: pssepdriver.f
- $(F77) $(DRVOPTS) -c $<
-pdsepdriver.o: pdsepdriver.f
- $(F77) $(DRVOPTS) -c $<
-pcsepdriver.o: pcsepdriver.f
- $(F77) $(DRVOPTS) -c $<
-pzsepdriver.o: pzsepdriver.f
- $(F77) $(DRVOPTS) -c $<
-
-psgsepdriver.o: psgsepdriver.f
- $(F77) $(DRVOPTS) -c $<
-pdgsepdriver.o: pdgsepdriver.f
- $(F77) $(DRVOPTS) -c $<
-pcgsepdriver.o: pcgsepdriver.f
- $(F77) $(DRVOPTS) -c $<
-pzgsepdriver.o: pzgsepdriver.f
- $(F77) $(DRVOPTS) -c $<
-
-psnepdriver.o: psnepdriver.f
- $(F77) $(DRVOPTS) -c $<
-pdnepdriver.o: pdnepdriver.f
- $(F77) $(DRVOPTS) -c $<
-pcnepdriver.o: pcnepdriver.f
- $(F77) $(DRVOPTS) -c $<
-pznepdriver.o: pznepdriver.f
- $(F77) $(DRVOPTS) -c $<
-
-pcevcdriver.o: pcevcdriver.f
- $(F77) $(DRVOPTS) -c $<
-pzevcdriver.o: pzevcdriver.f
- $(F77) $(DRVOPTS) -c $<
-
-.f.o : ; $(F77) -c $(F77FLAGS) $*.f
+.f.o:
+ $(FC) -c $(FCFLAGS) $<
diff --git a/TESTING/EIG/pcgseptst.f b/TESTING/EIG/pcgseptst.f
index 4dd74d3..e1ef930 100644
--- a/TESTING/EIG/pcgseptst.f
+++ b/TESTING/EIG/pcgseptst.f
@@ -547,6 +547,11 @@
$ WORK( INDWORK ), SIZETMS, IPREPAD, IPOSTPAD,
$ PADVAL+4.0E+0 )
*
+*
+* WKNOWN ... NOT SET, GUESS A DEFAULT
+*
+ WKNOWN = .TRUE.
+
ELSE
IINFO = 1
END IF
diff --git a/TESTING/EIG/pclasizeheevr.f b/TESTING/EIG/pclasizeheevr.f
new file mode 100644
index 0000000..32c839b
--- /dev/null
+++ b/TESTING/EIG/pclasizeheevr.f
@@ -0,0 +1,188 @@
+ SUBROUTINE PCLASIZEHEEVR( WKNOWN, RANGE, N, DESCA, VL, VU, IL, IU,
+ $ ISEED, WIN, MAXSIZE, VECSIZE, VALSIZE )
+*
+* -- ScaLAPACK routine (@(MODE)version *TBA*) --
+* University of California, Berkeley and
+* University of Tennessee, Knoxville.
+* October 21, 2006
+*
+ IMPLICIT NONE
+*
+* .. Scalar Arguments ..
+ LOGICAL WKNOWN
+ CHARACTER RANGE
+ INTEGER IL, IU, MAXSIZE, N, VALSIZE, VECSIZE
+ REAL VL, VU
+
+* ..
+* .. Array Arguments ..
+ INTEGER DESCA( * ), ISEED( 4 )
+ REAL WIN( * )
+* ..
+*
+* Purpose
+* =======
+*
+* PCLASIZEHEEVR computes the amount of memory needed by PCHEEVR
+* to ensure:
+* 1) Orthogonal Eigenvectors
+* 2) Eigenpairs with small residual norms
+*
+* Arguments
+* =========
+*
+* WKNOWN (global input) INTEGER
+* .FALSE.: WIN does not contain the eigenvalues
+* .TRUE.: WIN does contain the eigenvalues
+*
+* RANGE (global input) CHARACTER*1
+* = 'A': all eigenvalues will be found.
+* = 'V': all eigenvalues in the interval [VL,VU]
+* will be found.
+* = 'I': the IL-th through IU-th eigenvalues will be found.
+*
+* N (global input) INTEGER
+* Size of the matrix to be tested. (global size)
+*
+* DESCA (global input) INTEGER array dimension ( DLEN_ )
+*
+* VL (global input/output ) REAL
+* If RANGE='V', the lower bound of the interval to be searched
+* for eigenvalues. Not referenced if RANGE = 'A' or 'I'.
+* If VL > VU, RANGE='V' and WKNOWN = .TRUE., VL is set
+* to a random value near an entry in WIN
+*
+* VU (global input/output ) REAL
+* If RANGE='V', the upper bound of the interval to be searched
+* for eigenvalues. Not referenced if RANGE = 'A' or 'I'.
+* If VL > VU, RANGE='V' and WKNOWN = .TRUE., VU is set
+* to a random value near an entry in WIN
+*
+* IL (global input/output ) INTEGER
+* If RANGE='I', the index (from smallest to largest) of the
+* smallest eigenvalue to be returned. IL >= 1.
+* Not referenced if RANGE = 'A' or 'V'.
+* If IL < 0, RANGE='I' and WKNOWN = .TRUE., IL is set
+* to a random value from 1 to N
+*
+* IU (global input/output ) INTEGER
+* If RANGE='I', the index (from smallest to largest) of the
+* largest eigenvalue to be returned. min(IL,N) <= IU <= N.
+* Not referenced if RANGE = 'A' or 'V'.
+* If IU < 0, RANGE='I' and WKNOWN = .TRUE., IU is set
+* to a random value from IL to N
+*
+* ISEED (global input/output) INTEGER array, dimension (4)
+* On entry, the seed of the random number generator; the array
+* elements must be between 0 and 4095, and ISEED(4) must be
+* odd.
+* On exit, the seed is updated.
+* ISEED is not touched unless IL, IU, VL or VU are modified.
+*
+* WIN (global input) REAL array, dimension (N)
+* If WKNOWN=1, WIN contains the eigenvalues of the matrix.
+*
+* MAXSIZE (global output) INTEGER
+* Workspace required to guarantee that PCHEEVR will return
+* orthogonal eigenvectors. IF WKNOWN=0, MAXSIZE is set to a
+* a value which guarantees orthogonality no matter what the
+* spectrum is. If WKNOWN=1, MAXSIZE is set to a value which
+* guarantees orthogonality on a matrix with eigenvalues given
+* by WIN.
+*
+* VECSIZE (global output) INTEGER
+* Workspace required to guarantee that PCHEEVR
+* will compute eigenvectors.
+*
+* VALSIZE (global output) INTEGER
+* Workspace required to guarantee that PCHEEVR
+* will compute eigenvalues.
+*
+*
+* .. Parameters ..
+ INTEGER CTXT_, MB_
+ PARAMETER ( CTXT_ = 2, MB_ = 5 )
+ REAL TWENTY
+ PARAMETER ( TWENTY = 20.0E0 )
+* ..
+* .. Local Scalars ..
+*
+ INTEGER ILMIN, IUMAX,
+ $ MQ0, MYCOL, MYIL, MYIU, MYROW, NB, NEIG, NN,
+ $ NP0, NPCOL, NPROW
+ REAL ANORM, EPS, SAFMIN
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ INTEGER ICEIL, NUMROC
+ REAL SLARAN, PSLAMCH
+ EXTERNAL LSAME, ICEIL, NUMROC, SLARAN, PSLAMCH
+* ..
+* .. External Subroutines ..
+ EXTERNAL BLACS_GRIDINFO
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, REAL, INT, MAX
+
+* ..
+* .. Executable Statements ..
+*
+ CALL BLACS_GRIDINFO( DESCA( CTXT_ ), NPROW, NPCOL, MYROW, MYCOL )
+ EPS = PSLAMCH( DESCA( CTXT_ ), 'Precision' )
+ SAFMIN = PSLAMCH( DESCA( CTXT_ ), 'Safe Minimum' )
+ NB = DESCA( MB_ )
+ NN = MAX( N, NB, 2 )
+ NP0 = NUMROC( NN, NB, 0, 0, NPROW )
+
+ VALSIZE = 3 + 5*N + MAX( 12*NN, NB*( NP0+1 ) )
+
+ IF( WKNOWN ) THEN
+ ANORM = SAFMIN / EPS
+ IF( N.GE.1 )
+ $ ANORM = MAX( ABS( WIN( 1 ) ), ABS( WIN( N ) ), ANORM )
+ IF( LSAME( RANGE, 'I' ) ) THEN
+ IF( IL.LT.0 )
+ $ IL = INT( SLARAN( ISEED )*REAL( N ) ) + 1
+ IF( IU.LT.0 )
+ $ IU = INT( SLARAN( ISEED )*REAL( N-IL ) ) + IL
+ IF( N.EQ.0 )
+ $ IU = 0
+ ELSE IF( LSAME( RANGE, 'V' ) ) THEN
+ IF( VL.GT.VU ) THEN
+ MYIL = INT( SLARAN( ISEED )*REAL( N ) ) + 1
+ MYIU = INT( SLARAN( ISEED )*REAL( N-MYIL ) ) + MYIL
+ VL = WIN( MYIL ) - TWENTY*EPS*ABS( WIN( MYIL ) )
+ VU = WIN( MYIU ) + TWENTY*EPS*ABS( WIN( MYIU ) )
+ VU = MAX( VU, VL+EPS*TWENTY*ABS( VL )+SAFMIN )
+ END IF
+ END IF
+*
+ END IF
+ IF( LSAME( RANGE, 'V' ) ) THEN
+* We do not know how many eigenvalues will be computed
+ ILMIN = 1
+ IUMAX = N
+ ELSE IF( LSAME( RANGE, 'I' ) ) THEN
+ ILMIN = IL
+ IUMAX = IU
+ ELSE IF( LSAME( RANGE, 'A' ) ) THEN
+ ILMIN = 1
+ IUMAX = N
+ END IF
+*
+ NEIG = IUMAX - ILMIN + 1
+*
+ MQ0 = NUMROC( MAX( NEIG, NB, 2 ), NB, 0, 0, NPCOL )
+*
+ VECSIZE = 3 + 5*N + MAX( 18*NN, NP0*MQ0+2*NB*NB ) +
+ $ (2 + ICEIL( NEIG, NPROW*NPCOL ))*NN
+
+ VALSIZE = MAX(3, VALSIZE)
+ VECSIZE = MAX(3, VECSIZE)
+ MAXSIZE = VECSIZE
+*
+ RETURN
+*
+* End of PCLASIZEHEEVR
+*
+ END
diff --git a/TESTING/EIG/pclasizesepr.f b/TESTING/EIG/pclasizesepr.f
new file mode 100644
index 0000000..771390c
--- /dev/null
+++ b/TESTING/EIG/pclasizesepr.f
@@ -0,0 +1,167 @@
+ SUBROUTINE PCLASIZESEPR( DESCA, IPREPAD, IPOSTPAD, SIZEMQRLEFT,
+ $ SIZEMQRRIGHT, SIZEQRF, SIZETMS, SIZEQTQ,
+ $ SIZECHK, SIZEHEEVR, RSIZEHEEVR,
+ $ ISIZEHEEVR, SIZESUBTST, RSIZESUBTST,
+ $ ISIZESUBTST, SIZETST, RSIZETST,
+ $ ISIZETST )
+*
+* -- ScaLAPACK routine (@(MODE)version *TBA*) --
+* University of California, Berkeley and
+* University of Tennessee, Knoxville.
+* October 21, 2006
+*
+ IMPLICIT NONE
+*
+* .. Scalar Arguments ..
+ INTEGER IPOSTPAD, IPREPAD, ISIZEHEEVR, ISIZESUBTST,
+ $ ISIZETST, RSIZEHEEVR, RSIZESUBTST, RSIZETST,
+ $ SIZECHK, SIZEHEEVR, SIZEMQRLEFT, SIZEMQRRIGHT,
+ $ SIZEQRF, SIZEQTQ, SIZESUBTST, SIZETMS, SIZETST
+* ..
+* .. Array Arguments ..
+ INTEGER DESCA( * )
+*
+* Purpose
+* =======
+*
+* PCLASIZESEPR computes the amount of memory needed by
+* various SEPR test routines, as well as PCHEEVR itself.
+*
+* Arguments
+* =========
+*
+* DESCA (global input) INTEGER array dimension ( DLEN_ )
+* Array descriptor for dense matrix.
+*
+* SIZEMQRLEFT LWORK for the 1st PCUNMQR call in PCLAGHE
+*
+* SIZEMQRRIGHT LWORK for the 2nd PCUNMQR call in PCLAGHE
+*
+* SIZEQRF LWORK for PCGEQRF in PCLAGHE
+*
+* SIZETMS LWORK for PCLATMS
+*
+* SIZEQTQ LWORK for PCSEPQTQ
+*
+* SIZECHK LWORK for PCSEPCHK
+*
+* SIZEHEEVR LWORK for PCHEEVR
+*
+* RSIZEHEEVR LRWORK for PCHEEVR
+*
+* ISIZEHEEVR LIWORK for PCHEEVR
+*
+* SIZESUBTST LWORK for PCSEPRSUBTST
+*
+* RSIZESUBTST LRWORK for PCSEPRSUBTST
+*
+* ISIZESUBTST LIWORK for PCSEPRSUBTST
+*
+* SIZETST LWORK for PCSEPRTST
+*
+* RSIZETST LRWORK for PCSEPRTST
+*
+* ISIZETST LIWORK for PCSEPRTST
+*
+*
+* .. Parameters ..
+ INTEGER CTXT_, M_,
+ $ MB_, NB_, RSRC_, CSRC_, LLD_
+ PARAMETER (
+ $ CTXT_ = 2, M_ = 3, MB_ = 5, NB_ = 6,
+ $ RSRC_ = 7, CSRC_ = 8, LLD_ = 9 )
+* ..
+* .. Local Scalars ..
+ INTEGER CSRC_A, IACOL, IAROW, ICOFFA, IROFFA, LCM,
+ $ LCMQ, LDA, MQ0, MYCOL, MYROW, N, NB, NEIG, NN,
+ $ NNP, NP, NP0, NPCOL, NPROW, NQ, RSRC_A
+ INTEGER ANB, ICTXT, NHETRD_LWOPT, NPS, SQNPC
+* ..
+* .. External Functions ..
+ INTEGER ICEIL, ILCM, INDXG2P, NUMROC
+ EXTERNAL ICEIL, ILCM, INDXG2P, NUMROC
+ INTEGER PJLAENV
+ EXTERNAL PJLAENV
+*
+* .. External Subroutines ..
+ EXTERNAL BLACS_GRIDINFO
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC DBLE, INT, MAX, SQRT
+* ..
+* .. Executable Statements ..
+*
+ N = DESCA( M_ )
+ NB = DESCA( MB_ )
+ RSRC_A = DESCA( RSRC_ )
+ CSRC_A = DESCA( CSRC_ )
+*
+ LDA = DESCA( LLD_ )
+ CALL BLACS_GRIDINFO( DESCA( CTXT_ ), NPROW, NPCOL, MYROW, MYCOL )
+*
+ LCM = ILCM( NPROW, NPCOL )
+ LCMQ = LCM / NPCOL
+ IROFFA = 0
+ ICOFFA = 0
+ IAROW = INDXG2P( 1, NB, MYROW, RSRC_A, NPROW )
+ IACOL = INDXG2P( 1, NB, MYCOL, CSRC_A, NPCOL )
+ NP = NUMROC( N+IROFFA, NB, MYROW, IAROW, NPROW )
+ NQ = NUMROC( N+ICOFFA, NB, MYCOL, IACOL, NPCOL )
+ SIZEMQRLEFT = MAX( ( NB*( NB-1 ) ) / 2, ( NP+NQ )*NB ) + NB*NB
+ SIZEMQRRIGHT = MAX( ( NB*( NB-1 ) ) / 2,
+ $ ( NQ+MAX( NP+NUMROC( NUMROC( N+ICOFFA, NB, 0, 0,
+ $ NPCOL ), NB, 0, 0, LCMQ ), NP ) )*NB ) + NB*NB
+ SIZEQRF = NB*NP + NB*NQ + NB*NB
+ SIZETMS = ( LDA+1 )*MAX( 1, NQ ) +
+ $ MAX( SIZEMQRLEFT, SIZEMQRRIGHT, SIZEQRF )
+*
+ NP0 = NUMROC( N, DESCA( MB_ ), 0, 0, NPROW )
+ MQ0 = NUMROC( N, DESCA( NB_ ), 0, 0, NPCOL )
+ SIZEQTQ = 2 + MAX( DESCA( MB_ ), 2 )*( 2*NP0+MQ0 )
+ SIZECHK = NUMROC( N, DESCA( NB_ ), MYCOL, 0, NPCOL )
+*
+ NEIG = N
+ NN = MAX( N, NB, 2 ) + 1
+ NP0 = NUMROC( NN, NB, 0, 0, NPROW )
+ MQ0 = NUMROC( MAX( NEIG, NB, 2 ), NB, 0, 0, NPCOL )
+ NNP = MAX( N, NPROW*NPCOL+1, 4 )
+*
+*
+ SIZEHEEVR = 1+N + ( NP0+MQ0+NB )*NB
+ SIZEHEEVR = MAX(3, SIZEHEEVR)
+ RSIZEHEEVR = 1 + 5*N + MAX( 18*NN, NP0*MQ0+2*NB*NB ) +
+ $ (2 + ICEIL( NEIG, NPROW*NPCOL ))*NN
+ RSIZEHEEVR = MAX(3, RSIZEHEEVR)
+*
+ ISIZEHEEVR = 12*NNP + 2*N
+*
+ ICTXT = DESCA( CTXT_ )
+ ANB = PJLAENV( ICTXT, 3, 'PCHETTRD', 'L', 0, 0, 0, 0 )
+ SQNPC = INT( SQRT( DBLE( NPROW*NPCOL ) ) )
+ NPS = MAX( NUMROC( N, 1, 0, 0, SQNPC ), 2*ANB )
+ NHETRD_LWOPT = 2*( ANB+1 )*( 4*NPS+2 ) + ( NPS+2 )*NPS
+ SIZEHEEVR = MAX( SIZEHEEVR, N + NHETRD_LWOPT )
+*
+ SIZESUBTST = MAX( SIZETMS, SIZEHEEVR ) +
+ $ IPREPAD + IPOSTPAD
+ RSIZESUBTST = MAX( SIZEQTQ, SIZECHK, RSIZEHEEVR ) +
+ $ IPREPAD + IPOSTPAD
+ ISIZESUBTST = ISIZEHEEVR + IPREPAD + IPOSTPAD
+*
+* Allow room for A, COPYA, Z, WORK
+*
+ SIZETST = 3*( LDA*NP+IPREPAD+IPOSTPAD ) + SIZESUBTST
+*
+* Allow room for DIAG, WIN, WNEW, GAP, RWORK
+*
+ RSIZETST = 4*( N+IPREPAD+IPOSTPAD ) + RSIZESUBTST
+*
+* Allow room for IFAIL, ICLUSTR, and IWORK
+* (only needed for PCHEEVX)
+*
+ ISIZETST = N + 2*NPROW*NPCOL + 2*( IPREPAD+IPOSTPAD ) +
+ $ ISIZESUBTST
+*
+*
+ RETURN
+ END
diff --git a/TESTING/EIG/pcsepchk.f b/TESTING/EIG/pcsepchk.f
index aa4bafa..6c609e3 100644
--- a/TESTING/EIG/pcsepchk.f
+++ b/TESTING/EIG/pcsepchk.f
@@ -4,10 +4,9 @@
$ Q, IQ, JQ, DESCQ, C, IC, JC, DESCC, W, WORK,
$ LWORK, TSTNRM, RESULT )
*
-* -- ScaLAPACK routine (version 1.7) --
-* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
-* and University of California, Berkeley.
-* November 15, 1997
+* -- ScaLAPACK routine (version 2.0.2) --
+* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver
+* May 1 2012
*
* .. Scalar Arguments ..
INTEGER IA, IC, IQ, JA, JC, JQ, LWORK, MS, NV, RESULT
@@ -216,7 +215,7 @@
CALL BLACS_GRIDINFO( DESCA( CTXT_ ), NPROW, NPCOL, MYROW, MYCOL )
*
INFO = 0
- CALL CHK1MAT( MS, 1, MS, 2, IA, JA, DESCA, 6, INFO )
+ CALL CHK1MAT( MS, 1, MS, 1, IA, JA, DESCA, 6, INFO )
CALL CHK1MAT( MS, 1, NV, 2, IQ, JQ, DESCQ, 12, INFO )
CALL CHK1MAT( MS, 1, NV, 2, IC, JC, DESCC, 16, INFO )
*
diff --git a/TESTING/EIG/pcseprdriver.f b/TESTING/EIG/pcseprdriver.f
new file mode 100644
index 0000000..d57d120
--- /dev/null
+++ b/TESTING/EIG/pcseprdriver.f
@@ -0,0 +1,260 @@
+ PROGRAM PCSEPRDRIVER
+*
+* Parallel COMPLEX symmetric eigenproblem test driver for PCSYEVR
+*
+ IMPLICIT NONE
+*
+* The user should modify TOTMEM to indicate the maximum amount of
+* memory in bytes her system has. Remember to leave room in memory
+* for operating system, the BLACS buffer, etc. REALSZ
+* indicates the length in bytes on the given platform for a number,
+* real for SINGLE/DOUBLE PRECISION, and complex for COMPLEX/COMPLEX*16.
+* For example, on a standard system, the length of a
+* REAL is 8, and an integer takes up 4 bytes. Some playing around
+* to discover what the maximum value you can set MEMSIZ to may be
+* required.
+* All arrays used by factorization and solve are allocated out of
+* big array called MEM.
+*
+* TESTS PERFORMED
+* ===============
+*
+* This routine performs tests for combinations of: matrix size, process
+* configuration (nprow and npcol), block size (nb),
+* matrix type, range of eigenvalue (all, by value, by index),
+* and upper vs. lower storage.
+*
+* It returns an error message when heterogeneity is detected.
+*
+* The input file allows multiple requests where each one is
+* of the following sets:
+* matrix sizes: n
+* process configuration triples: nprow, npcol, nb
+* matrix types:
+* eigenvalue requests: all, by value, by position
+* storage (upper vs. lower): uplo
+*
+* TERMS:
+* Request - means a set of tests, which is the cross product of
+* a set of specifications from the input file.
+* Test - one element in the cross product, i.e. a specific input
+* size and type, process configuration, etc.
+*
+* .. Parameters ..
+*
+ INTEGER TOTMEM, REALSZ, NIN
+ PARAMETER ( TOTMEM = 100000000, REALSZ = 8, NIN = 11 )
+ INTEGER MEMSIZ
+ PARAMETER ( MEMSIZ = TOTMEM / REALSZ )
+* ..
+* .. Local Scalars ..
+ CHARACTER HETERO
+ CHARACTER*80 SUMMRY, USRINFO
+ INTEGER CONTEXT, IAM, INFO, ISIEEE, MAXNODES, NNOCHECK,
+ $ NOUT, NPASSED, NPROCS, NSKIPPED, NTESTS
+* ..
+* .. Local Arrays ..
+*
+ INTEGER ISEED( 4 )
+ COMPLEX MEM( MEMSIZ )
+* ..
+* .. External Functions ..
+ REAL SLAMCH
+ EXTERNAL SLAMCH
+* ..
+* .. External Subroutines ..
+*
+ EXTERNAL BLACS_EXIT, BLACS_GET, BLACS_GRIDEXIT,
+ $ BLACS_GRIDINIT, BLACS_PINFO, BLACS_SETUP,
+ $ IGAMN2D, PSLACHKIEEE, PSLASNBT, PCSEPRREQ
+* ..
+* .. Executable Statements ..
+*
+* Get starting information
+*
+ CALL BLACS_PINFO( IAM, NPROCS )
+*
+*
+ IF( IAM.EQ.0 ) THEN
+*
+* Open file and skip data file header
+*
+ OPEN( UNIT = NIN, FILE = 'SEPR.dat', STATUS = 'OLD' )
+ READ( NIN, FMT = * )SUMMRY
+ SUMMRY = ' '
+*
+* Read in user-supplied info about machine type, compiler, etc.
+*
+ READ( NIN, FMT = 9999 )USRINFO
+*
+* Read name and unit number for summary output file
+*
+ READ( NIN, FMT = * )SUMMRY
+ READ( NIN, FMT = * )NOUT
+ IF( NOUT.NE.0 .AND. NOUT.NE.6 )
+ $ OPEN( NOUT, FILE = SUMMRY, STATUS = 'UNKNOWN' )
+ READ( NIN, FMT = * )MAXNODES
+ READ( NIN, FMT = * )HETERO
+ END IF
+*
+ IF( NPROCS.LT.1 ) THEN
+ CALL BLACS_SETUP( IAM, MAXNODES )
+ NPROCS = MAXNODES
+ END IF
+*
+ CALL BLACS_GET( -1, 0, CONTEXT )
+ CALL BLACS_GRIDINIT( CONTEXT, 'R', 1, NPROCS )
+*
+ CALL PSLASNBT( ISIEEE )
+*
+ CALL IGAMN2D( CONTEXT, 'a', ' ', 1, 1, ISIEEE, 1, 1, 1, -1, -1,
+ $ 0 )
+*
+ IF( ( ISIEEE.NE.0 ) ) THEN
+ IF( IAM.EQ.0 ) THEN
+ WRITE( NOUT, FMT = 9997 )
+ WRITE( NOUT, FMT = 9996 )
+ WRITE( NOUT, FMT = 9995 )
+ END IF
+*
+ CALL PSLACHKIEEE( ISIEEE, SLAMCH( 'O' ), SLAMCH( 'U' ) )
+*
+ CALL IGAMN2D( CONTEXT, 'a', ' ', 1, 1, ISIEEE, 1, 1, 1, -1, -1,
+ $ 0 )
+*
+ IF( ISIEEE.EQ.0 ) THEN
+ GO TO 20
+ END IF
+*
+ IF( IAM.EQ.0 ) THEN
+ WRITE( NOUT, FMT = 9986 )
+ END IF
+*
+ END IF
+*
+ IF( IAM.EQ.0 ) THEN
+ WRITE( NOUT, FMT = 9999 )
+ $ 'Test ScaLAPACK symmetric eigendecomposition routine.'
+ WRITE( NOUT, FMT = 9999 )USRINFO
+ WRITE( NOUT, FMT = 9999 )' '
+ WRITE( NOUT, FMT = 9999 )'Running tests of the parallel ' //
+ $ 'symmetric eigenvalue routine: PCSYEVR.'
+ WRITE( NOUT, FMT = 9999 )'The following scaled residual ' //
+ $ 'checks will be computed:'
+ WRITE( NOUT, FMT = 9999 )' ||AQ - QL|| ' //
+ $ '/ ((abstol + ||A|| * eps) * N)'
+ WRITE( NOUT, FMT = 9999 )' ||Q^T*Q - I|| ' // '/ (N * eps)'
+ WRITE( NOUT, FMT = 9999 )
+ WRITE( NOUT, FMT = 9999 )'An explanation of the ' //
+ $ 'input/output parameters follows:'
+ WRITE( NOUT, FMT = 9999 )'RESULT : passed; or ' //
+ $ 'an indication of which eigen request test failed'
+ WRITE( NOUT, FMT = 9999 )
+ $ 'N : The number of rows and columns ' //
+ $ 'of the matrix A.'
+ WRITE( NOUT, FMT = 9999 )
+ $ 'P : The number of process rows.'
+ WRITE( NOUT, FMT = 9999 )
+ $ 'Q : The number of process columns.'
+ WRITE( NOUT, FMT = 9999 )
+ $ 'NB : The size of the square blocks' //
+ $ ' the matrix A is split into.'
+ WRITE( NOUT, FMT = 9999 )
+ $ 'THRESH : If a residual value is less ' //
+ $ 'than THRESH, RESULT = PASSED.'
+ WRITE( NOUT, FMT = 9999 )
+ $ 'TYP : matrix type (see PCSEPRTST).'
+ WRITE( NOUT, FMT = 9999 )'SUB : Subtests (Y/N).'
+ WRITE( NOUT, FMT = 9999 )'WALL : Wallclock time.'
+ WRITE( NOUT, FMT = 9999 )'CPU : CPU time.'
+ WRITE( NOUT, FMT = 9999 )'CHK : ||AQ - QL|| ' //
+ $ '/ ((abstol + ||A|| * eps) * N)'
+ WRITE( NOUT, FMT = 9999 )'QTQ : ||Q^T*Q - I||/ (N * eps)'
+ WRITE( NOUT, FMT = 9999 )
+ $ ' : when the adjusted QTQ norm exceeds THRESH',
+ $ ' it is printed,'
+ WRITE( NOUT, FMT = 9999 )
+ $ ' otherwise the true QTQ norm is printed.'
+ WRITE( NOUT, FMT = 9999 )
+ $ ' : If more than one test is done, CHK and QTQ '
+ WRITE( NOUT, FMT = 9999 )
+ $ ' are the max over all eigentests performed.'
+ WRITE( NOUT, FMT = 9999 )
+ $ 'TEST : EVR - testing PCSYEVR'
+ WRITE( NOUT, FMT = 9999 )' '
+ END IF
+*
+ NTESTS = 0
+ NPASSED = 0
+ NSKIPPED = 0
+ NNOCHECK = 0
+*
+ IF( IAM.EQ.0 ) THEN
+ WRITE( NOUT, FMT = 9979 )
+ WRITE( NOUT, FMT = 9978 )
+ END IF
+*
+ 10 CONTINUE
+*
+ ISEED( 1 ) = 139
+ ISEED( 2 ) = 1139
+ ISEED( 3 ) = 2139
+ ISEED( 4 ) = 3139
+*
+ CALL PCSEPRREQ( HETERO, NIN, MEM, MEMSIZ, NOUT, ISEED, NTESTS,
+ $ NSKIPPED, NNOCHECK, NPASSED, INFO )
+ IF( INFO.EQ.0 )
+ $ GO TO 10
+*
+ IF( IAM.EQ.0 ) THEN
+ WRITE( NOUT, FMT = 9985 )NTESTS
+ WRITE( NOUT, FMT = 9984 )NPASSED
+ WRITE( NOUT, FMT = 9983 )NNOCHECK
+ WRITE( NOUT, FMT = 9982 )NSKIPPED
+ WRITE( NOUT, FMT = 9981 )NTESTS - NPASSED - NSKIPPED -
+ $ NNOCHECK
+ WRITE( NOUT, FMT = * )
+ WRITE( NOUT, FMT = * )
+ WRITE( NOUT, FMT = 9980 )
+ END IF
+*
+* Uncomment this line on SUN systems to avoid the useless print out
+*
+c CALL IEEE_FLAGS( 'clear', 'exception', 'underflow', ' ')
+*
+ 20 CONTINUE
+ IF( IAM.EQ.0 ) THEN
+ CLOSE ( NIN )
+ IF( NOUT.NE.6 .AND. NOUT.NE.0 )
+ $ CLOSE ( NOUT )
+ END IF
+*
+ CALL BLACS_GRIDEXIT( CONTEXT )
+*
+ CALL BLACS_EXIT( 0 )
+ STOP
+*
+ 9999 FORMAT( A )
+ 9997 FORMAT( 'Check if overflow is handled in ieee default manner.' )
+ 9996 FORMAT( 'If this is the last output you see, you should assume')
+ 9995 FORMAT( 'that overflow caused a floating point exception.' )
+*
+ 9986 FORMAT( 'Test ok. The system appears to handle ieee overflow.' )
+*
+ 9985 FORMAT( 'Finished ', I6, ' tests, with the following results:' )
+ 9984 FORMAT( I5, ' tests completed and passed residual checks.' )
+ 9983 FORMAT( I5, ' tests completed without checking.' )
+ 9982 FORMAT( I5, ' tests skipped for lack of memory.' )
+ 9981 FORMAT( I5, ' tests completed and failed.' )
+ 9980 FORMAT( 'END OF TESTS.' )
+ 9979 FORMAT( ' N NB P Q TYP SUB WALL CPU ',
+ $ ' CHK QTQ CHECK TEST' )
+ 9978 FORMAT( ' ----- --- --- --- --- --- -------- --------',
+ $ ' --------- --------- ----- ----' )
+*
+* End of PCSEPRDRIVER
+*
+ END
+
+
+
diff --git a/TESTING/EIG/pcseprreq.f b/TESTING/EIG/pcseprreq.f
new file mode 100644
index 0000000..e2e100e
--- /dev/null
+++ b/TESTING/EIG/pcseprreq.f
@@ -0,0 +1,227 @@
+ SUBROUTINE PCSEPRREQ( HETERO, NIN, MEM, MEMSIZE, NOUT, ISEED,
+ $ NTESTS, NSKIPPED, NNOCHECK, NPASSED, INFO )
+*
+* -- ScaLAPACK routine (@(MODE)version *TBA*) --
+* University of California, Berkeley and
+* University of Tennessee, Knoxville.
+* October 21, 2006
+*
+ IMPLICIT NONE
+*
+* .. Scalar Arguments ..
+ CHARACTER HETERO
+ INTEGER INFO, MEMSIZE, NIN, NNOCHECK, NOUT, NPASSED,
+ $ NSKIPPED, NTESTS
+* ..
+* .. Array Arguments ..
+ INTEGER ISEED( 4 )
+ COMPLEX MEM( MEMSIZE )
+*
+* Purpose
+* =======
+*
+* PCSEPRREQ performs one request from the input file 'SEPR.dat'
+* A request is the cross product of the specifications in the
+* input file. It prints one line per test.
+*
+* Arguments
+* =========
+*
+* NIN (local input) INTEGER
+* The unit number for the input file 'SEPR.dat'
+*
+* MEM (local input ) COMPLEX ARRAY, dimension MEMSIZE
+* Array encompassing the available single precision memory
+*
+* MEMSIZE (local input) INTEGER
+* Size of MEM array
+*
+* NOUT (local input) INTEGER
+* The unit number for output file.
+* NOUT = 6, output to screen,
+* NOUT = 0, output to stderr.
+* NOUT = 13, output to file, divide thresh by 10
+* NOUT = 14, output to file, divide thresh by 20
+* Only used on node 0.
+* NOUT = 13, 14 allow the threshold to be tighter for our
+* internal testing which means that when a user reports
+* a threshold error, it is more likely to be significant.
+*
+* ISEED (global input/output) INTEGER array, dimension 4
+* Random number generator seed
+*
+* NTESTS (global input/output) INTEGER
+* NTESTS = NTESTS + tests requested
+*
+* NSKIPPED (global input/output) INTEGER
+* NSKIPPED = NSKIPPED + tests skipped
+*
+* NNOCHECK (global input/output) INTEGER
+* NNOCHECK = NNOCHECK + tests completed but not checked
+*
+* NPASSED (global input/output) INTEGER
+* NPASSED = NPASSED + tests which passed all checks
+*
+* INFO (global output) INTEGER
+* 0 = test request ran
+* -1 = end of file
+* -2 = incorrect .dat file
+*
+* .. Parameters ..
+*
+ INTEGER DLEN_
+ PARAMETER ( DLEN_ = 9 )
+ INTEGER REALSZ, INTGSZ
+ PARAMETER ( REALSZ = 4, INTGSZ = 4 )
+ INTEGER KMPXSZ
+ PARAMETER ( KMPXSZ = 8 )
+ INTEGER MAXSETSIZE
+ PARAMETER ( MAXSETSIZE = 50 )
+* ..
+* .. Local Scalars ..
+ CHARACTER SUBTESTS
+ INTEGER CONTEXT, IAM, IMIDPAD, INITCON, IPOSTPAD,
+ $ IPREPAD, ISIZESUBTST, ISIZEEVR, ISIZETST,
+ $ LDA, LLWORK, MATSIZE, MATTYPE, MYCOL, MYROW, N,
+ $ NB, NMATSIZES, NMATTYPES, NNODES, NP, NPCOL,
+ $ NPCONFIGS, NPROW, NQ, NUPLOS, ORDER, PCONFIG,
+ $ PTRA, PTRCOPYA, PTRGAP, PTRICLUS, PTRIFAIL,
+ $ PTRIWRK, PTRW, PTRW2, PTRWORK, PTRZ, RES,
+ $ SIZECHK, SIZEMQRLEFT, SIZEMQRRIGHT, SIZEQRF,
+ $ SIZEQTQ, SIZESUBTST, SIZEEVR,
+ $ SIZETMS, SIZETST, UPLO
+ INTEGER PTRRWORK, RSIZEEVR, RSIZESUBTST, RSIZETST
+*
+ REAL ABSTOL, THRESH
+* ..
+* .. Local Arrays ..
+ CHARACTER UPLOS( 2 )
+ INTEGER DESCA( DLEN_ ), MATSIZES( MAXSETSIZE ),
+ $ MATTYPES( MAXSETSIZE ), NBS( MAXSETSIZE ),
+ $ NPCOLS( MAXSETSIZE ), NPROWS( MAXSETSIZE )
+* ..
+* .. External Functions ..
+ INTEGER ICEIL, NUMROC
+ EXTERNAL ICEIL, NUMROC
+* ..
+* .. External Subroutines ..
+ EXTERNAL BLACS_ABORT, BLACS_GET, BLACS_GRIDEXIT,
+ $ BLACS_GRIDINFO, BLACS_GRIDINIT, BLACS_PINFO,
+ $ DESCINIT, PCLASIZESEPR, PSSEPINFO, PCSEPRTST
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX
+* ..
+* .. Executable Statements ..
+*
+ CALL BLACS_PINFO( IAM, NNODES )
+ CALL BLACS_GET( -1, 0, INITCON )
+ CALL BLACS_GRIDINIT( INITCON, 'R', 1, NNODES )
+*
+ CALL PSSEPINFO( INITCON, IAM, NIN, NOUT, MAXSETSIZE, NMATSIZES,
+ $ MATSIZES, NUPLOS, UPLOS, NPCONFIGS, NPROWS,
+ $ NPCOLS, NBS, NMATTYPES, MATTYPES, 22, SUBTESTS,
+ $ THRESH, ORDER, ABSTOL, INFO )
+*
+ CALL BLACS_GRIDEXIT( INITCON )
+*
+ IF( INFO.EQ.0 ) THEN
+*
+ DO 40 MATSIZE = 1, NMATSIZES
+*
+ DO 30 PCONFIG = 1, NPCONFIGS
+*
+ DO 20 MATTYPE = 1, NMATTYPES
+*
+ DO 10 UPLO = 1, NUPLOS
+*
+ N = MATSIZES( MATSIZE )
+ ORDER = N
+*
+ NPROW = NPROWS( PCONFIG )
+ NPCOL = NPCOLS( PCONFIG )
+ NB = NBS( PCONFIG )
+*
+ NP = NUMROC( N, NB, 0, 0, NPROW )
+ NQ = NUMROC( N, NB, 0, 0, NPCOL )
+ IPREPAD = MAX( NB, NP )
+ IMIDPAD = NB
+ IPOSTPAD = MAX( NB, NQ )
+*
+ LDA = MAX( NP, 1 ) + IMIDPAD
+*
+ CALL BLACS_GET( -1, 0, CONTEXT )
+ CALL BLACS_GRIDINIT( CONTEXT, 'R', NPROW, NPCOL )
+ CALL BLACS_GRIDINFO( CONTEXT, NPROW, NPCOL, MYROW,
+ $ MYCOL )
+*
+ IF( MYROW.GE.0 ) THEN
+ CALL DESCINIT( DESCA, N, N, NB, NB, 0, 0,
+ $ CONTEXT, LDA, INFO )
+ CALL PCLASIZESEPR( DESCA, IPREPAD, IPOSTPAD,
+ $ SIZEMQRLEFT, SIZEMQRRIGHT,
+ $ SIZEQRF, SIZETMS, SIZEQTQ,
+ $ SIZECHK, SIZEEVR, RSIZEEVR,
+ $ ISIZEEVR, SIZESUBTST,
+ $ RSIZESUBTST, ISIZESUBTST,
+ $ SIZETST, RSIZETST, ISIZETST )
+*
+ PTRA = 1
+ PTRZ = PTRA + LDA*NQ + IPREPAD + IPOSTPAD
+ PTRCOPYA = PTRZ + LDA*NQ + IPREPAD + IPOSTPAD
+ PTRW = PTRCOPYA + LDA*NQ + IPREPAD + IPOSTPAD
+ PTRW2 = PTRW + ICEIL( MAX( N, 1 )+IPREPAD+
+ $ IPOSTPAD, KMPXSZ / REALSZ )
+ PTRWORK = PTRW2 + ICEIL( MAX( N, 1 )+IPREPAD+
+ $ IPOSTPAD, KMPXSZ / REALSZ )
+ PTRGAP = PTRWORK + SIZETST + IPREPAD + IPOSTPAD
+ PTRIFAIL = PTRGAP + ICEIL( NPROW*NPCOL+IPREPAD+
+ $ IPOSTPAD, KMPXSZ / REALSZ )
+ PTRICLUS = PTRIFAIL + ICEIL( N+IPREPAD+IPOSTPAD,
+ $ KMPXSZ / INTGSZ )
+ PTRIWRK = PTRICLUS + ICEIL( 2*NPROW*NPCOL+
+ $ IPREPAD+IPOSTPAD, KMPXSZ / INTGSZ )
+ PTRRWORK = PTRIWRK + ICEIL( ISIZETST+IPREPAD+
+ $ IPOSTPAD, KMPXSZ / INTGSZ )
+ LLWORK = ( MEMSIZE-PTRRWORK+1 )*KMPXSZ / REALSZ
+
+ NTESTS = NTESTS + 1
+ IF( LLWORK.LT.RSIZETST ) THEN
+ NSKIPPED = NSKIPPED + 1
+ ELSE
+ CALL PCSEPRTST( DESCA, UPLOS( UPLO ), N,
+ $ MATTYPES( MATTYPE ), SUBTESTS,
+ $ THRESH, N, ABSTOL, ISEED,
+ $ MEM( PTRA ), MEM( PTRCOPYA ),
+ $ MEM( PTRZ ), LDA, MEM( PTRW ),
+ $ MEM( PTRW2 ), MEM( PTRIFAIL ),
+ $ MEM( PTRICLUS ),
+ $ MEM( PTRGAP ), IPREPAD,
+ $ IPOSTPAD, MEM( PTRWORK ),
+ $ SIZETST, MEM( PTRRWORK ),
+ $ LLWORK, MEM( PTRIWRK ),
+ $ ISIZETST, HETERO, NOUT, RES )
+*
+ IF( RES.EQ.0 ) THEN
+ NPASSED = NPASSED + 1
+ ELSE IF( RES.EQ.2 ) THEN
+ NNOCHECK = NNOCHECK + 1
+ ELSE IF( RES.EQ.3 ) THEN
+ NSKIPPED = NSKIPPED + 1
+ WRITE( NOUT, FMT = * )' PCSEPRREQ failed'
+ CALL BLACS_ABORT( CONTEXT, -1 )
+ END IF
+ END IF
+ CALL BLACS_GRIDEXIT( CONTEXT )
+ END IF
+ 10 CONTINUE
+ 20 CONTINUE
+ 30 CONTINUE
+ 40 CONTINUE
+ END IF
+*
+ RETURN
+*
+* End of PCSEPRREQ
+*
+ END
diff --git a/TESTING/EIG/pcseprsubtst.f b/TESTING/EIG/pcseprsubtst.f
new file mode 100644
index 0000000..d54ec17
--- /dev/null
+++ b/TESTING/EIG/pcseprsubtst.f
@@ -0,0 +1,827 @@
+ SUBROUTINE PCSEPRSUBTST( WKNOWN, JOBZ, RANGE, UPLO, N, VL, VU, IL,
+ $ IU, THRESH, ABSTOL, A, COPYA, Z, IA, JA,
+ $ DESCA, WIN, WNEW, IFAIL, ICLUSTR, GAP,
+ $ IPREPAD, IPOSTPAD, WORK, LWORK, RWORK,
+ $ LRWORK, LWORK1, IWORK, LIWORK, RESULT,
+ $ TSTNRM, QTQNRM, NOUT )
+*
+* -- ScaLAPACK routine (@(MODE)version *TBA*) --
+* University of California, Berkeley and
+* University of Tennessee, Knoxville.
+* October 21, 2006
+*
+ IMPLICIT NONE
+*
+* .. Scalar Arguments ..
+ LOGICAL WKNOWN
+ CHARACTER JOBZ, RANGE, UPLO
+ INTEGER IA, IL, IPOSTPAD, IPREPAD, IU, JA, LIWORK,
+ $ LWORK, LWORK1, N, NOUT, RESULT
+ REAL ABSTOL, QTQNRM, THRESH, TSTNRM, VL, VU
+ INTEGER LRWORK
+* ..
+* .. Array Arguments ..
+ INTEGER DESCA( * ), ICLUSTR( * ), IFAIL( * ),
+ $ IWORK( * )
+ COMPLEX A( * ), COPYA( * ), WORK( * ), Z( * )
+ REAL GAP( * ), RWORK( * ), WIN( * ), WNEW( * )
+* ..
+*
+* Purpose
+* =======
+*
+* PCSEPRSUBTST calls PCSYEVR and then tests its output.
+* If JOBZ = 'V' then the following two tests are performed:
+* |AQ -QL| / (abstol + eps * norm(A) ) < N*THRESH
+* |QT * Q - I| / eps < N*THRESH
+* If WKNOWN then
+* we check to make sure that the eigenvalues match expectations
+* i.e. |WIN - WNEW(1+IPREPAD)| / (eps * |WIN|) < THRESH
+* where WIN is the array of eigenvalues computed.
+*
+* Arguments
+* =========
+*
+* NP = the number of rows local to a given process.
+* NQ = the number of columns local to a given process.
+*
+* WKNOWN (global input) INTEGER
+* .FALSE.: WIN does not contain the eigenvalues
+* .TRUE.: WIN does contain the eigenvalues
+*
+* JOBZ (global input) CHARACTER*1
+* Specifies whether or not to compute the eigenvectors:
+* = 'N': Compute eigenvalues only.
+* = 'V': Compute eigenvalues and eigenvectors.
+* Must be 'V' on first call.
+*
+* RANGE (global input) CHARACTER*1
+* = 'A': all eigenvalues will be found.
+* = 'V': all eigenvalues in the interval [VL,VU]
+* will be found.
+* = 'I': the IL-th through IU-th eigenvalues will be found.
+* Must be 'A' on first call.
+*
+* UPLO (global input) CHARACTER*1
+* Specifies whether the upper or lower triangular part of the
+* matrix A is stored:
+* = 'U': Upper triangular
+* = 'L': Lower triangular
+*
+* N (global input) INTEGER
+* Size of the matrix to be tested. (global size)
+*
+* VL (global input) REAL
+* If RANGE='V', the lower bound of the interval to be searched
+* for eigenvalues. Not referenced if RANGE = 'A' or 'I'.
+*
+* VU (global input) REAL
+* If RANGE='V', the upper bound of the interval to be searched
+* for eigenvalues. Not referenced if RANGE = 'A' or 'I'.
+*
+* IL (global input) INTEGER
+* If RANGE='I', the index (from smallest to largest) of the
+* smallest eigenvalue to be returned. IL >= 1.
+* Not referenced if RANGE = 'A' or 'V'.
+*
+* IU (global input) INTEGER
+* If RANGE='I', the index (from smallest to largest) of the
+* largest eigenvalue to be returned. min(IL,N) <= IU <= N.
+* Not referenced if RANGE = 'A' or 'V'.
+*
+* THRESH (global input) REAL
+* A test will count as "failed" if the "error", computed as
+* described below, exceeds THRESH. Note that the error
+* is scaled to be O(1), so THRESH should be a reasonably
+* small multiple of 1, e.g., 100 or 250. In particular,
+* it should not depend on the size of the matrix.
+* It must be at least zero.
+*
+* ABSTOL (global input) REAL
+* The absolute tolerance for the residual test.
+*
+* A (local workspace) COMPLEX array
+* global dimension (N, N), local dimension (DESCA(DLEN_), NQ)
+* The test matrix, which is subsequently overwritten.
+* A is distributed in a 2D-block cyclic manner over both rows
+* and columns.
+* A has already been padded front and back, use A(1+IPREPAD)
+*
+* COPYA (local input) COMPLEX array, dimension(N*N)
+* COPYA holds a copy of the original matrix A
+* identical in both form and content to A
+*
+* Z (local workspace) COMPLEX array, dim (N*N)
+* Z is distributed in the same manner as A
+* Z contains the eigenvector matrix
+* Z is used as workspace by the test routines
+* PCSEPCHK and PCSEPQTQ.
+* Z has already been padded front and back, use Z(1+IPREPAD)
+*
+* IA (global input) INTEGER
+* On entry, IA specifies the global row index of the submatrix
+* of the global matrix A, COPYA and Z to operate on.
+*
+* JA (global input) INTEGER
+* On entry, IA specifies the global column index of the submat
+* of the global matrix A, COPYA and Z to operate on.
+*
+* DESCA (global/local input) INTEGER array of dimension 8
+* The array descriptor for the matrix A, COPYA and Z.
+*
+* WIN (global input) REAL array, dimension (N)
+* If .not. WKNOWN, WIN is ignored on input
+* Otherwise, WIN() is taken as the standard by which the
+* eigenvalues are to be compared against.
+*
+* WNEW (global workspace) REAL array, dimension (N)
+* The computed eigenvalues.
+* If JOBZ <> 'V' or RANGE <> 'A' these eigenvalues are
+* compared against those in WIN().
+* WNEW has already been padded front and back,
+* use WNEW(1+IPREPAD)
+*
+* IFAIL (global output) INTEGER array, dimension (N)
+* If JOBZ = 'V', then on normal exit, the first M elements of
+* IFAIL are zero. If INFO > 0 on exit, then IFAIL contains the
+* indices of the eigenvectors that failed to converge.
+* If JOBZ = 'N', then IFAIL is not referenced.
+* IFAIL has already been padded front and back,
+* use IFAIL(1+IPREPAD)
+*
+* ICLUSTR (global workspace) integer array, dimension (2*NPROW*NPCOL)
+*
+* GAP (global workspace) REAL array,
+* dimension (NPROW*NPCOL)
+*
+* WORK (local workspace) COMPLEX array, dimension (LWORK)
+* WORK has already been padded front and back,
+* use WORK(1+IPREPAD)
+*
+* LWORK (local input) INTEGER
+* The actual length of the array WORK after padding.
+*
+* RWORK (local workspace) DOUBLE PRECISION array, dimension (LRWORK)
+* RWORK has already been padded front and back,
+* use RWORK(1+IPREPAD)
+*
+* LRWORK (local input) INTEGER
+* The actual length of the array RWORK after padding.
+*
+* LWORK1 (local input) INTEGER
+* The amount of real workspace to pass to the eigensolver.
+*
+* IWORK (local workspace) INTEGER array, dimension (LIWORK)
+* IWORK has already been padded front and back,
+* use IWORK(1+IPREPAD)
+*
+* LIWORK (local input) INTEGER
+* The length of the array IWORK after padding.
+*
+* RESULT (global output) INTEGER
+* The result of this call.
+* RESULT = -3 => This process did not participate
+* RESULT = 0 => All tests passed
+* RESULT = 1 => ONe or more tests failed
+*
+* TSTNRM (global output) REAL
+* |AQ- QL| / (ABSTOL+EPS*|A|)*N
+*
+* QTQNRM (global output) REAL
+* |QTQ -I| / N*EPS
+*
+* .. Parameters ..
+*
+ INTEGER DLEN_, CTXT_, M_, N_,
+ $ MB_, NB_, RSRC_, CSRC_, LLD_
+ PARAMETER ( DLEN_ = 9,
+ $ CTXT_ = 2, M_ = 3, N_ = 4, MB_ = 5, NB_ = 6,
+ $ RSRC_ = 7, CSRC_ = 8, LLD_ = 9 )
+ REAL PADVAL, FIVE, NEGONE
+ PARAMETER ( PADVAL = 13.5285E0, FIVE = 5.0E0,
+ $ NEGONE = -1.0E0 )
+ COMPLEX ZPADVAL
+ PARAMETER ( ZPADVAL = ( 13.989E0, 1.93E0 ) )
+ INTEGER IPADVAL
+ PARAMETER ( IPADVAL = 927 )
+* ..
+* .. Local Scalars ..
+ LOGICAL MISSLARGEST, MISSSMALLEST
+ INTEGER I, IAM, INDIWRK, INFO, ISIZESUBTST, ISIZEEVR,
+ $ ISIZETST, J, M, MAXEIGS, MAXIL, MAXIU, MAXSIZE,
+ $ MINIL, MQ, MYCOL, MYIL, MYROW, NCLUSTERS, NP,
+ $ NPCOL, NPROW, NQ, NZ, OLDIL, OLDIU, OLDNZ, RES,
+ $ SIZECHK, SIZEMQRLEFT, SIZEMQRRIGHT, SIZEQRF,
+ $ SIZEQTQ, SIZESUBTST, SIZEEVR, SIZETMS,
+ $ SIZETST, VALSIZE, VECSIZE
+ INTEGER RSIZEEVR, RSIZESUBTST, RSIZETST
+ REAL EPS, EPSNORMA, ERROR, MAXERROR, MAXVU,
+ $ MINERROR, MINVL, NORMWIN, OLDVL, OLDVU,
+ $ SAFMIN
+* ..
+* .. Local Arrays ..
+ INTEGER DESCZ( DLEN_ ), ISEED( 4 ), ITMP( 2 )
+* ..
+* .. External Functions ..
+*
+ LOGICAL LSAME
+ INTEGER NUMROC
+ REAL PSLAMCH, PCLANHE
+ EXTERNAL LSAME, NUMROC, PSLAMCH, PCLANHE
+* ..
+* .. External Subroutines ..
+ EXTERNAL BLACS_GRIDINFO, CLACPY, DESCINIT, IGAMN2D,
+ $ IGAMX2D, PCCHEKPAD, PCELSET, PCFILLPAD,
+ $ PCHEEVR, PCLASIZEHEEVR, PCLASIZESEPR, PCSEPCHK,
+ $ PCSEPQTQ, PICHEKPAD, PIFILLPAD, PSCHEKPAD,
+ $ PSFILLPAD, SGAMN2D, SGAMX2D, SLBOOT, SLTIMER
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX, MIN, MOD
+* ..
+* .. Executable Statements ..
+*
+ CALL PCLASIZESEPR( DESCA, IPREPAD, IPOSTPAD, SIZEMQRLEFT,
+ $ SIZEMQRRIGHT, SIZEQRF, SIZETMS, SIZEQTQ,
+ $ SIZECHK, SIZEEVR, RSIZEEVR, ISIZEEVR,
+ $ SIZESUBTST, RSIZESUBTST, ISIZESUBTST,
+ $ SIZETST, RSIZETST, ISIZETST )
+*
+ TSTNRM = NEGONE
+ QTQNRM = NEGONE
+ EPS = PSLAMCH( DESCA( CTXT_ ), 'Eps' )
+ SAFMIN = PSLAMCH( DESCA( CTXT_ ), 'Safe min' )
+*
+ NORMWIN = SAFMIN / EPS
+ IF( N.GE.1 )
+ $ NORMWIN = MAX( ABS( WIN( 1 ) ), ABS( WIN( N ) ), NORMWIN )
+*
+* Make sure that no information from previous calls is used
+*
+ NZ = -13
+ OLDNZ = NZ
+ OLDIL = IL
+ OLDIU = IU
+ OLDVL = VL
+ OLDVU = VU
+*
+ DO 10 I = 1, LWORK1, 1
+ RWORK( I+IPREPAD ) = 14.3E0
+ 10 CONTINUE
+*
+ DO 15 I = 1, LWORK, 1
+ WORK( I+IPREPAD ) = ( 15.63E0, 1.1E0 )
+ 15 CONTINUE
+*
+ DO 20 I = 1, LIWORK, 1
+ IWORK( I+IPREPAD ) = 14
+ 20 CONTINUE
+*
+ DO 30 I = 1, N
+ WNEW( I+IPREPAD ) = 3.14159E0
+ 30 CONTINUE
+*
+ ICLUSTR( 1+IPREPAD ) = 139
+*
+ IF (LSAME( RANGE, 'V' ) ) THEN
+* WRITE(*,*) 'VL VU = ', VL, ' ', VU
+ END IF
+
+ IF( LSAME( JOBZ, 'N' ) ) THEN
+ MAXEIGS = 0
+ ELSE
+ IF( LSAME( RANGE, 'A' ) ) THEN
+ MAXEIGS = N
+ ELSE IF( LSAME( RANGE, 'I' ) ) THEN
+ MAXEIGS = IU - IL + 1
+ ELSE
+ MINVL = VL - NORMWIN*FIVE*EPS - ABSTOL
+ MAXVU = VU + NORMWIN*FIVE*EPS + ABSTOL
+* WRITE(*,*) 'MINVL = ', MINVL, ' MAXVU = ', MAXVU
+* WRITE(*,*) 'WIN = ', WIN( 1 )
+ MINIL = 1
+ MAXIU = 0
+ DO 40 I = 1, N
+ IF( WIN( I ).LT.MINVL )
+ $ MINIL = MINIL + 1
+ IF( WIN( I ).LE.MAXVU )
+ $ MAXIU = MAXIU + 1
+ 40 CONTINUE
+*
+ MAXEIGS = MAXIU - MINIL + 1
+ END IF
+ END IF
+*
+*
+ CALL DESCINIT( DESCZ, DESCA( M_ ), DESCA( N_ ), DESCA( MB_ ),
+ $ DESCA( NB_ ), DESCA( RSRC_ ), DESCA( CSRC_ ),
+ $ DESCA( CTXT_ ), DESCA( LLD_ ), INFO )
+*
+ CALL BLACS_GRIDINFO( DESCA( CTXT_ ), NPROW, NPCOL, MYROW, MYCOL )
+ INDIWRK = 1 + IPREPAD + NPROW*NPCOL + 1
+*
+ IAM = 1
+ IF( MYROW.EQ.0 .AND. MYCOL.EQ.0 )
+ $ IAM = 0
+*
+* If this process is not involved in this test, bail out now
+*
+ RESULT = -3
+ IF( MYROW.GE.NPROW .OR. MYROW.LT.0 )
+ $ GO TO 150
+ RESULT = 0
+*
+ ISEED( 1 ) = 1
+*
+ CALL PCLASIZEHEEVR( WKNOWN, RANGE, N, DESCA, VL, VU, IL, IU,
+ $ ISEED, WIN, MAXSIZE, VECSIZE, VALSIZE )
+*
+ NP = NUMROC( N, DESCA( MB_ ), MYROW, 0, NPROW )
+ NQ = NUMROC( N, DESCA( NB_ ), MYCOL, 0, NPCOL )
+ MQ = NUMROC( MAXEIGS, DESCA( NB_ ), MYCOL, 0, NPCOL )
+*
+ CALL CLACPY( 'A', NP, NQ, COPYA, DESCA( LLD_ ), A( 1+IPREPAD ),
+ $ DESCA( LLD_ ) )
+*
+ CALL PCFILLPAD( DESCA( CTXT_ ), NP, NQ, A, DESCA( LLD_ ), IPREPAD,
+ $ IPOSTPAD, ZPADVAL )
+*
+ CALL PCFILLPAD( DESCZ( CTXT_ ), NP, MQ, Z, DESCZ( LLD_ ), IPREPAD,
+ $ IPOSTPAD, ZPADVAL+1.0E0 )
+*
+* WRITE(*,*) ' NP = ', NP, ' MQ = ', MQ, ' LDZ = ', DESCZ( LLD_ ),
+* $ ' IPREPAD = ', IPREPAD, ' IPOSTPAD = ', IPOSTPAD,
+* $ ' MAXEIGS = ', MAXEIGS
+* WRITE(*,*) ' PADZ( 1 ) = ', Z( 1 ), ' PADZ( 2 ) = ', Z( 2 ),
+* $ ' PADZ( 3 ) = ', Z( 3 ), ' PADZ( 4 ) = ', Z( 4 )
+*
+ CALL PSFILLPAD( DESCA( CTXT_ ), N, 1, WNEW, N, IPREPAD, IPOSTPAD,
+ $ PADVAL+2.0E0 )
+*
+ CALL PSFILLPAD( DESCA( CTXT_ ), NPROW*NPCOL, 1, GAP, NPROW*NPCOL,
+ $ IPREPAD, IPOSTPAD, PADVAL+3.0E0 )
+*
+ CALL PSFILLPAD( DESCA( CTXT_ ), LWORK1, 1, RWORK,LWORK1, IPREPAD,
+ $ IPOSTPAD, PADVAL+4.0E0 )
+*
+ CALL PIFILLPAD( DESCA( CTXT_ ), LIWORK, 1, IWORK, LIWORK, IPREPAD,
+ $ IPOSTPAD, IPADVAL )
+*
+ CALL PIFILLPAD( DESCA( CTXT_ ), N, 1, IFAIL, N, IPREPAD, IPOSTPAD,
+ $ IPADVAL )
+*
+ CALL PIFILLPAD( DESCA( CTXT_ ), 2*NPROW*NPCOL, 1, ICLUSTR,
+ $ 2*NPROW*NPCOL, IPREPAD, IPOSTPAD, IPADVAL )
+*
+ CALL PCFILLPAD( DESCA( CTXT_ ), LWORK, 1, WORK, LWORK, IPREPAD,
+ $ IPOSTPAD, ZPADVAL+4.1E0 )
+*
+* Make sure that PCHEEVR does not cheat (i.e. use answers
+* already computed.)
+*
+ DO 60 I = 1, N, 1
+ DO 50 J = 1, MAXEIGS, 1
+ CALL PCELSET( Z( 1+IPREPAD ), I, J, DESCA,
+ $ ( 13.0E0, 1.34E0 ) )
+ 50 CONTINUE
+ 60 CONTINUE
+*
+* Reset and start the timer
+*
+ CALL SLBOOT
+ CALL SLTIMER( 1 )
+ CALL SLTIMER( 6 )
+
+*********************************
+*
+* Main call to PCHEEVR
+*
+ CALL PCHEEVR( JOBZ, RANGE, UPLO, N, A( 1+IPREPAD ), IA, JA, DESCA,
+ $ VL, VU, IL, IU, M, NZ, WNEW( 1+IPREPAD ),
+ $ Z( 1+IPREPAD ), IA, JA, DESCA,
+ $ WORK( 1+IPREPAD ), SIZEEVR,
+ $ RWORK( 1+IPREPAD ), LWORK1,
+ $ IWORK( 1+IPREPAD ), LIWORK, INFO )
+*
+*********************************
+*
+* Stop timer
+*
+ CALL SLTIMER( 6 )
+ CALL SLTIMER( 1 )
+*
+* Indicate that there are no unresolved clusters.
+* This is necessary so that the tester
+* (adapted from the one originally made for PSSYEVX)
+* works correctly.
+ ICLUSTR( 1+IPREPAD ) = 0
+*
+ IF( THRESH.LE.0 ) THEN
+ RESULT = 0
+ ELSE
+ CALL PCCHEKPAD( DESCA( CTXT_ ), 'PCHEEVR-A', NP, NQ, A,
+ $ DESCA( LLD_ ), IPREPAD, IPOSTPAD, ZPADVAL )
+*
+ CALL PCCHEKPAD( DESCZ( CTXT_ ), 'PCHEEVR-Z', NP, MQ, Z,
+ $ DESCZ( LLD_ ), IPREPAD, IPOSTPAD,
+ $ ZPADVAL+1.0E0 )
+*
+ CALL PSCHEKPAD( DESCA( CTXT_ ), 'PCHEEVR-WNEW', N, 1, WNEW, N,
+ $ IPREPAD, IPOSTPAD, PADVAL+2.0E0 )
+*
+ CALL PSCHEKPAD( DESCA( CTXT_ ), 'PCHEEVR-GAP', NPROW*NPCOL, 1,
+ $ GAP, NPROW*NPCOL, IPREPAD, IPOSTPAD,
+ $ PADVAL+3.0E0 )
+*
+ CALL PSCHEKPAD( DESCA( CTXT_ ), 'PCHEEVR-RWORK',LWORK1, 1,
+ $ RWORK, LWORK1, IPREPAD, IPOSTPAD,
+ $ PADVAL+4.0E0 )
+*
+ CALL PCCHEKPAD( DESCA( CTXT_ ), 'PCHEEVR-WORK',LWORK, 1,
+ $ WORK, LWORK, IPREPAD, IPOSTPAD,
+ $ ZPADVAL+4.1E0 )
+*
+ CALL PICHEKPAD( DESCA( CTXT_ ), 'PCHEEVR-IWORK', LIWORK, 1,
+ $ IWORK, LIWORK, IPREPAD, IPOSTPAD, IPADVAL )
+*
+ CALL PICHEKPAD( DESCA( CTXT_ ), 'PCHEEVR-IFAIL', N, 1, IFAIL,
+ $ N, IPREPAD, IPOSTPAD, IPADVAL )
+*
+ CALL PICHEKPAD( DESCA( CTXT_ ), 'PCHEEVR-ICLUSTR',
+ $ 2*NPROW*NPCOL, 1, ICLUSTR, 2*NPROW*NPCOL,
+ $ IPREPAD, IPOSTPAD, IPADVAL )
+*
+* If we now know the spectrum, we can potentially reduce MAXSIZE.
+*
+ IF( LSAME( RANGE, 'A' ) ) THEN
+ CALL PCLASIZEHEEVR( .TRUE., RANGE, N, DESCA, VL, VU, IL, IU,
+ $ ISEED, WNEW( 1+IPREPAD ), MAXSIZE,
+ $ VECSIZE, VALSIZE )
+ END IF
+*
+* Check INFO
+* Make sure that all processes return the same value of INFO
+*
+ ITMP( 1 ) = INFO
+ ITMP( 2 ) = INFO
+*
+ CALL IGAMN2D( DESCA( CTXT_ ), 'a', ' ', 1, 1, ITMP, 1, 1, 1,
+ $ -1, -1, 0 )
+ CALL IGAMX2D( DESCA( CTXT_ ), 'a', ' ', 1, 1, ITMP( 2 ), 1, 1,
+ $ 1, -1, -1, 0 )
+*
+*
+ IF( ITMP( 1 ).NE.ITMP( 2 ) ) THEN
+ IF( IAM.EQ.0 )
+ $ WRITE( NOUT, FMT = * )
+ $ 'Different processes return different INFO'
+ RESULT = 1
+ ELSE IF( MOD( INFO, 2 ).EQ.1 .OR. INFO.GT.7 .OR. INFO.LT.0 )
+ $ THEN
+ IF( IAM.EQ.0 )
+ $ WRITE( NOUT, FMT = 9999 )INFO
+ RESULT = 1
+ ELSE IF( MOD( INFO / 2, 2 ).EQ.1 .AND. LWORK1.GE.MAXSIZE ) THEN
+ IF( IAM.EQ.0 )
+ $ WRITE( NOUT, FMT = 9996 )INFO
+ RESULT = 1
+ ELSE IF( MOD( INFO / 4, 2 ).EQ.1 .AND. LWORK1.GE.VECSIZE ) THEN
+ IF( IAM.EQ.0 )
+ $ WRITE( NOUT, FMT = 9996 )INFO
+ RESULT = 1
+ END IF
+*
+ IF( LSAME( JOBZ, 'V' ) .AND. ( ICLUSTR( 1+IPREPAD ).NE.
+ $ 0 ) .AND. ( MOD( INFO / 2, 2 ).NE.1 ) ) THEN
+ IF( IAM.EQ.0 )
+ $ WRITE( NOUT, FMT = 9995 )
+ RESULT = 1
+ END IF
+*
+* Check M
+*
+ IF( ( M.LT.0 ) .OR. ( M.GT.N ) ) THEN
+ IF( IAM.EQ.0 )
+ $ WRITE( NOUT, FMT = 9994 )
+ WRITE( NOUT,*) 'M = ', M, '\n', 'N = ', N
+ RESULT = 1
+ ELSE IF( LSAME( RANGE, 'A' ) .AND. ( M.NE.N ) ) THEN
+ IF( IAM.EQ.0 )
+ $ WRITE( NOUT, FMT = 9993 )
+ RESULT = 1
+ ELSE IF( LSAME( RANGE, 'I' ) .AND. ( M.NE.IU-IL+1 ) ) THEN
+ IF( IAM.EQ.0 ) THEN
+ WRITE( NOUT, FMT = 9992 )
+ WRITE( NOUT,*) 'IL = ', IL, ' IU = ', IU, ' M = ', M
+ END IF
+ RESULT = 1
+ ELSE IF( LSAME( JOBZ, 'V' ) .AND.
+ $ ( .NOT.( LSAME( RANGE, 'V' ) ) ) .AND. ( M.NE.NZ ) )
+ $ THEN
+ IF( IAM.EQ.0 )
+ $ WRITE( NOUT, FMT = 9991 )
+ RESULT = 1
+ END IF
+*
+* Check NZ
+*
+ IF( LSAME( JOBZ, 'V' ) ) THEN
+ IF( LSAME( RANGE, 'V' ) ) THEN
+ IF( NZ.GT.M ) THEN
+ IF( IAM.EQ.0 )
+ $ WRITE( NOUT, FMT = 9990 )
+ RESULT = 1
+ END IF
+ IF( NZ.LT.M .AND. MOD( INFO / 4, 2 ).NE.1 ) THEN
+ IF( IAM.EQ.0 )
+ $ WRITE( NOUT, FMT = 9989 )
+ RESULT = 1
+ END IF
+ ELSE
+ IF( NZ.NE.M ) THEN
+ IF( IAM.EQ.0 )
+ $ WRITE( NOUT, FMT = 9988 )
+ RESULT = 1
+ END IF
+ END IF
+ END IF
+ IF( RESULT.EQ.0 ) THEN
+*
+* Make sure that all processes return the same # of eigenvalues
+*
+ ITMP( 1 ) = M
+ ITMP( 2 ) = M
+*
+ CALL IGAMN2D( DESCA( CTXT_ ), 'a', ' ', 1, 1, ITMP, 1, 1, 1,
+ $ -1, -1, 0 )
+ CALL IGAMX2D( DESCA( CTXT_ ), 'a', ' ', 1, 1, ITMP( 2 ), 1,
+ $ 1, 1, -1, -1, 0 )
+*
+ IF( ITMP( 1 ).NE.ITMP( 2 ) ) THEN
+ IF( IAM.EQ.0 )
+ $ WRITE( NOUT, FMT = 9987 )
+ RESULT = 1
+ ELSE
+*
+* Ensure that different processes return the same eigenvalues
+*
+ DO 70 I = 1, M
+ RWORK( I ) = WNEW( I+IPREPAD )
+ RWORK( I+M ) = WNEW( I+IPREPAD )
+ 70 CONTINUE
+*
+ CALL SGAMN2D( DESCA( CTXT_ ), 'a', ' ', M, 1, RWORK, M,
+ $ 1, 1, -1, -1, 0 )
+ CALL SGAMX2D( DESCA( CTXT_ ), 'a', ' ', M, 1,
+ $ RWORK( 1+M ), M, 1, 1, -1, -1, 0 )
+*
+ DO 80 I = 1, M
+ IF( RESULT.EQ.0 .AND. ( ABS( RWORK( I )-RWORK( M+
+ $ I ) ).GT.FIVE*EPS*ABS( RWORK( I ) ) ) ) THEN
+ IF( IAM.EQ.0 )
+ $ WRITE( NOUT, FMT = 9986 )
+ RESULT = 1
+ END IF
+ 80 CONTINUE
+ END IF
+ END IF
+*
+* Make sure that all processes return the same # of clusters
+*
+ IF( LSAME( JOBZ, 'V' ) ) THEN
+ NCLUSTERS = 0
+ DO 90 I = 0, NPROW*NPCOL - 1
+ IF( ICLUSTR( 1+IPREPAD+2*I ).EQ.0 )
+ $ GO TO 100
+ NCLUSTERS = NCLUSTERS + 1
+ 90 CONTINUE
+ 100 CONTINUE
+ ITMP( 1 ) = NCLUSTERS
+ ITMP( 2 ) = NCLUSTERS
+*
+ CALL IGAMN2D( DESCA( CTXT_ ), 'a', ' ', 1, 1, ITMP, 1, 1, 1,
+ $ -1, -1, 0 )
+ CALL IGAMX2D( DESCA( CTXT_ ), 'a', ' ', 1, 1, ITMP( 2 ), 1,
+ $ 1, 1, -1, -1, 0 )
+*
+ IF( ITMP( 1 ).NE.ITMP( 2 ) ) THEN
+ IF( IAM.EQ.0 )
+ $ WRITE( NOUT, FMT = 9985 )
+ RESULT = 1
+ ELSE
+*
+* Make sure that different processes return the same clusters
+*
+ DO 110 I = 1, NCLUSTERS
+ IWORK( INDIWRK+I ) = ICLUSTR( I+IPREPAD )
+ IWORK( INDIWRK+I+NCLUSTERS ) = ICLUSTR( I+IPREPAD )
+ 110 CONTINUE
+ CALL IGAMN2D( DESCA( CTXT_ ), 'a', ' ', NCLUSTERS*2+1, 1,
+ $ IWORK( INDIWRK+1 ), NCLUSTERS*2+1, 1, 1,
+ $ -1, -1, 0 )
+ CALL IGAMX2D( DESCA( CTXT_ ), 'a', ' ', NCLUSTERS*2+1, 1,
+ $ IWORK( INDIWRK+1+NCLUSTERS ),
+ $ NCLUSTERS*2+1, 1, 1, -1, -1, 0 )
+*
+ DO 120 I = 1, NCLUSTERS
+ IF( RESULT.EQ.0 .AND. IWORK( INDIWRK+I ).NE.
+ $ IWORK( INDIWRK+NCLUSTERS+I ) ) THEN
+ IF( IAM.EQ.0 )
+ $ WRITE( NOUT, FMT = 9984 )
+ RESULT = 1
+ END IF
+ 120 CONTINUE
+*
+ IF( ICLUSTR( 1+IPREPAD+NCLUSTERS*2 ).NE.0 ) THEN
+ IF( IAM.EQ.0 )
+ $ WRITE( NOUT, FMT = 9983 )
+ RESULT = 1
+ END IF
+ END IF
+ END IF
+*
+ CALL IGAMX2D( DESCA( CTXT_ ), 'a', ' ', 1, 1, RESULT, 1, 1, 1,
+ $ -1, -1, 0 )
+ IF( RESULT.NE.0 )
+ $ GO TO 150
+*
+* Compute eps * norm(A)
+*
+ IF( N.EQ.0 ) THEN
+ EPSNORMA = EPS
+ ELSE
+ EPSNORMA = PCLANHE( 'I', UPLO, N, COPYA, IA, JA, DESCA,
+ $ RWORK )*EPS
+ END IF
+*
+ IF( LSAME( JOBZ, 'V' ) ) THEN
+*
+* Perform the |A Z - Z W| test
+*
+ CALL PSFILLPAD( DESCA( CTXT_ ), SIZECHK, 1, RWORK,SIZECHK,
+ $ IPREPAD, IPOSTPAD, 4.3E0 )
+*
+ CALL PCSEPCHK( N, NZ, COPYA, IA, JA, DESCA,
+ $ MAX( ABSTOL+EPSNORMA, SAFMIN ), THRESH,
+ $ Z( 1+IPREPAD ), IA, JA, DESCZ,
+ $ A( 1+IPREPAD ), IA, JA, DESCA,
+ $ WNEW( 1+IPREPAD ), RWORK( 1+IPREPAD ),
+ $ SIZECHK, TSTNRM, RES )
+*
+ CALL PSCHEKPAD( DESCA( CTXT_ ), 'PCSEPCHK-RWORK',SIZECHK, 1,
+ $ RWORK,SIZECHK, IPREPAD, IPOSTPAD, 4.3E0 )
+*
+ IF( RES.NE.0 )
+ $ RESULT = 1
+*
+* Perform the |QTQ - I| test
+*
+ CALL PSFILLPAD( DESCA( CTXT_ ), SIZEQTQ, 1,RWORK, SIZEQTQ,
+ $ IPREPAD, IPOSTPAD, 4.3E0 )
+*
+*
+ CALL PCSEPQTQ( N, NZ, THRESH, Z( 1+IPREPAD ), IA, JA, DESCZ,
+ $ A( 1+IPREPAD ), IA, JA, DESCA,
+ $ IWORK( 1+IPREPAD+1 ), ICLUSTR( 1+IPREPAD ),
+ $ GAP( 1+IPREPAD ),RWORK( IPREPAD+1 ), SIZEQTQ,
+ $ QTQNRM, INFO, RES )
+*
+ CALL PSCHEKPAD( DESCA( CTXT_ ), 'PSSEPQTQ-RWORK',SIZEQTQ, 1,
+ $ RWORK,SIZEQTQ, IPREPAD, IPOSTPAD, 4.3E0 )
+*
+ IF( RES.NE.0 )
+ $ RESULT = 1
+*
+ IF( INFO.NE.0 ) THEN
+ IF( IAM.EQ.0 )
+ $ WRITE( NOUT, FMT = 9998 )INFO
+ RESULT = 1
+ END IF
+ END IF
+*
+* Check to make sure that the right eigenvalues have been obtained
+*
+ IF( WKNOWN ) THEN
+* Set up MYIL if necessary
+ MYIL = IL
+*
+ IF( LSAME( RANGE, 'V' ) ) THEN
+ MYIL = 1
+ MINIL = 1
+ MAXIL = N - M + 1
+ ELSE
+ IF( LSAME( RANGE, 'A' ) ) THEN
+ MYIL = 1
+ END IF
+ MINIL = MYIL
+ MAXIL = MYIL
+ END IF
+*
+* Find the largest difference between the computed
+* and expected eigenvalues
+*
+ MINERROR = NORMWIN
+*
+ DO 140 MYIL = MINIL, MAXIL
+ MAXERROR = 0
+*
+* Make sure that we aren't skipping any important eigenvalues
+*
+ MISSSMALLEST = .TRUE.
+ IF( .NOT.LSAME( RANGE, 'V' ) .OR. ( MYIL.EQ.1 ) )
+ $ MISSSMALLEST = .FALSE.
+ IF( MISSSMALLEST .AND. ( WIN( MYIL-1 ).LT.VL+NORMWIN*
+ $ FIVE*THRESH*EPS ) )MISSSMALLEST = .FALSE.
+ MISSLARGEST = .TRUE.
+ IF( .NOT.LSAME( RANGE, 'V' ) .OR. ( MYIL.EQ.MAXIL ) )
+ $ MISSLARGEST = .FALSE.
+ IF( MISSLARGEST .AND. ( WIN( MYIL+M ).GT.VU-NORMWIN*FIVE*
+ $ THRESH*EPS ) )MISSLARGEST = .FALSE.
+ IF( .NOT.MISSSMALLEST ) THEN
+ IF( .NOT.MISSLARGEST ) THEN
+*
+* Make sure that the eigenvalues that we report are OK
+*
+ DO 130 I = 1, M
+* WRITE(*,*) 'WIN WNEW = ', WIN( I+MYIL-1 ),
+* $ WNEW( I+IPREPAD )
+ ERROR = ABS( WIN( I+MYIL-1 )-WNEW( I+IPREPAD ) )
+ MAXERROR = MAX( MAXERROR, ERROR )
+ 130 CONTINUE
+*
+ MINERROR = MIN( MAXERROR, MINERROR )
+ END IF
+ END IF
+ 140 CONTINUE
+*
+* If JOBZ = 'V' and RANGE='A', we might be comparing
+* against our estimate of what the eigenvalues ought to
+* be, rather than comparing against what was computed
+* last time around, so we have to be more generous.
+*
+ IF( LSAME( JOBZ, 'V' ) .AND. LSAME( RANGE, 'A' ) ) THEN
+ IF( MINERROR.GT.NORMWIN*FIVE*FIVE*THRESH*EPS ) THEN
+ IF( IAM.EQ.0 )
+ $ WRITE( NOUT, FMT = 9997 )MINERROR, NORMWIN
+ RESULT = 1
+ END IF
+ ELSE
+ IF( MINERROR.GT.NORMWIN*FIVE*THRESH*EPS ) THEN
+ IF( IAM.EQ.0 )
+ $ WRITE( NOUT, FMT = 9997 )MINERROR, NORMWIN
+ RESULT = 1
+ END IF
+ END IF
+ END IF
+*
+* Make sure that the IL, IU, VL and VU were not altered
+*
+ IF( IL.NE.OLDIL .OR. IU.NE.OLDIU .OR. VL.NE.OLDVL .OR. VU.NE.
+ $ OLDVU ) THEN
+ IF( IAM.EQ.0 )
+ $ WRITE( NOUT, FMT = 9982 )
+ RESULT = 1
+ END IF
+*
+ IF( LSAME( JOBZ, 'N' ) .AND. ( NZ.NE.OLDNZ ) ) THEN
+ IF( IAM.EQ.0 )
+ $ WRITE( NOUT, FMT = 9981 )
+ RESULT = 1
+ END IF
+*
+ END IF
+*
+* All processes should report the same result
+*
+ CALL IGAMX2D( DESCA( CTXT_ ), 'a', ' ', 1, 1, RESULT, 1, 1, 1, -1,
+ $ -1, 0 )
+*
+ 150 CONTINUE
+*
+ RETURN
+*
+ 9999 FORMAT( 'PCHEEVR returned INFO=', I7 )
+ 9998 FORMAT( 'PCSEPQTQ returned INFO=', I7 )
+ 9997 FORMAT( 'PCSEPRSUBTST minerror =', D11.2, ' normwin=', D11.2 )
+ 9996 FORMAT( 'PCHEEVR returned INFO=', I7,
+ $ ' despite adequate workspace' )
+ 9995 FORMAT( 'ICLUSTR(1).NE.0 but mod(INFO/2,2).NE.1' )
+ 9994 FORMAT( 'M not in the range 0 to N' )
+ 9993 FORMAT( 'M not equal to N' )
+ 9992 FORMAT( 'M not equal to IU-IL+1' )
+ 9991 FORMAT( 'M not equal to NZ' )
+ 9990 FORMAT( 'NZ > M' )
+ 9989 FORMAT( 'NZ < M' )
+ 9988 FORMAT( 'NZ not equal to M' )
+ 9987 FORMAT( 'Different processes return different values for M' )
+ 9986 FORMAT( 'Different processes return different eigenvalues' )
+ 9985 FORMAT( 'Different processes return ',
+ $ 'different numbers of clusters' )
+ 9984 FORMAT( 'Different processes return different clusters' )
+ 9983 FORMAT( 'ICLUSTR not zero terminated' )
+ 9982 FORMAT( 'IL, IU, VL or VU altered by PCHEEVR' )
+ 9981 FORMAT( 'NZ altered by PCHEEVR with JOBZ=N' )
+*
+* End of PCSEPRSUBTST
+*
+ END
diff --git a/TESTING/EIG/pcseprtst.f b/TESTING/EIG/pcseprtst.f
new file mode 100644
index 0000000..a5f92b1
--- /dev/null
+++ b/TESTING/EIG/pcseprtst.f
@@ -0,0 +1,823 @@
+ SUBROUTINE PCSEPRTST(DESCA, UPLO, N, MATTYPE, SUBTESTS, THRESH,
+ $ ORDER, ABSTOL, ISEED, A, COPYA, Z, LDA, WIN,
+ $ WNEW, IFAIL, ICLUSTR, GAP, IPREPAD, IPOSTPAD,
+ $ WORK, LWORK, RWORK, LRWORK,
+ $ IWORK, LIWORK, HETERO, NOUT, INFO )
+*
+* -- ScaLAPACK routine (@(MODE)version *TBA*) --
+* University of California, Berkeley and
+* University of Tennessee, Knoxville.
+* October 21, 2006
+*
+ IMPLICIT NONE
+*
+* .. Scalar Arguments ..
+ CHARACTER HETERO, SUBTESTS, UPLO
+ INTEGER INFO, IPOSTPAD, IPREPAD, LDA, LIWORK, LWORK,
+ $ MATTYPE, N, NOUT, ORDER
+ INTEGER LRWORK
+ REAL ABSTOL, THRESH
+* ..
+* .. Array Arguments ..
+ INTEGER DESCA( * ), ICLUSTR( * ), IFAIL( * ),
+ $ ISEED( 4 ), IWORK( * )
+ REAL GAP( * ), WIN( * ), WNEW( * ), RWORK( * )
+ COMPLEX A( LDA, * ), COPYA( LDA, * ),
+ $ WORK( * ), Z( LDA, * )
+* ..
+*
+* Purpose
+* =======
+*
+* PCSEPRTST builds a random matrix and runs PCHEEVR to
+* compute the eigenvalues and eigenvectors. Then it performs two tests
+* to determine if the result is good enough. The two tests are:
+* |AQ -QL| / (abstol + ulp * norm(A) )
+* and
+* |QT * Q - I| / ulp * norm(A)
+*
+* The random matrix built depends upon the following parameters:
+* N, NB, ISEED, ORDER
+*
+* Arguments
+* =========
+*
+* NP = the number of rows local to a given process.
+* NQ = the number of columns local to a given process.
+*
+* DESCA (global and local input) INTEGER array of dimension DLEN_
+* The array descriptor for the distributed matrices
+*
+* UPLO (global input) CHARACTER*1
+* Specifies whether the upper or lower triangular part of the
+* matrix A is stored:
+* = 'U': Upper triangular
+* = 'L': Lower triangular
+*
+* N (global input) INTEGER
+* Size of the matrix to be tested. (global size)
+*
+* MATTYPE (global input) INTEGER
+* Matrix type
+* Currently, the list of possible types is:
+*
+* (1) The zero matrix.
+* (2) The identity matrix.
+*
+* (3) A diagonal matrix with evenly spaced entries
+* 1, ..., ULP and random signs.
+* (ULP = (first number larger than 1) - 1 )
+* (4) A diagonal matrix with geometrically spaced entries
+* 1, ..., ULP and random signs.
+* (5) A diagonal matrix with "clustered" entries 1, ULP, ..., ULP
+* and random signs.
+*
+* (6) Same as (4), but multiplied by SQRT( overflow threshold )
+* (7) Same as (4), but multiplied by SQRT( underflow threshold )
+*
+* (8) A matrix of the form U' D U, where U is orthogonal and
+* D has evenly spaced entries 1, ..., ULP with random signs
+* on the diagonal.
+*
+* (9) A matrix of the form U' D U, where U is orthogonal and
+* D has geometrically spaced entries 1, ..., ULP with random
+* signs on the diagonal.
+*
+* (10) A matrix of the form U' D U, where U is orthogonal and
+* D has "clustered" entries 1, ULP,..., ULP with random
+* signs on the diagonal.
+*
+* (11) Same as (8), but multiplied by SQRT( overflow threshold )
+* (12) Same as (8), but multiplied by SQRT( underflow threshold )
+*
+* (13) A matrix with random entries chosen from (-1,1).
+* (14) Same as (13), but multiplied by SQRT( overflow threshold )
+* (15) Same as (13), but multiplied by SQRT( underflow threshold )
+* (16) Same as (8), but diagonal elements are all positive.
+* (17) Same as (9), but diagonal elements are all positive.
+* (18) Same as (10), but diagonal elements are all positive.
+* (19) Same as (16), but multiplied by SQRT( overflow threshold )
+* (20) Same as (16), but multiplied by SQRT( underflow threshold )
+* (21) A tridiagonal matrix that is a direct sum of smaller diagonally
+* dominant submatrices. Each unreduced submatrix has geometrically
+* spaced diagonal entries 1, ..., ULP.
+* (22) A matrix of the form U' D U, where U is orthogonal and
+* D has ceil(lgN) "clusters" at 0,1,2,...,ceil(lgN)-1. The
+* size of the cluster at the value I is 2^I.
+*
+* SUBTESTS (global input) CHARACTER*1
+* 'Y' - Perform subset tests
+* 'N' - Do not perform subset tests
+*
+* THRESH (global input) REAL
+* A test will count as "failed" if the "error", computed as
+* described below, exceeds THRESH. Note that the error
+* is scaled to be O(1), so THRESH should be a reasonably
+* small multiple of 1, e.g., 10 or 100. In particular,
+* it should not depend on the precision (single vs. double)
+* or the size of the matrix. It must be at least zero.
+*
+* ORDER (global input) INTEGER
+* Number of reflectors used in test matrix creation.
+* If ORDER is large, it will
+* take more time to create the test matrices but they will
+* be closer to random.
+* ORDER .lt. N not implemented
+*
+* ABSTOL (global input) REAL
+* For the purposes of this test, ABSTOL=0.0 is fine.
+* THis test does not test for high relative accuracy.
+*
+* ISEED (global input/output) INTEGER array, dimension (4)
+* On entry, the seed of the random number generator; the array
+* elements must be between 0 and 4095, and ISEED(4) must be
+* odd.
+* On exit, the seed is updated.
+*
+* A (local workspace) COMPLEX array, dim (N*N)
+* global dimension (N, N), local dimension (LDA, NQ)
+* The test matrix, which is then overwritten.
+* A is distributed in a block cyclic manner over both rows
+* and columns. The actual location of a particular element
+* in A is controlled by the values of NPROW, NPCOL, and NB.
+*
+* COPYA (local workspace) COMPLEX array, dim (N, N)
+* COPYA is used to hold an identical copy of the array A
+* identical in both form and content to A
+*
+* Z (local workspace) COMPLEX array, dim (N*N)
+* Z is distributed in the same manner as A
+* Z is used as workspace by the test routines
+* PCSEPCHK and PCSEPQTQ
+*
+* W (local workspace) REAL array, dimension (N)
+* On normal exit, the first M entries
+* contain the selected eigenvalues in ascending order.
+*
+* IFAIL (global workspace) INTEGER array, dimension (N)
+* Not used, only for backward compatibility
+*
+* WORK (local workspace) COMPLEX array, dimension (LWORK)
+*
+* LWORK (local input) INTEGER
+* The length of the array WORK. LWORK >= SIZETST as
+* returned by PCLASIZESEPR
+*
+* RWORK (local workspace) REAL array, dimension (LRWORK)
+*
+* LRWORK (local input) INTEGER
+* The length of the array WORK. LRWORK >= RSIZETST as
+* returned by P@(CRPF)LASIZESEPR
+*
+* IWORK (local workspace) INTEGER array, dimension (LIWORK)
+*
+* LIWORK (local input) INTEGER
+* The length of the array IWORK. LIWORK >= ISIZETST as
+* returned by PCLASIZESEPR
+*
+* HETERO (input) INTEGER
+*
+* NOUT (local input) INTEGER
+* The unit number for output file. Only used on node 0.
+* NOUT = 6, output to screen,
+* NOUT = 0, output to stderr.
+* NOUT = 13, output to file, divide thresh by 10.0
+* NOUT = 14, output to file, divide thresh by 20.0
+* (This hack allows us to test more stringently internally
+* so that when errors on found on other computers they will
+* be serious enough to warrant our attention.)
+*
+* INFO (global output) INTEGER
+* -3 This process is not involved
+* 0 Test succeeded (passed |AQ -QL| and |QT*Q - I| tests)
+* 1 At least one test failed
+* 2 Residual test were not performed, thresh <= 0.0
+* 3 Test was skipped because of inadequate memory space
+*
+* .. Parameters ..
+ INTEGER CTXT_, MB_, NB_, RSRC_, CSRC_, LLD_
+ PARAMETER ( CTXT_ = 2, MB_ = 5, NB_ = 6,
+ $ RSRC_ = 7, CSRC_ = 8, LLD_ = 9 )
+ REAL HALF, ONE, TEN, ZERO
+ PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0,
+ $ TEN = 10.0E0, HALF = 0.5E0 )
+ COMPLEX PADVAL
+ PARAMETER ( PADVAL = ( 19.25E0, 1.1E1 ) )
+ COMPLEX ZZERO
+ PARAMETER ( ZZERO = ( 0.0E0, 0.0E0 ) )
+ COMPLEX ZONE
+ PARAMETER ( ZONE = ( 1.0E0, 0.0E0 ) )
+ INTEGER MAXTYP
+ PARAMETER ( MAXTYP = 22 )
+* ..
+*
+* .. Local Scalars ..
+ LOGICAL WKNOWN
+ CHARACTER JOBZ, RANGE
+ CHARACTER*14 PASSED
+ INTEGER CONTEXT, I, IAM, IHETERO, IINFO, IL, IMODE, IN,
+ $ INDD, INDWORK, ISIZESUBTST, ISIZEEVR,
+ $ ISIZETST, ITYPE, IU, J, LLWORK, LEVRSIZE,
+ $ MAXSIZE, MYCOL, MYROW, NB, NGEN, NLOC,
+ $ NNODES, NP, NPCOL, NPROW, NQ, RES, SIZECHK,
+ $ SIZEMQRLEFT, SIZEMQRRIGHT, SIZEQRF, SIZEQTQ,
+ $ SIZESUBTST, SIZEEVR, SIZETMS,
+ $ SIZETST, VALSIZE, VECSIZE
+ INTEGER INDRWORK, LLRWORK, RSIZEEVR, RSIZESUBTST,
+ $ RSIZETST
+ REAL ANINV, ANORM, COND, MAXQTQNRM, MAXTSTNRM, OVFL,
+ $ QTQNRM, RTOVFL, RTUNFL, TEMP1, TSTNRM, ULP,
+ $ ULPINV, UNFL, VL, VU
+* ..
+* .. Local Arrays ..
+ INTEGER ISEEDIN( 4 ), KMAGN( MAXTYP ), KMODE( MAXTYP ),
+ $ KTYPE( MAXTYP )
+ DOUBLE PRECISION CTIME( 10 ), WTIME( 10 )
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ INTEGER NUMROC
+ REAL SLARAN, PSLAMCH
+ EXTERNAL SLARAN, LSAME, NUMROC, PSLAMCH
+* ..
+* .. External Subroutines ..
+ EXTERNAL BLACS_GRIDINFO, BLACS_PINFO, CLATMS, IGAMX2D,
+ $ IGEBR2D, IGEBS2D, PCCHEKPAD, PCELSET,
+ $ PCFILLPAD, PCLASET, PCLASIZEHEEVR,
+ $ PCLASIZESEPR, PCLATMS, PCMATGEN, PCSEPRSUBTST,
+ $ SLABAD, SLASRT, SLCOMBINE
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, REAL, INT, MAX, MIN, SQRT
+* ..
+* .. Data statements ..
+ DATA KTYPE / 1, 2, 4, 4, 4, 4, 4, 5, 5, 5, 5, 5, 8,
+ $ 8, 8, 9, 9, 9, 9, 9, 10, 11 /
+ DATA KMAGN / 1, 1, 1, 1, 1, 2, 3, 1, 1, 1, 2, 3, 1,
+ $ 2, 3, 1, 1, 1, 2, 3, 1, 1 /
+ DATA KMODE / 0, 0, 4, 3, 1, 4, 4, 4, 3, 1, 4, 4, 0,
+ $ 0, 0, 4, 3, 1, 4, 4, 3, 0 /
+* ..
+* .. Executable Statements ..
+*
+ INFO = 0
+ PASSED = 'PASSED EVR'
+ CONTEXT = DESCA( CTXT_ )
+ NB = DESCA( NB_ )
+*
+ CALL BLACS_PINFO( IAM, NNODES )
+ CALL BLACS_GRIDINFO( CONTEXT, NPROW, NPCOL, MYROW, MYCOL )
+*
+* Distribute HETERO across processes
+*
+ IF( IAM.EQ.0 ) THEN
+ IF( LSAME( HETERO, 'Y' ) ) THEN
+ IHETERO = 2
+ ELSE
+ IHETERO = 1
+ END IF
+ CALL IGEBS2D( CONTEXT, 'All', ' ', 1, 1, IHETERO, 1 )
+ ELSE
+ CALL IGEBR2D( CONTEXT, 'All', ' ', 1, 1, IHETERO, 1, 0, 0 )
+ END IF
+ IF( IHETERO.EQ.2 ) THEN
+ HETERO = 'Y'
+ ELSE
+ HETERO = 'N'
+ END IF
+*
+* Make sure that there is enough memory
+*
+ CALL PCLASIZESEPR( DESCA, IPREPAD, IPOSTPAD, SIZEMQRLEFT,
+ $ SIZEMQRRIGHT, SIZEQRF, SIZETMS, SIZEQTQ,
+ $ SIZECHK, SIZEEVR, RSIZEEVR, ISIZEEVR,
+ $ SIZESUBTST, RSIZESUBTST,
+ $ ISIZESUBTST, SIZETST, RSIZETST, ISIZETST )
+ IF( LRWORK.LT.RSIZETST ) THEN
+ INFO = 3
+ END IF
+*
+ CALL IGAMX2D( CONTEXT, 'a', ' ', 1, 1, INFO, 1, 1, 1, -1, -1, 0 )
+*
+ IF( INFO.EQ.0 ) THEN
+*
+ INDD = 1
+ INDRWORK = INDD + N
+ INDWORK = 1
+ LLWORK = LWORK - INDWORK + 1
+ LLRWORK = LRWORK - INDRWORK + 1
+*
+ ULP = PSLAMCH( CONTEXT, 'P' )
+ ULPINV = ONE / ULP
+ UNFL = PSLAMCH( CONTEXT, 'Safe min' )
+ OVFL = ONE / UNFL
+ CALL SLABAD( UNFL, OVFL )
+ RTUNFL = SQRT( UNFL )
+ RTOVFL = SQRT( OVFL )
+ ANINV = ONE / REAL( MAX( 1, N ) )
+*
+* This ensures that everyone starts out with the same seed.
+*
+ IF( MYROW.EQ.0 .AND. MYCOL.EQ.0 ) THEN
+ CALL IGEBS2D( CONTEXT, 'a', ' ', 4, 1, ISEED, 4 )
+ ELSE
+ CALL IGEBR2D( CONTEXT, 'a', ' ', 4, 1, ISEED, 4, 0, 0 )
+ END IF
+ ISEEDIN( 1 ) = ISEED( 1 )
+ ISEEDIN( 2 ) = ISEED( 2 )
+ ISEEDIN( 3 ) = ISEED( 3 )
+ ISEEDIN( 4 ) = ISEED( 4 )
+*
+* Compute the matrix A
+*
+* Control parameters:
+*
+* KMAGN KMODE KTYPE
+* =1 O(1) clustered 1 zero
+* =2 large clustered 2 identity
+* =3 small exponential (none)
+* =4 arithmetic diagonal, (w/ eigenvalues)
+* =5 random log Hermitian, w/ eigenvalues
+* =6 random (none)
+* =7 random diagonal
+* =8 random Hermitian
+* =9 positive definite
+* =10 block diagonal with tridiagonal blocks
+* =11 Geometrically sized clusters.
+*
+ ITYPE = KTYPE( MATTYPE )
+ IMODE = KMODE( MATTYPE )
+*
+* Compute norm
+*
+ GO TO ( 10, 20, 30 )KMAGN( MATTYPE )
+*
+ 10 CONTINUE
+ ANORM = ONE
+ GO TO 40
+*
+ 20 CONTINUE
+ ANORM = ( RTOVFL*ULP )*ANINV
+ GO TO 40
+*
+ 30 CONTINUE
+ ANORM = RTUNFL*N*ULPINV
+ GO TO 40
+*
+ 40 CONTINUE
+ IF( MATTYPE.LE.15 ) THEN
+ COND = ULPINV
+ ELSE
+ COND = ULPINV*ANINV / TEN
+ END IF
+*
+* Special Matrices
+*
+ IF( ITYPE.EQ.1 ) THEN
+*
+* Zero Matrix
+*
+ DO 50 I = 1, N
+ RWORK( INDD+I-1 ) = ZERO
+ 50 CONTINUE
+ CALL PCLASET( 'All', N, N,ZZERO,ZZERO, COPYA, 1, 1, DESCA )
+ WKNOWN = .TRUE.
+*
+ ELSE IF( ITYPE.EQ.2 ) THEN
+*
+* Identity Matrix
+*
+ DO 60 I = 1, N
+ RWORK( INDD+I-1 ) = ONE
+ 60 CONTINUE
+ CALL PCLASET( 'All', N, N,ZZERO,ZONE, COPYA, 1, 1, DESCA )
+ WKNOWN = .TRUE.
+*
+ ELSE IF( ITYPE.EQ.4 ) THEN
+*
+* Diagonal Matrix, [Eigen]values Specified
+*
+ CALL PCFILLPAD( DESCA( CTXT_ ), SIZETMS, 1, WORK( INDWORK ),
+ $ SIZETMS, IPREPAD, IPOSTPAD, PADVAL+1.0E0 )
+*
+ CALL PCLATMS( N, N, 'S', ISEED, 'S',RWORK( INDD ), IMODE,
+ $ COND, ANORM, 0, 0, 'N', COPYA, 1, 1, DESCA,
+ $ ORDER, WORK( INDWORK+IPREPAD ), SIZETMS,
+ $ IINFO )
+ WKNOWN = .TRUE.
+*
+ CALL PCCHEKPAD( DESCA( CTXT_ ), 'PCLATMS1-WORK', SIZETMS, 1,
+ $ WORK( INDWORK ), SIZETMS, IPREPAD, IPOSTPAD,
+ $ PADVAL+1.0E0 )
+*
+ ELSE IF( ITYPE.EQ.5 ) THEN
+*
+* Hermitian, eigenvalues specified
+*
+ CALL PCFILLPAD( DESCA( CTXT_ ), SIZETMS, 1, WORK( INDWORK ),
+ $ SIZETMS, IPREPAD, IPOSTPAD, PADVAL+2.0E0 )
+*
+ CALL PCLATMS( N, N, 'S', ISEED, 'S',RWORK( INDD ), IMODE,
+ $ COND, ANORM, N, N, 'N', COPYA, 1, 1, DESCA,
+ $ ORDER, WORK( INDWORK+IPREPAD ), SIZETMS,
+ $ IINFO )
+*
+ CALL PCCHEKPAD( DESCA( CTXT_ ), 'PCLATMS2-WORK', SIZETMS, 1,
+ $ WORK( INDWORK ), SIZETMS, IPREPAD, IPOSTPAD,
+ $ PADVAL+2.0E0 )
+*
+ WKNOWN = .TRUE.
+*
+ ELSE IF( ITYPE.EQ.8 ) THEN
+*
+* Hermitian, random eigenvalues
+*
+ NP = NUMROC( N, DESCA( MB_ ), MYROW, 0, NPROW )
+ NQ = NUMROC( N, DESCA( NB_ ), MYCOL, 0, NPCOL )
+ CALL PCMATGEN( DESCA( CTXT_ ), 'H', 'N', N, N, DESCA( MB_ ),
+ $ DESCA( NB_ ), COPYA, DESCA( LLD_ ),
+ $ DESCA( RSRC_ ), DESCA( CSRC_ ), ISEED( 1 ),
+ $ 0, NP, 0, NQ, MYROW, MYCOL, NPROW, NPCOL )
+ INFO = 0
+ WKNOWN = .FALSE.
+*
+ ELSE IF( ITYPE.EQ.9 ) THEN
+*
+* Positive definite, eigenvalues specified.
+*
+ CALL PCFILLPAD( DESCA( CTXT_ ), SIZETMS, 1, WORK( INDWORK ),
+ $ SIZETMS, IPREPAD, IPOSTPAD, PADVAL+3.0E0 )
+*
+ CALL PCLATMS( N, N, 'S', ISEED, 'S',RWORK( INDD ), IMODE,
+ $ COND, ANORM, N, N, 'N', COPYA, 1, 1, DESCA,
+ $ ORDER, WORK( INDWORK+IPREPAD ), SIZETMS,
+ $ IINFO )
+*
+ WKNOWN = .TRUE.
+*
+ CALL PCCHEKPAD( DESCA( CTXT_ ), 'PCLATMS3-WORK', SIZETMS, 1,
+ $ WORK( INDWORK ), SIZETMS, IPREPAD, IPOSTPAD,
+ $ PADVAL+3.0E0 )
+*
+ ELSE IF( ITYPE.EQ.10 ) THEN
+*
+* Block diagonal matrix with each block being a positive
+* definite tridiagonal submatrix.
+*
+ CALL PCLASET( 'All', N, N,ZZERO,ZZERO, COPYA, 1, 1, DESCA )
+ NP = NUMROC( N, DESCA( MB_ ), 0, 0, NPROW )
+ NQ = NUMROC( N, DESCA( NB_ ), 0, 0, NPCOL )
+ NLOC = MIN( NP, NQ )
+ NGEN = 0
+ 70 CONTINUE
+*
+ IF( NGEN.LT.N ) THEN
+ IN = MIN( 1+INT( SLARAN( ISEED )*REAL( NLOC ) ), N-NGEN )
+*
+ CALL CLATMS( IN, IN, 'S', ISEED, 'P',RWORK( INDD ),
+ $ IMODE, COND, ANORM, 1, 1, 'N', A, LDA,
+ $ WORK( INDWORK ), IINFO )
+*
+ DO 80 I = 2, IN
+ TEMP1 = ABS( A( I-1, I ) ) /
+ $ SQRT( ABS( A( I-1, I-1 )*A( I, I ) ) )
+ IF( TEMP1.GT.HALF ) THEN
+ A( I-1, I ) = HALF*SQRT( ABS( A( I-1, I-1 )*A( I,
+ $ I ) ) )
+ A( I, I-1 ) = A( I-1, I )
+ END IF
+ 80 CONTINUE
+ CALL PCELSET( COPYA, NGEN+1, NGEN+1, DESCA, A( 1, 1 ) )
+ DO 90 I = 2, IN
+ CALL PCELSET( COPYA, NGEN+I, NGEN+I, DESCA,
+ $ A( I, I ) )
+ CALL PCELSET( COPYA, NGEN+I-1, NGEN+I, DESCA,
+ $ A( I-1, I ) )
+ CALL PCELSET( COPYA, NGEN+I, NGEN+I-1, DESCA,
+ $ A( I, I-1 ) )
+ 90 CONTINUE
+ NGEN = NGEN + IN
+ GO TO 70
+ END IF
+ WKNOWN = .FALSE.
+*
+ ELSE IF( ITYPE.EQ.11 ) THEN
+*
+* Geometrically sized clusters. Eigenvalues: 0,1,1,2,2,2,2,...
+*
+ NGEN = 0
+ J = 1
+ TEMP1 = ZERO
+ 100 CONTINUE
+ IF( NGEN.LT.N ) THEN
+ IN = MIN( J, N-NGEN )
+ DO 110 I = 0, IN - 1
+ RWORK( INDD+NGEN+I ) = TEMP1
+ 110 CONTINUE
+ TEMP1 = TEMP1 + ONE
+ J = 2*J
+ NGEN = NGEN + IN
+ GO TO 100
+ END IF
+*
+ CALL PCFILLPAD( DESCA( CTXT_ ), SIZETMS, 1, WORK( INDWORK ),
+ $ SIZETMS, IPREPAD, IPOSTPAD, PADVAL+4.0E0 )
+*
+ CALL PCLATMS( N, N, 'S', ISEED, 'S',RWORK( INDD ), IMODE,
+ $ COND, ANORM, 0, 0, 'N', COPYA, 1, 1, DESCA,
+ $ ORDER, WORK( INDWORK+IPREPAD ), SIZETMS,
+ $ IINFO )
+*
+ CALL PCCHEKPAD( DESCA( CTXT_ ), 'PCLATMS4-WORK', SIZETMS, 1,
+ $ WORK( INDWORK ), SIZETMS, IPREPAD, IPOSTPAD,
+ $ PADVAL+4.0E0 )
+*
+ ELSE
+ IINFO = 1
+ END IF
+*
+ IF( WKNOWN )
+ $ CALL SLASRT( 'I', N,RWORK( INDD ), IINFO )
+*
+ CALL PCLASIZEHEEVR( WKNOWN, 'A', N, DESCA, VL, VU, IL, IU,
+ $ ISEED,RWORK( INDD ), MAXSIZE, VECSIZE,
+ $ VALSIZE )
+ LEVRSIZE = MIN( MAXSIZE, LLRWORK )
+*
+ CALL PCSEPRSUBTST( WKNOWN, 'v', 'a', UPLO, N, VL, VU, IL, IU,
+ $ THRESH, ABSTOL, A, COPYA, Z, 1, 1, DESCA,
+ $ RWORK( INDD ), WIN, IFAIL, ICLUSTR, GAP,
+ $ IPREPAD, IPOSTPAD, WORK( INDWORK ), LLWORK,
+ $ RWORK( INDRWORK ), LLRWORK,
+ $ LEVRSIZE, IWORK, ISIZEEVR, RES, TSTNRM,
+ $ QTQNRM, NOUT )
+*
+ MAXTSTNRM = TSTNRM
+ MAXQTQNRM = QTQNRM
+*
+ IF( THRESH.LE.ZERO ) THEN
+ PASSED = 'SKIPPED '
+ INFO = 2
+ ELSE IF( RES.NE.0 ) THEN
+ PASSED = 'FAILED '
+ INFO = 1
+ END IF
+ END IF
+*
+ IF( THRESH.GT.ZERO .AND. LSAME( SUBTESTS, 'Y' ) ) THEN
+*
+* Subtest 1: JOBZ = 'N', RANGE = 'A', minimum memory
+*
+ IF( INFO.EQ.0 ) THEN
+*
+ JOBZ = 'N'
+ RANGE = 'A'
+ CALL PCLASIZEHEEVR( .TRUE., RANGE, N, DESCA, VL, VU, IL, IU,
+ $ ISEED, WIN( 1+IPREPAD ), MAXSIZE,
+ $ VECSIZE, VALSIZE )
+*
+ LEVRSIZE = VALSIZE
+*
+ CALL PCSEPRSUBTST( .TRUE., JOBZ, RANGE, UPLO, N, VL, VU, IL,
+ $ IU, THRESH, ABSTOL, A, COPYA, Z, 1, 1,
+ $ DESCA, WIN( 1+IPREPAD ), WNEW, IFAIL,
+ $ ICLUSTR, GAP, IPREPAD, IPOSTPAD,
+ $ WORK( INDWORK ), LLWORK,
+ $ RWORK, LRWORK, LEVRSIZE,
+ $ IWORK, ISIZEEVR, RES, TSTNRM, QTQNRM,
+ $ NOUT )
+*
+ IF( RES.NE.0 ) THEN
+ MAXTSTNRM = MAX( TSTNRM, MAXTSTNRM )
+ MAXQTQNRM = MAX( QTQNRM, MAXQTQNRM )
+ PASSED = 'FAILED stest 1'
+ INFO = 1
+ END IF
+ END IF
+*
+* Subtest 2: JOBZ = 'N', RANGE = 'I', minimum memory
+*
+ IF( INFO.EQ.0 ) THEN
+*
+ IL = -1
+ IU = -1
+ JOBZ = 'N'
+ RANGE = 'I'
+*
+* Use PCLASIZEHEEVR to choose IL and IU.
+*
+ CALL PCLASIZEHEEVR( .TRUE., RANGE, N, DESCA, VL, VU, IL, IU,
+ $ ISEED, WIN( 1+IPREPAD ), MAXSIZE,
+ $ VECSIZE, VALSIZE )
+*
+ LEVRSIZE = VALSIZE
+*
+ CALL PCSEPRSUBTST( .TRUE., JOBZ, RANGE, UPLO, N, VL, VU, IL,
+ $ IU, THRESH, ABSTOL, A, COPYA, Z, 1, 1,
+ $ DESCA, WIN( 1+IPREPAD ), WNEW, IFAIL,
+ $ ICLUSTR, GAP, IPREPAD, IPOSTPAD,
+ $ WORK( INDWORK ), LLWORK,
+ $ RWORK, LRWORK, LEVRSIZE,
+ $ IWORK, ISIZEEVR, RES, TSTNRM, QTQNRM,
+ $ NOUT )
+*
+ IF( RES.NE.0 ) THEN
+ MAXTSTNRM = MAX( TSTNRM, MAXTSTNRM )
+ MAXQTQNRM = MAX( QTQNRM, MAXQTQNRM )
+ PASSED = 'FAILED stest 2'
+ INFO = 1
+ END IF
+ END IF
+*
+* Subtest 3: JOBZ = 'V', RANGE = 'I', minimum memory
+*
+ IF( INFO.EQ.0 ) THEN
+ IL = -1
+ IU = -1
+ JOBZ = 'V'
+ RANGE = 'I'
+*
+* We use PCLASIZEHEEVR to choose IL and IU for us.
+*
+ CALL PCLASIZEHEEVR( .TRUE., RANGE, N, DESCA, VL, VU, IL, IU,
+ $ ISEED, WIN( 1+IPREPAD ), MAXSIZE,
+ $ VECSIZE, VALSIZE )
+*
+ LEVRSIZE = VECSIZE
+*
+ CALL PCSEPRSUBTST( .TRUE., JOBZ, RANGE, UPLO, N, VL, VU, IL,
+ $ IU, THRESH, ABSTOL, A, COPYA, Z, 1, 1,
+ $ DESCA, WIN( 1+IPREPAD ), WNEW, IFAIL,
+ $ ICLUSTR, GAP, IPREPAD, IPOSTPAD,
+ $ WORK( INDWORK ), LLWORK,
+ $ RWORK, LRWORK, LEVRSIZE,
+ $ IWORK, ISIZEEVR, RES, TSTNRM, QTQNRM,
+ $ NOUT )
+*
+ IF( RES.NE.0 ) THEN
+ MAXTSTNRM = MAX( TSTNRM, MAXTSTNRM )
+ MAXQTQNRM = MAX( QTQNRM, MAXQTQNRM )
+ PASSED = 'FAILED stest 3'
+ INFO = 1
+ END IF
+ END IF
+*
+* Subtest 4: JOBZ = 'N', RANGE = 'V', minimum memory
+*
+ IF( INFO.EQ.0 ) THEN
+ VL = ONE
+ VU = -ONE
+ JOBZ = 'N'
+ RANGE = 'V'
+*
+* We use PCLASIZEHEEVR to choose IL and IU for us.
+*
+ CALL PCLASIZEHEEVR( .TRUE., RANGE, N, DESCA, VL, VU, IL, IU,
+ $ ISEED, WIN( 1+IPREPAD ), MAXSIZE,
+ $ VECSIZE, VALSIZE )
+*
+ LEVRSIZE = VALSIZE
+*
+ CALL PCSEPRSUBTST( .TRUE., JOBZ, RANGE, UPLO, N, VL, VU, IL,
+ $ IU, THRESH, ABSTOL, A, COPYA, Z, 1, 1,
+ $ DESCA, WIN( 1+IPREPAD ), WNEW, IFAIL,
+ $ ICLUSTR, GAP, IPREPAD, IPOSTPAD,
+ $ WORK( INDWORK ), LLWORK,
+ $ RWORK, LRWORK, LEVRSIZE,
+ $ IWORK, ISIZEEVR, RES, TSTNRM, QTQNRM,
+ $ NOUT )
+*
+ IF( RES.NE.0 ) THEN
+ MAXTSTNRM = MAX( TSTNRM, MAXTSTNRM )
+ MAXQTQNRM = MAX( QTQNRM, MAXQTQNRM )
+ PASSED = 'FAILED stest 4'
+ INFO = 1
+ END IF
+ END IF
+*
+* Subtest 5: JOBZ = 'V', RANGE = 'V', minimum memory
+*
+ IF( INFO.EQ.0 ) THEN
+ VL = ONE
+ VU = -ONE
+ JOBZ = 'V'
+ RANGE = 'V'
+*
+* We use PCLASIZEHEEVR to choose VL and VU for us.
+*
+ CALL PCLASIZEHEEVR( .TRUE., RANGE, N, DESCA, VL, VU, IL, IU,
+ $ ISEED, WIN( 1+IPREPAD ), MAXSIZE,
+ $ VECSIZE, VALSIZE )
+*
+ LEVRSIZE = VECSIZE
+*
+ CALL PCSEPRSUBTST( .TRUE., JOBZ, RANGE, UPLO, N, VL, VU, IL,
+ $ IU, THRESH, ABSTOL, A, COPYA, Z, 1, 1,
+ $ DESCA, WIN( 1+IPREPAD ), WNEW, IFAIL,
+ $ ICLUSTR, GAP, IPREPAD, IPOSTPAD,
+ $ WORK( INDWORK ), LLWORK,
+ $ RWORK, LRWORK, LEVRSIZE,
+ $ IWORK, ISIZEEVR, RES, TSTNRM, QTQNRM,
+ $ NOUT )
+*
+ IF( RES.NE.0 ) THEN
+ MAXTSTNRM = MAX( TSTNRM, MAXTSTNRM )
+ MAXQTQNRM = MAX( QTQNRM, MAXQTQNRM )
+ PASSED = 'FAILED stest 5'
+ INFO = 1
+ END IF
+ END IF
+ END IF
+*
+ CALL IGAMX2D( CONTEXT, 'All', ' ', 1, 1, INFO, 1, -1, -1, -1, -1,
+ $ -1 )
+ IF( INFO.EQ.1 ) THEN
+ IF( IAM.EQ.0 .AND. .FALSE. ) THEN
+ WRITE( NOUT, FMT = 9994 )'C '
+ WRITE( NOUT, FMT = 9993 )ISEEDIN( 1 )
+ WRITE( NOUT, FMT = 9992 )ISEEDIN( 2 )
+ WRITE( NOUT, FMT = 9991 )ISEEDIN( 3 )
+ WRITE( NOUT, FMT = 9990 )ISEEDIN( 4 )
+ IF( LSAME( UPLO, 'L' ) ) THEN
+ WRITE( NOUT, FMT = 9994 )' UPLO= ''L'' '
+ ELSE
+ WRITE( NOUT, FMT = 9994 )' UPLO= ''U'' '
+ END IF
+ IF( LSAME( SUBTESTS, 'Y' ) ) THEN
+ WRITE( NOUT, FMT = 9994 )' SUBTESTS= ''Y'' '
+ ELSE
+ WRITE( NOUT, FMT = 9994 )' SUBTESTS= ''N'' '
+ END IF
+ WRITE( NOUT, FMT = 9989 )N
+ WRITE( NOUT, FMT = 9988 )NPROW
+ WRITE( NOUT, FMT = 9987 )NPCOL
+ WRITE( NOUT, FMT = 9986 )NB
+ WRITE( NOUT, FMT = 9985 )MATTYPE
+ WRITE( NOUT, FMT = 9982 )ABSTOL
+ WRITE( NOUT, FMT = 9981 )THRESH
+ WRITE( NOUT, FMT = 9994 )'C '
+ END IF
+ END IF
+*
+ CALL SLCOMBINE( CONTEXT, 'All', '>', 'W', 6, 1, WTIME )
+ CALL SLCOMBINE( CONTEXT, 'All', '>', 'C', 6, 1, CTIME )
+ IF( IAM.EQ.0 ) THEN
+ IF( INFO.EQ.0 .OR. INFO.EQ.1 ) THEN
+ IF( WTIME( 1 ).GE.0.0 ) THEN
+ WRITE( NOUT, FMT = 9999 )N, NB, NPROW, NPCOL, MATTYPE,
+ $ SUBTESTS, WTIME( 1 ), CTIME( 1 ), MAXTSTNRM,
+ $ MAXQTQNRM, PASSED
+ ELSE
+ WRITE( NOUT, FMT = 9998 )N, NB, NPROW, NPCOL, MATTYPE,
+ $ SUBTESTS, CTIME( 1 ), MAXTSTNRM, MAXQTQNRM, PASSED
+ END IF
+ ELSE IF( INFO.EQ.2 ) THEN
+ IF( WTIME( 1 ).GE.0.0 ) THEN
+ WRITE( NOUT, FMT = 9997 )N, NB, NPROW, NPCOL, MATTYPE,
+ $ SUBTESTS, WTIME( 1 ), CTIME( 1 )
+ ELSE
+ WRITE( NOUT, FMT = 9996 )N, NB, NPROW, NPCOL, MATTYPE,
+ $ SUBTESTS, CTIME( 1 )
+ END IF
+ ELSE IF( INFO.EQ.3 ) THEN
+ WRITE( NOUT, FMT = 9995 )N, NB, NPROW, NPCOL, MATTYPE,
+ $ SUBTESTS
+ END IF
+C WRITE(*,*)'************************************************'
+ END IF
+*
+
+ RETURN
+ 9999 FORMAT( 1X, I5, 1X, I3, 1X, I3, 1X, I3, 1X, I3, 3X, A1, 1X,
+ $ F8.2, 1X, F8.2, 1X, G9.2, 1X, G9.2, 1X, A14 )
+ 9998 FORMAT( 1X, I5, 1X, I3, 1X, I3, 1X, I3, 1X, I3, 3X, A1, 1X, 8X,
+ $ 1X, F8.2, 1X, G9.2, 1X, G9.2, A14 )
+ 9997 FORMAT( 1X, I5, 1X, I3, 1X, I3, 1X, I3, 1X, I3, 3X, A1, 1X, F8.2,
+ $ 1X, F8.2, 21X, 'Bypassed' )
+ 9996 FORMAT( 1X, I5, 1X, I3, 1X, I3, 1X, I3, 1X, I3, 3X, A1, 1X, 8X,
+ $ 1X, F8.2, 21X, 'Bypassed' )
+ 9995 FORMAT( 1X, I5, 1X, I3, 1X, I3, 1X, I3, 1X, I3, 3X, A1, 32X,
+ $ 'Bad MEMORY parameters' )
+ 9994 FORMAT( A )
+ 9993 FORMAT( ' ISEED( 1 ) =', I8 )
+ 9992 FORMAT( ' ISEED( 2 ) =', I8 )
+ 9991 FORMAT( ' ISEED( 3 ) =', I8 )
+ 9990 FORMAT( ' ISEED( 4 ) =', I8 )
+ 9989 FORMAT( ' N=', I8 )
+ 9988 FORMAT( ' NPROW=', I8 )
+ 9987 FORMAT( ' NPCOL=', I8 )
+ 9986 FORMAT( ' NB=', I8 )
+ 9985 FORMAT( ' MATTYPE=', I8 )
+C 9984 FORMAT( ' IBTYPE=', I8 )
+C 9983 FORMAT( ' SUBTESTS=', A1 )
+ 9982 FORMAT( ' ABSTOL=', D16.6 )
+ 9981 FORMAT( ' THRESH=', D16.6 )
+C 9980 FORMAT( ' Increase TOTMEM in PCSEPRDRIVER' )
+*
+* End of PCSEPRTST
+*
+ END
+
+
+
+
diff --git a/TESTING/EIG/pcseptst.f b/TESTING/EIG/pcseptst.f
index dedeb7f..a2165b3 100644
--- a/TESTING/EIG/pcseptst.f
+++ b/TESTING/EIG/pcseptst.f
@@ -537,6 +537,10 @@
$ WORK( INDWORK ), SIZETMS, IPREPAD, IPOSTPAD,
$ PADVAL+4.0E+0 )
*
+*
+* WKNOWN ... NOT SET, GUESS A DEFAULT
+*
+ WKNOWN = .TRUE.
ELSE
IINFO = 1
END IF
diff --git a/TESTING/EIG/pdgseptst.f b/TESTING/EIG/pdgseptst.f
index 56b2958..9033beb 100644
--- a/TESTING/EIG/pdgseptst.f
+++ b/TESTING/EIG/pdgseptst.f
@@ -531,6 +531,10 @@
$ WORK( INDWORK ), SIZETMS, IPREPAD, IPOSTPAD,
$ PADVAL+4.0D+0 )
*
+*
+* WKNOWN ... NOT SET, GUESS A DEFAULT
+*
+ WKNOWN = .TRUE.
ELSE
IINFO = 1
END IF
diff --git a/TESTING/EIG/pdhseqrdriver.f b/TESTING/EIG/pdhseqrdriver.f
new file mode 100644
index 0000000..bddd5f4
--- /dev/null
+++ b/TESTING/EIG/pdhseqrdriver.f
@@ -0,0 +1,564 @@
+***********************************************************************
+* Test program for ScaLAPACK-style routine PDHSEQR *
+***********************************************************************
+*
+* Contributor: Robert Granat and Meiyue Shao
+* This version is of Feb 2011.
+*
+ PROGRAM PDHSEQRDRIVER
+*
+* Declarations
+*
+ IMPLICIT NONE
+* ...Parameters...
+ LOGICAL BALANCE, COMPHESS, COMPRESI,
+ $ COMPORTH
+ LOGICAL DEBUG, PRN, TIMESTEPS, BARR,
+ $ UNI_LAPACK
+ INTEGER SLV_MIN, SLV_MAX
+ PARAMETER ( DEBUG = .FALSE.,
+ $ PRN = .FALSE.,
+ $ TIMESTEPS = .TRUE.,
+ $ COMPHESS = .TRUE.,
+ $ COMPRESI = .TRUE.,
+ $ COMPORTH = .TRUE.,
+ $ BALANCE = .TRUE.,
+ $ BARR = .FALSE.,
+* Solver: 1-PDLAQR1, 2-PDHSEQR.
+ $ SLV_MIN = 2, SLV_MAX = 2,
+ $ UNI_LAPACK = .TRUE. )
+ INTEGER N, NB, ARSRC, ACSRC
+ PARAMETER (
+* Problem size.
+ $ N = 500, NB = 50,
+* What processor should hold the first element in A?
+ $ ARSRC = 0, ACSRC = 0 )
+ INTEGER BLOCK_CYCLIC_2D, CSRC_, CTXT_, DLEN_, DT_,
+ $ LLD_, MB_, M_, NB_, N_, RSRC_
+ PARAMETER ( BLOCK_CYCLIC_2D = 1, DLEN_ = 9, DT_ = 1,
+ $ CTXT_ = 2, M_ = 3, N_ = 4, MB_ = 5, NB_ = 6,
+ $ RSRC_ = 7, CSRC_ = 8, LLD_ = 9 )
+ INTEGER DPALLOC, INTALLC
+ INTEGER DPSIZ, INTSZ, NOUT, IZERO
+ PARAMETER ( DPSIZ = 8, DPALLOC = 8 000 000,
+ $ INTSZ = 4, INTALLC = 8 000 000,
+ $ NOUT = 6, IZERO = 0)
+ DOUBLE PRECISION ZERO, ONE, TWO
+ PARAMETER ( ZERO = 0.0D+00, ONE = 1.0D+00, TWO = 2.0D+00 )
+*
+* ...Local Scalars...
+ INTEGER ICTXT, IAM, NPROW, NPCOL, MYROW, MYCOL,
+ $ SYS_NPROCS, NPROCS, AROWS, ACOLS, TEMP_ICTXT
+ INTEGER THREADS
+ INTEGER INFO, KTOP, KBOT, ILO, IHI, I
+ INTEGER IPA, IPACPY, IPQ, WR1, WI1, WR2, WI2, IPW1,
+ $ IPW2, IPIW
+ INTEGER TOTIT, SWEEPS, TOTNS, HESS
+ DOUBLE PRECISION EPS, THRESH
+ DOUBLE PRECISION STAMP, TOTTIME, T_BA, T_GEN, T_HS, T_SCH, T_QR,
+ $ T_RES, ITPEREIG, SWPSPEIG, NSPEIG, SPEEDUP,
+ $ EFFICIENCY
+ DOUBLE PRECISION RNORM, ANORM, R1, ORTH, O1, O2, DPDUM, ELEM1,
+ $ ELEM2, ELEM3, EDIFF
+ INTEGER SOLVER
+ CHARACTER*6 PASSED
+*
+* ...Local Arrays...
+ INTEGER DESCA( DLEN_ ), DESCQ( DLEN_ ), DESCVEC( DLEN_ )
+ DOUBLE PRECISION SCALE( N )
+ DOUBLE PRECISION, ALLOCATABLE :: MEM(:)
+ INTEGER, ALLOCATABLE :: IMEM(:)
+*
+* ...Intrinsic Functions...
+ INTRINSIC INT, DBLE, SQRT, MAX, MIN
+*
+* ...External Functions...
+ INTEGER NUMROC
+ DOUBLE PRECISION PDLAMCH, PDLANGE, MPI_WTIME
+ EXTERNAL BLACS_PINFO, BLACS_GET, BLACS_GRIDINIT,
+ $ BLACS_GRIDINFO, BLACS_GRIDEXIT, BLACS_EXIT
+ EXTERNAL NUMROC, PDLAMCH, PDLASET, PDGEHRD, PDLANGE
+ EXTERNAL DGEBAL, DGEHRD
+ EXTERNAL MPI_WTIME
+ EXTERNAL PDGEBAL
+ EXTERNAL PDMATGEN2
+*
+* ...Executable statements...
+*
+ CALL BLACS_PINFO( IAM, SYS_NPROCS )
+ NPROW = INT( SQRT( DBLE(SYS_NPROCS) ) )
+ NPCOL = SYS_NPROCS / NPROW
+ CALL BLACS_GET( 0, 0, ICTXT )
+ CALL BLACS_GRIDINIT( ICTXT, '2D', NPROW, NPCOL )
+ CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL )
+c print*, iam, ictxt, myrow, mycol
+c IF ( ( MYROW.GE.NPROW ) .OR. ( MYCOL.GE.NPCOL ) ) GO TO 777
+ IF ( ICTXT.LT.0 ) GO TO 777
+*
+* Read out the number of underlying threads and set stack size in
+* kilobytes.
+*
+ THRESH = 30.0
+ TOTTIME = MPI_WTIME()
+ T_GEN = 0.0D+00
+ T_RES = 0.0D+00
+ T_SCH = 0.0D+00
+*
+* Allocate and Init memory with zeros.
+*
+ INFO = 0
+ ALLOCATE ( MEM( DPALLOC ), STAT = INFO )
+ IF( INFO.NE.0 ) THEN
+ WRITE(*,*) '% Could not allocate MEM. INFO = ', INFO
+ GO TO 777
+ END IF
+ ALLOCATE ( IMEM( INTALLC ), STAT = INFO )
+ IF( INFO.NE.0 ) THEN
+ WRITE(*,*) '% Could not allocate IMEM. INFO = ', INFO
+ GO TO 777
+ END IF
+ MEM( 1:DPALLOC ) = ZERO
+ IMEM( 1:INTALLC ) = IZERO
+*
+* Get machine epsilon.
+*
+ EPS = PDLAMCH( ICTXT, 'Epsilon' )
+*
+* Print welcoming message.
+*
+ IF( IAM.EQ.0 ) THEN
+ WRITE(*,*)
+ WRITE(*,*) 'ScaLAPACK Test for PDHSEQR'
+ WRITE(*,*)
+ WRITE(*,*) 'epsilon = ', EPS
+ WRITE(*,*) 'threshold = ', THRESH
+ WRITE(*,*)
+ WRITE(*,*) 'Residual and Orthogonality Residual computed by:'
+ WRITE(*,*)
+ WRITE(*,*) 'Residual = ',
+ $ ' || T - Q^T*A*Q ||_F / ( ||A||_F * eps * sqrt(N) )'
+ WRITE(*,*)
+ WRITE(*,*) 'Orthogonality = ',
+ $ ' MAX( || I - Q^T*Q ||_F, || I - Q*Q^T ||_F ) / ',
+ $ ' (eps * N)'
+ WRITE(*,*)
+ WRITE(*,*)
+ $ 'Test passes if both residuals are less then threshold'
+ WRITE( NOUT, * )
+ WRITE( NOUT, FMT = 9995 )
+ WRITE( NOUT, FMT = 9994 )
+ END IF
+*
+* Loop over problem parameters.
+*
+ DO KTOP = 1, 1
+ DO KBOT = N, N
+ DO SOLVER = SLV_MAX, SLV_MIN, -1
+*
+* Set INFO to zero for this run.
+*
+ INFO = 0
+ NPROCS = NPROW*NPCOL
+ TEMP_ICTXT = ICTXT
+*
+* Count the number of rows and columns of current problem
+* for the current block sizes and grid properties.
+*
+ STAMP = MPI_WTIME()
+ AROWS = NUMROC( N, NB, MYROW, 0, NPROW )
+ ACOLS = NUMROC( N, NB, MYCOL, 0, NPCOL )
+*
+* Set up matrix descriptors.
+*
+ IF( DEBUG ) WRITE(*,*) '% #', IAM, ': Set up descriptors...'
+ IF( BARR ) CALL BLACS_BARRIER(ICTXT, 'A')
+ CALL DESCINIT( DESCA, N, N, NB, NB, MIN(ARSRC,NPROW-1),
+ $ MIN(NPCOL-1,ACSRC), TEMP_ICTXT, MAX(1, AROWS), INFO )
+ IF ( INFO.NE.0 ) THEN
+ WRITE(*,*) "% DESCINIT DESCA failed, INFO =", INFO
+ GO TO 999
+ END IF
+ CALL DESCINIT( DESCQ, N, N, NB, NB, MIN(ARSRC,NPROW-1),
+ $ MIN(NPCOL-1,ACSRC), TEMP_ICTXT, MAX(1, AROWS), INFO )
+ IF ( INFO.NE.0 ) THEN
+ WRITE(*,*) "% DESCINIT DESCQ failed, INFO =", INFO
+ GO TO 999
+ END IF
+ CALL DESCINIT( DESCVEC, N, 1, N, 1, MIN(ARSRC,NPROW-1),
+ $ MIN(NPCOL-1,ACSRC), TEMP_ICTXT, N, INFO )
+ IF ( INFO.NE.0 ) THEN
+ WRITE(*,*) "% DESCINIT DESCVEC failed, INFO =", INFO
+ GO TO 999
+ END IF
+*
+* Assign pointer for ScaLAPACK arrays - first set DP memory.
+*
+ IF( DEBUG ) WRITE(*,*) '% #', IAM, ': Assign pointers...'
+ IPA = 1
+ IPACPY = IPA + DESCA( LLD_ ) * ACOLS
+ IPQ = IPACPY + DESCA( LLD_ ) * ACOLS
+ WR1 = IPQ + DESCQ( LLD_ ) * ACOLS
+ WI1 = WR1 + N
+ WR2 = WI1 + N
+ WI2 = WR2 + N
+ IPW1 = WI2 + N
+ IPW2 = IPW1 + DESCA( LLD_ ) * ACOLS
+ IF( DEBUG ) WRITE(*,*) '% (IPW2,DPALLOC):', IPW2, DPALLOC
+* PRINT*, '%', IPA, IPACPY, IPQ, WR1, WI1, WR2, WI2, IPW1, IPW2
+ IF( IPW2+DESCA(LLD_)*ACOLS .GT. DPALLOC+1 ) THEN
+ WRITE(*,*) '% Not enough DP memory!'
+ GO TO 999
+ END IF
+*
+* Then set integer memory pointers.
+*
+ IPIW = 1
+*
+* Generate testproblem.
+*
+ IF( BARR ) CALL BLACS_BARRIER(ICTXT, 'A')
+ CALL PDLASET( 'All over', N, N, ZERO, ONE, MEM(IPQ), 1, 1,
+ $ DESCQ )
+ CALL PDMATGEN2( TEMP_ICTXT, 'Random', 'NoDiagDominant',
+ $ N, N, NB, NB, MEM(IPA), DESCA( LLD_ ), 0, 0, 7, 0,
+ $ AROWS, 0, ACOLS, MYROW, MYCOL, NPROW, NPCOL )
+ IF( .NOT. COMPHESS ) THEN
+ CALL PDLASET( 'Lower triangular', N-2, N-2, ZERO, ZERO,
+ $ MEM(IPA), 3, 1, DESCA )
+ CALL PDLASET( 'All over', N, N, ZERO, ONE, MEM(IPQ),
+ $ 1, 1, DESCQ )
+ IF( KTOP.GT.1 )
+ $ CALL PDLASET( 'Lower triangular', KTOP-1, KTOP-1,
+ $ ZERO, ZERO, MEM(IPA), 2, 1, DESCQ )
+ IF( KBOT.LT.N )
+ $ CALL PDLASET( 'Lower triangular', N-KBOT, N-KBOT,
+ $ ZERO, ZERO, MEM(IPA), KBOT+1, KBOT, DESCQ )
+ END IF
+*
+* Do balancing if general matrix.
+*
+ IF( BARR ) CALL BLACS_BARRIER(ICTXT, 'A')
+ T_BA = MPI_WTIME()
+ IF( COMPHESS .AND. BALANCE ) THEN
+ IF( NPROCS.EQ.1 .AND. SOLVER.NE.2 .AND. UNI_LAPACK ) THEN
+ IF( DEBUG ) WRITE(*,*) '% #', IAM, ': == dgebal =='
+ CALL DGEBAL( 'Both', N, MEM(IPA), DESCA(LLD_), ILO,
+ $ IHI, SCALE, INFO )
+ IF ( INFO.NE.0 ) THEN
+ WRITE(*,*) "% DGEBAL failed, INFO =", INFO
+ GO TO 999
+ END IF
+ ELSE
+ IF( DEBUG ) WRITE(*,*) '% #', IAM, ': == pdgebal =='
+ CALL PDGEBAL( 'Both', N, MEM(IPA), DESCA, ILO, IHI,
+ $ SCALE, INFO )
+ IF ( INFO.NE.0 ) THEN
+ WRITE(*,*) "% PDGEBAL failed, INFO =", INFO
+ GO TO 999
+ END IF
+ END IF
+ ELSEIF( COMPHESS ) THEN
+ ILO = 1
+ IHI = N
+ ELSE
+ ILO = KTOP
+ IHI = KBOT
+ END IF
+ T_BA = MPI_WTIME() - T_BA
+c IF( TIMESTEPS.AND.IAM.EQ.0 ) WRITE(*,*)
+c $ ' %%% Balancing took in seconds:',T_BA
+ IF( DEBUG ) WRITE(*,*) '% #', IAM, ': ILO,IHI=',ILO,IHI
+*
+* Make a copy of A.
+*
+ IF( BARR ) CALL BLACS_BARRIER(ICTXT, 'A')
+ IF( DEBUG ) WRITE(*,*) '% #', IAM, ': Copy matrix A'
+ CALL PDLACPY( 'All', N, N, MEM(IPA), 1, 1, DESCA, MEM(IPACPY),
+ $ 1, 1, DESCA )
+*
+* Print matrices to screen in debugging mode.
+*
+ IF( PRN )
+ $ CALL PDLAPRNT( N, N, MEM(IPACPY), 1, 1, DESCA, 0, 0,
+ $ 'A', NOUT, MEM(IPW1) )
+ T_GEN = T_GEN + MPI_WTIME() - STAMP - T_BA
+c IF( TIMESTEPS.AND.IAM.EQ.0 ) WRITE(*,*)
+c $ ' %%% Generation took in seconds:',T_GEN
+*
+* Only compute the Hessenberg form if necessary.
+*
+ T_HS = MPI_WTIME()
+ IF( .NOT. COMPHESS ) GO TO 30
+*
+* Reduce A to Hessenberg form.
+*
+ IF( BARR ) CALL BLACS_BARRIER(ICTXT, 'A')
+ IF( DEBUG ) WRITE(*,*) '% #', IAM,
+ $ ': Reduce to Hessenberg form...N=',N, ILO,IHI
+* PRINT*, '% PDGEHRD: IPW2,MEM(IPW2)', IPW2, MEM(IPW2)
+ IF( NPROCS.EQ.1 .AND. SOLVER.NE.2 .AND. UNI_LAPACK ) THEN
+ IF( DEBUG ) WRITE(*,*) '% #', IAM, ': == dgehrd =='
+ CALL DGEHRD( N, ILO, IHI, MEM(IPA), DESCA(LLD_),
+ $ MEM(IPW1), MEM(IPW2), -1, INFO )
+ IF (DPALLOC-IPW2.LT.MEM(IPW2)) THEN
+ WRITE(*,*) "% Not enough memory for DGEHRD"
+ GO TO 999
+ END IF
+ CALL DGEHRD( N, ILO, IHI, MEM(IPA), DESCA(LLD_),
+ $ MEM(IPW1), MEM(IPW2), DPALLOC-IPW2, INFO )
+ IF ( INFO.NE.0 ) THEN
+ WRITE(*,*) "% DGEHRD failed, INFO =", INFO
+ GO TO 999
+ END IF
+ ELSE
+ IF( DEBUG ) WRITE(*,*) '% #', IAM, ': == pdgehrd =='
+ CALL PDGEHRD( N, ILO, IHI, MEM(IPA), 1, 1, DESCA, MEM(IPW1),
+ $ MEM(IPW2), -1, INFO )
+ IF (DPALLOC-IPW2.LT.MEM(IPW2)) THEN
+ WRITE(*,*) "% Not enough memory for PDGEHRD"
+ GO TO 999
+ END IF
+ CALL PDGEHRD( N, ILO, IHI, MEM(IPA), 1, 1, DESCA, MEM(IPW1),
+ $ MEM(IPW2), DPALLOC-IPW2, INFO )
+ IF ( INFO.NE.0 ) THEN
+ WRITE(*,*) "% PDGEHRD failed, INFO =", INFO
+ GO TO 999
+ END IF
+ END IF
+*
+* Form Q explicitly.
+*
+ IF( BARR ) CALL BLACS_BARRIER(ICTXT, 'A')
+ IF( DEBUG ) WRITE(*,*) '% #', IAM, ':Form Q explicitly'
+* PRINT*, '% PDORMHR: IPW2,MEM(IPW2)', IPW2, MEM(IPW2)
+ IF( DEBUG ) WRITE(*,*) '% #', IAM, ': == pdormhr =='
+ CALL PDORMHR( 'L', 'N', N, N, ILO, IHI, MEM(IPA), 1, 1,
+ $ DESCA, MEM(IPW1), MEM(IPQ), 1, 1, DESCQ, MEM(IPW2),
+ $ -1, INFO )
+ IF (DPALLOC-IPW2.LT.MEM(IPW2)) THEN
+ WRITE(*,*) "% Not enough memory for PDORMHR"
+ GO TO 999
+ END IF
+ CALL PDORMHR( 'L', 'N', N, N, ILO, IHI, MEM(IPA), 1, 1,
+ $ DESCA, MEM(IPW1), MEM(IPQ), 1, 1, DESCQ, MEM(IPW2),
+ $ DPALLOC-IPW2, INFO )
+ IF ( INFO.NE.0 ) THEN
+ WRITE(*,*) "% PDORMHR failed, INFO =", INFO
+ GO TO 999
+ END IF
+*
+* Extract the upper Hessenberg part of A.
+*
+ CALL PDLASET( 'Lower triangular', N-2, N-2, ZERO, ZERO,
+ $ MEM(IPA), 3, 1, DESCA )
+*
+* Print reduced matrix A in debugging mode.
+*
+ IF( PRN ) THEN
+ CALL PDLAPRNT( N, N, MEM(IPA), 1, 1, DESCA, 0, 0, 'H', NOUT,
+ $ MEM(IPW1) )
+ CALL PDLAPRNT( N, N, MEM(IPQ), 1, 1, DESCQ, 0, 0, 'Q', NOUT,
+ $ MEM(IPW1) )
+ END IF
+*
+ 30 CONTINUE
+ T_HS = MPI_WTIME() - T_HS
+c IF( TIMESTEPS.AND.IAM.EQ.0 ) WRITE(*,*)
+c $ ' %%% Hessenberg took in seconds:',T_HS
+*
+* Compute the real Schur form of the Hessenberg matrix A.
+*
+ IF( BARR ) CALL BLACS_BARRIER(ICTXT, 'A')
+ T_QR = MPI_WTIME()
+ IF( SOLVER.EQ.1 ) THEN
+ IF( DEBUG ) WRITE(*,*) '% #', IAM, ': == pdlaqr1 =='
+* PRINT*, '% PDLAQR1: IPW1,MEM(IPW1)', IPW1, MEM(IPW1)
+ CALL PDLAQR1( .TRUE., .TRUE., N, ILO, IHI, MEM(IPA), DESCA,
+ $ MEM(WR1), MEM(WI1), ILO, IHI, MEM(IPQ), DESCQ,
+ $ MEM(IPW1), -1, IMEM, -1, INFO )
+ IF (DPALLOC-IPW1.LT.MEM(IPW1)) THEN
+ WRITE(*,*) "% Not enough DP memory for PDLAQR1"
+ GO TO 999
+ END IF
+ IF (INTALLC.LT.IMEM(1)) THEN
+ WRITE(*,*) "% Not enough INT memory for PDLAQR1"
+ GO TO 999
+ END IF
+ CALL PDLAQR1( .TRUE., .TRUE., N, ILO, IHI, MEM(IPA), DESCA,
+ $ MEM(WR1), MEM(WI1), ILO, IHI, MEM(IPQ), DESCQ,
+ $ MEM(IPW1), DPALLOC-IPW1+1, IMEM, INTALLC, INFO )
+ IF (INFO.NE.0) THEN
+ WRITE(*,*) "% PDLAQR1: INFO =", INFO
+ END IF
+ ELSEIF( SOLVER.EQ.2 ) THEN
+ IF( DEBUG ) WRITE(*,*) '% #', IAM, ': == pdhseqr =='
+* PRINT*, '% PDHSEQR: IPW1,MEM(IPW1)', IPW1, MEM(IPW1)
+ IF( BARR ) CALL BLACS_BARRIER(ICTXT, 'A')
+ CALL PDHSEQR( 'Schur', 'Vectors', N, ILO, IHI, MEM(IPA),
+ $ DESCA, MEM(WR2), MEM(WI2), MEM(IPQ), DESCQ, MEM(IPW1),
+ $ -1, IMEM, -1, INFO )
+ IF( BARR ) CALL BLACS_BARRIER(ICTXT, 'A')
+ IF (DPALLOC-IPW1.LT.MEM(IPW1)) THEN
+ WRITE(*,*) "% Not enough DP memory for PDHSEQR"
+ GO TO 999
+ END IF
+ IF (INTALLC.LT.IMEM(1)) THEN
+ WRITE(*,*) "% Not enough INT memory for PDHSEQR"
+ GO TO 999
+ END IF
+ IF( BARR ) CALL BLACS_BARRIER(ICTXT, 'A')
+ CALL PDHSEQR( 'Schur', 'Vectors', N, ILO, IHI, MEM(IPA),
+ $ DESCA, MEM(WR2), MEM(WI2), MEM(IPQ), DESCQ, MEM(IPW1),
+ $ DPALLOC-IPW1+1, IMEM, INTALLC, INFO )
+ IF (INFO.NE.0) THEN
+ WRITE(*,*) "% PDHSEQR: INFO =", INFO
+ END IF
+ ELSE
+ WRITE(*,*) '% ERROR: Illegal SOLVER number!'
+ GO TO 999
+ END IF
+ T_QR = MPI_WTIME() - T_QR
+c IF( TIMESTEPS.AND.IAM.EQ.0 ) WRITE(*,*)
+c $ ' %%% QR-algorithm took in seconds:',T_QR
+ T_SCH = T_SCH + T_QR + T_HS + T_BA
+* TOTIT = IMEM(1)
+* SWEEPS = IMEM(2)
+* TOTNS = IMEM(3)
+ ITPEREIG = DBLE(TOTIT) / DBLE(N)
+ SWPSPEIG = DBLE(SWEEPS) / DBLE(N)
+ NSPEIG = DBLE(TOTNS) / DBLE(N)
+*
+* Print reduced matrix A in debugging mode.
+*
+ IF( PRN ) THEN
+ CALL PDLAPRNT( N, N, MEM(IPA), 1, 1, DESCA, 0, 0, 'T',
+ $ NOUT, MEM(IPW1) )
+ CALL PDLAPRNT( N, N, MEM(IPQ), 1, 1, DESCQ, 0, 0, 'Z',
+ $ NOUT, MEM(IPW1) )
+ END IF
+*
+* Check that returned Schur form is really a quasi-triangular
+* matrix.
+*
+ HESS = 0
+ DO I = 1, N-1
+ IF( I.GT.1 ) THEN
+ CALL PDELGET( 'All', '1-Tree', ELEM1, MEM(IPA), I, I-1,
+ $ DESCA )
+ ELSE
+ ELEM1 = ZERO
+ END IF
+ CALL PDELGET( 'All', '1-Tree', ELEM2, MEM(IPA), I+1, I,
+ $ DESCA )
+ IF( I.LT.N-1 ) THEN
+ CALL PDELGET( 'All', '1-Tree', ELEM3, MEM(IPA), I+2, I+1,
+ $ DESCA )
+ ELSE
+ ELEM3 = ZERO
+ END IF
+ IF( ELEM2.NE.ZERO .AND. ABS(ELEM1)+ABS(ELEM2)+ABS(ELEM3).GT.
+ $ ABS(ELEM2) ) HESS = HESS + 1
+ END DO
+*
+* Compute residual norms and other results:
+*
+* 1) RNORM = || T - Q'*A*Q ||_F / ||A||_F
+* 2) ORTH = MAX( || I - Q'*Q ||_F, || I - Q*Q' ||_F ) /
+* (epsilon*N)
+*
+ STAMP = MPI_WTIME()
+ IF( COMPRESI ) THEN
+ IF( DEBUG ) WRITE(*,*) '% #', IAM, ': Compute residuals 1'
+ IF( DEBUG ) WRITE(*,*) '% #', IAM, ': pdgemm 3'
+ CALL PDGEMM( 'N', 'N', N, N, N, ONE, MEM(IPACPY), 1, 1,
+ $ DESCA, MEM(IPQ), 1, 1, DESCQ, ZERO, MEM(IPW1), 1, 1,
+ $ DESCA )
+ IF( DEBUG ) WRITE(*,*) '% #', IAM, ': pdgemm 4'
+ IF( DEBUG ) WRITE(*,*) '% #', IAM, ': N=',N
+ IF( DEBUG ) WRITE(*,*) '% #', IAM, ': DESCA=',DESCA(1:DLEN_)
+ IF( DEBUG ) WRITE(*,*) '% #', IAM, ': DESCQ=',DESCQ(1:DLEN_)
+ CALL PDGEMM( 'T', 'N', N, N, N, -ONE, MEM(IPQ), 1, 1,
+ $ DESCQ, MEM(IPW1), 1, 1, DESCA, ONE, MEM(IPA), 1, 1,
+ $ DESCA )
+ R1 = PDLANGE( 'Frobenius', N, N, MEM(IPA), 1, 1, DESCA,
+ $ DPDUM )
+ ANORM = PDLANGE( 'Frobenius', N, N, MEM(IPACPY), 1, 1,
+ $ DESCA, DPDUM )
+ IF( ANORM.GT.ZERO )THEN
+ RNORM = R1 / (ANORM*EPS*SQRT(DBLE(N)))
+ ELSE
+ RNORM = R1
+ END IF
+ ELSE
+ RNORM = 0.0D0
+ END IF
+*
+ IF( COMPORTH ) THEN
+ IF( DEBUG ) WRITE(*,*) '% #', IAM, ': Compute residuals 2'
+ CALL PDLASET( 'All', N, N, ZERO, ONE, MEM(IPW1), 1, 1,
+ $ DESCQ )
+ CALL PDLACPY( 'All', N, N, MEM(IPQ), 1, 1, DESCQ, MEM(IPW2),
+ $ 1, 1, DESCQ )
+ CALL PDGEMM( 'T', 'N', N, N, N, -ONE, MEM(IPQ), 1, 1, DESCQ,
+ $ MEM(IPW2), 1, 1, DESCQ, ONE, MEM(IPW1), 1, 1, DESCQ )
+ O1 = PDLANGE( 'Frobenius', N, N, MEM(IPW1), 1, 1, DESCQ,
+ $ DPDUM )
+ CALL PDLASET( 'All', N, N, ZERO, ONE, MEM(IPW1), 1, 1,
+ $ DESCQ )
+ CALL PDGEMM( 'N', 'T', N, N, N, -ONE, MEM(IPQ), 1, 1, DESCQ,
+ $ MEM(IPW2), 1, 1, DESCQ, ONE, MEM(IPW1), 1, 1, DESCQ )
+ O2 = PDLANGE( 'Frobenius', N, N, MEM(IPW1), 1, 1, DESCQ,
+ $ DPDUM )
+ ORTH = MAX(O1,O2) / (EPS*DBLE(N))
+ ELSE
+ ORTH = 0.0D0
+ END IF
+*
+ T_RES = T_RES + MPI_WTIME() - STAMP
+c IF( TIMESTEPS.AND.IAM.EQ.0 ) WRITE(*,*)
+c $ ' %%% Residuals took in seconds:',T_RES
+ TOTTIME = MPI_WTIME() - TOTTIME
+c IF( IAM.EQ.0 ) WRITE(*,*)
+c $ ' %%% Total execution time in seconds:', TOTTIME
+*
+*
+* Print results to screen.
+*
+ IF( (ORTH.GT.THRESH).OR.(RNORM.GT.THRESH) ) THEN
+ PASSED = 'FAILED'
+ ELSE
+ PASSED = 'PASSED'
+ END IF
+ IF( DEBUG ) WRITE(*,*) '% #', IAM, ': Print results...'
+ IF( IAM.EQ.0 ) THEN
+ WRITE( NOUT, FMT = 9993 ) N, NB, NPROW, NPCOL, T_QR, PASSED
+ END IF
+ CALL BLACS_BARRIER( ICTXT, 'All' )
+ END DO
+ END DO
+ END DO
+ 999 CONTINUE
+*
+* Deallocate MEM and IMEM.
+*
+ DEALLOCATE( MEM, IMEM )
+*
+ CALL BLACS_GRIDEXIT( ICTXT )
+*
+ 777 CONTINUE
+*
+ CALL BLACS_EXIT( 0 )
+*
+* Format specifications.
+*
+ 6666 FORMAT(A2,A3,A6,A4,A5,A6,A3,A3,A3,A9,A9,A9,A8,A8,A9,A9,A9,A9,A9,
+ $ A9,A9,A9,A9,A9,A9,A5,A5,A8,A5,A5)
+ 7777 FORMAT(A2,I3,I6,I4,I5,I6,I3,I3,I3,F9.2,F9.2,F9.2,F8.2,F8.2,F9.2,
+ $ F9.2,F9.2,F9.2,F9.2,F9.2,F9.2,F9.2,E9.2,E9.2,E9.2,I5,I5,
+ $ F8.4,I5,I5,A2)
+ 9995 FORMAT( ' N NB P Q QR Time CHECK' )
+ 9994 FORMAT( '----- --- ---- ---- -------- ------' )
+ 9993 FORMAT( I5, 1X, I3, 1X, I4, 1X, I4, 1X, F8.2, 1X, A6 )
+
+*
+ END
diff --git a/TESTING/EIG/pdlasizesepr.f b/TESTING/EIG/pdlasizesepr.f
new file mode 100644
index 0000000..a2b9e63
--- /dev/null
+++ b/TESTING/EIG/pdlasizesepr.f
@@ -0,0 +1,143 @@
+ SUBROUTINE PDLASIZESEPR( DESCA, IPREPAD, IPOSTPAD, SIZEMQRLEFT,
+ $ SIZEMQRRIGHT, SIZEQRF, SIZETMS, SIZEQTQ,
+ $ SIZECHK, SIZESYEVR, ISIZESYEVR,
+ $ SIZESUBTST, ISIZESUBTST, SIZETST,
+ $ ISIZETST )
+*
+* -- ScaLAPACK routine (@(MODE)version *TBA*) --
+* University of California, Berkeley and
+* University of Tennessee, Knoxville.
+* October 21, 2006
+*
+ IMPLICIT NONE
+*
+* .. Scalar Arguments ..
+ INTEGER IPOSTPAD, IPREPAD, ISIZESUBTST, ISIZESYEVR,
+ $ ISIZETST, SIZECHK, SIZEMQRLEFT, SIZEMQRRIGHT,
+ $ SIZEQRF, SIZEQTQ, SIZESUBTST, SIZESYEVR,
+ $ SIZETMS, SIZETST
+* ..
+* .. Array Arguments ..
+ INTEGER DESCA( * )
+*
+* Purpose
+* =======
+*
+* PDLASIZESEPR computes the amount of memory needed by
+* various SEPR test routines, as well as PDSYEVR itself.
+*
+* Arguments
+* =========
+*
+* DESCA (global input) INTEGER array dimension ( DLEN_ )
+* Array descriptor for dense matrix.
+*
+* SIZEMQRLEFT LWORK for the 1st PDORMQR call in PDLAGSY
+*
+* SIZEMQRRIGHT LWORK for the 2nd PDORMQR call in PDLAGSY
+*
+* SIZEQRF LWORK for PDGEQRF in PDLAGSY
+*
+* SIZETMS LWORK for PDLATMS
+*
+* SIZEQTQ LWORK for PDSEPQTQ
+*
+* SIZECHK LWORK for PDSEPCHK
+*
+* SIZESYEVR LWORK for PDSYEVR
+*
+* ISIZESYEVR LIWORK for PDSYEVR
+*
+* SIZESUBTST LWORK for PDSEPRSUBTST
+*
+* ISIZESUBTST LIWORK for PDSEPRSUBTST
+*
+* SIZETST LWORK for PDSEPRTST
+*
+* ISIZETST LIWORK for PDSEPRTST
+*
+*
+* .. Parameters ..
+ INTEGER CTXT_, M_,
+ $ MB_, NB_, RSRC_, CSRC_, LLD_
+ PARAMETER (
+ $ CTXT_ = 2, M_ = 3, MB_ = 5, NB_ = 6,
+ $ RSRC_ = 7, CSRC_ = 8, LLD_ = 9 )
+* ..
+* .. Local Scalars ..
+ INTEGER CSRC_A, IACOL, IAROW, ICOFFA, IROFFA, LCM,
+ $ LCMQ, LDA, MQ0, MYCOL, MYROW, N, NB, NEIG, NN,
+ $ NNP, NP, NP0, NPCOL, NPROW, NQ, RSRC_A
+* ..
+* .. External Functions ..
+ INTEGER ICEIL, ILCM, INDXG2P, NUMROC
+ EXTERNAL ICEIL, ILCM, INDXG2P, NUMROC
+*
+* .. External Subroutines ..
+ EXTERNAL BLACS_GRIDINFO
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX
+* ..
+* .. Executable Statements ..
+*
+ N = DESCA( M_ )
+ NB = DESCA( MB_ )
+ RSRC_A = DESCA( RSRC_ )
+ CSRC_A = DESCA( CSRC_ )
+*
+ LDA = DESCA( LLD_ )
+ CALL BLACS_GRIDINFO( DESCA( CTXT_ ), NPROW, NPCOL, MYROW, MYCOL )
+*
+ LCM = ILCM( NPROW, NPCOL )
+ LCMQ = LCM / NPCOL
+ IROFFA = 0
+ ICOFFA = 0
+ IAROW = INDXG2P( 1, NB, MYROW, RSRC_A, NPROW )
+ IACOL = INDXG2P( 1, NB, MYCOL, CSRC_A, NPCOL )
+ NP = NUMROC( N+IROFFA, NB, MYROW, IAROW, NPROW )
+ NQ = NUMROC( N+ICOFFA, NB, MYCOL, IACOL, NPCOL )
+ SIZEMQRLEFT = MAX( ( NB*( NB-1 ) ) / 2, ( NP+NQ )*NB ) + NB*NB
+ SIZEMQRRIGHT = MAX( ( NB*( NB-1 ) ) / 2,
+ $ ( NQ+MAX( NP+NUMROC( NUMROC( N+ICOFFA, NB, 0, 0,
+ $ NPCOL ), NB, 0, 0, LCMQ ), NP ) )*NB ) + NB*NB
+ SIZEQRF = NB*NP + NB*NQ + NB*NB
+ SIZETMS = ( LDA+1 )*MAX( 1, NQ ) +
+ $ MAX( SIZEMQRLEFT, SIZEMQRRIGHT, SIZEQRF )
+*
+ NP0 = NUMROC( N, DESCA( MB_ ), 0, 0, NPROW )
+ MQ0 = NUMROC( N, DESCA( NB_ ), 0, 0, NPCOL )
+ SIZEQTQ = 2 + MAX( DESCA( MB_ ), 2 )*( 2*NP0+MQ0 )
+ SIZECHK = NUMROC( N, DESCA( NB_ ), MYCOL, 0, NPCOL )
+*
+ NEIG = N
+ NN = MAX( N, NB, 2 ) + 1
+ NP0 = NUMROC( NN, NB, 0, 0, NPROW )
+ MQ0 = NUMROC( MAX( NEIG, NB, 2 ), NB, 0, 0, NPCOL )
+ NNP = MAX( N, NPROW*NPCOL+1, 4 )
+*
+*
+ SIZESYEVR = 1 + 5*N + MAX( 18*NN, NP0*MQ0+2*NB*NB ) +
+ $ (2 + ICEIL( NEIG, NPROW*NPCOL ))*NN
+ SIZESYEVR = MAX(3, SIZESYEVR)
+*
+ ISIZESYEVR = 12*NNP + 2*N
+*
+ SIZESUBTST = MAX( SIZETMS, SIZEQTQ, SIZECHK, SIZESYEVR ) +
+ $ IPREPAD + IPOSTPAD
+ ISIZESUBTST = ISIZESYEVR + IPREPAD + IPOSTPAD
+*
+* Allow room for A, COPYA and Z and DIAG, WIN, WNEW, GAP, WORK
+*
+ SIZETST = 3*( LDA*NP+IPREPAD+IPOSTPAD ) +
+ $ 4*( N+IPREPAD+IPOSTPAD ) + SIZESUBTST
+*
+* Allow room for IFAIL, ICLUSTR, and IWORK
+* (only needed for PDSYEVX)
+*
+ ISIZETST = N + 2*NPROW*NPCOL + 2*( IPREPAD+IPOSTPAD ) +
+ $ ISIZESUBTST
+*
+*
+ RETURN
+ END
diff --git a/TESTING/EIG/pdlasizesyevr.f b/TESTING/EIG/pdlasizesyevr.f
new file mode 100644
index 0000000..252fac1
--- /dev/null
+++ b/TESTING/EIG/pdlasizesyevr.f
@@ -0,0 +1,188 @@
+ SUBROUTINE PDLASIZESYEVR( WKNOWN, RANGE, N, DESCA, VL, VU, IL, IU,
+ $ ISEED, WIN, MAXSIZE, VECSIZE, VALSIZE )
+*
+* -- ScaLAPACK routine (@(MODE)version *TBA*) --
+* University of California, Berkeley and
+* University of Tennessee, Knoxville.
+* October 21, 2006
+*
+ IMPLICIT NONE
+*
+* .. Scalar Arguments ..
+ LOGICAL WKNOWN
+ CHARACTER RANGE
+ INTEGER IL, IU, MAXSIZE, N, VALSIZE, VECSIZE
+ DOUBLE PRECISION VL, VU
+
+* ..
+* .. Array Arguments ..
+ INTEGER DESCA( * ), ISEED( 4 )
+ DOUBLE PRECISION WIN( * )
+* ..
+*
+* Purpose
+* =======
+*
+* PDLASIZESYEVR computes the amount of memory needed by PDSYEVR
+* to ensure:
+* 1) Orthogonal Eigenvectors
+* 2) Eigenpairs with small residual norms
+*
+* Arguments
+* =========
+*
+* WKNOWN (global input) INTEGER
+* .FALSE.: WIN does not contain the eigenvalues
+* .TRUE.: WIN does contain the eigenvalues
+*
+* RANGE (global input) CHARACTER*1
+* = 'A': all eigenvalues will be found.
+* = 'V': all eigenvalues in the interval [VL,VU]
+* will be found.
+* = 'I': the IL-th through IU-th eigenvalues will be found.
+*
+* N (global input) INTEGER
+* Size of the matrix to be tested. (global size)
+*
+* DESCA (global input) INTEGER array dimension ( DLEN_ )
+*
+* VL (global input/output ) DOUBLE PRECISION
+* If RANGE='V', the lower bound of the interval to be searched
+* for eigenvalues. Not referenced if RANGE = 'A' or 'I'.
+* If VL > VU, RANGE='V' and WKNOWN = .TRUE., VL is set
+* to a random value near an entry in WIN
+*
+* VU (global input/output ) DOUBLE PRECISION
+* If RANGE='V', the upper bound of the interval to be searched
+* for eigenvalues. Not referenced if RANGE = 'A' or 'I'.
+* If VL > VU, RANGE='V' and WKNOWN = .TRUE., VU is set
+* to a random value near an entry in WIN
+*
+* IL (global input/output ) INTEGER
+* If RANGE='I', the index (from smallest to largest) of the
+* smallest eigenvalue to be returned. IL >= 1.
+* Not referenced if RANGE = 'A' or 'V'.
+* If IL < 0, RANGE='I' and WKNOWN = .TRUE., IL is set
+* to a random value from 1 to N
+*
+* IU (global input/output ) INTEGER
+* If RANGE='I', the index (from smallest to largest) of the
+* largest eigenvalue to be returned. min(IL,N) <= IU <= N.
+* Not referenced if RANGE = 'A' or 'V'.
+* If IU < 0, RANGE='I' and WKNOWN = .TRUE., IU is set
+* to a random value from IL to N
+*
+* ISEED (global input/output) INTEGER array, dimension (4)
+* On entry, the seed of the random number generator; the array
+* elements must be between 0 and 4095, and ISEED(4) must be
+* odd.
+* On exit, the seed is updated.
+* ISEED is not touched unless IL, IU, VL or VU are modified.
+*
+* WIN (global input) DOUBLE PRECISION array, dimension (N)
+* If WKNOWN=1, WIN contains the eigenvalues of the matrix.
+*
+* MAXSIZE (global output) INTEGER
+* Workspace required to guarantee that PDSYEVR will return
+* orthogonal eigenvectors. IF WKNOWN=0, MAXSIZE is set to a
+* a value which guarantees orthogonality no matter what the
+* spectrum is. If WKNOWN=1, MAXSIZE is set to a value which
+* guarantees orthogonality on a matrix with eigenvalues given
+* by WIN.
+*
+* VECSIZE (global output) INTEGER
+* Workspace required to guarantee that PDSYEVR
+* will compute eigenvectors.
+*
+* VALSIZE (global output) INTEGER
+* Workspace required to guarantee that PDSYEVR
+* will compute eigenvalues.
+*
+*
+* .. Parameters ..
+ INTEGER CTXT_, MB_
+ PARAMETER ( CTXT_ = 2, MB_ = 5 )
+ DOUBLE PRECISION TWENTY
+ PARAMETER ( TWENTY = 20.0D0 )
+* ..
+* .. Local Scalars ..
+*
+ INTEGER ILMIN, IUMAX,
+ $ MQ0, MYCOL, MYIL, MYIU, MYROW, NB, NEIG, NN,
+ $ NP0, NPCOL, NPROW
+ DOUBLE PRECISION ANORM, EPS, SAFMIN
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ INTEGER ICEIL, NUMROC
+ DOUBLE PRECISION DLARAN, PDLAMCH
+ EXTERNAL LSAME, ICEIL, NUMROC, DLARAN, PDLAMCH
+* ..
+* .. External Subroutines ..
+ EXTERNAL BLACS_GRIDINFO
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, DBLE, INT, MAX
+
+* ..
+* .. Executable Statements ..
+*
+ CALL BLACS_GRIDINFO( DESCA( CTXT_ ), NPROW, NPCOL, MYROW, MYCOL )
+ EPS = PDLAMCH( DESCA( CTXT_ ), 'Precision' )
+ SAFMIN = PDLAMCH( DESCA( CTXT_ ), 'Safe Minimum' )
+ NB = DESCA( MB_ )
+ NN = MAX( N, NB, 2 )
+ NP0 = NUMROC( NN, NB, 0, 0, NPROW )
+
+ VALSIZE = 3 + 5*N + MAX( 12*NN, NB*( NP0+1 ) )
+
+ IF( WKNOWN ) THEN
+ ANORM = SAFMIN / EPS
+ IF( N.GE.1 )
+ $ ANORM = MAX( ABS( WIN( 1 ) ), ABS( WIN( N ) ), ANORM )
+ IF( LSAME( RANGE, 'I' ) ) THEN
+ IF( IL.LT.0 )
+ $ IL = INT( DLARAN( ISEED )*DBLE( N ) ) + 1
+ IF( IU.LT.0 )
+ $ IU = INT( DLARAN( ISEED )*DBLE( N-IL ) ) + IL
+ IF( N.EQ.0 )
+ $ IU = 0
+ ELSE IF( LSAME( RANGE, 'V' ) ) THEN
+ IF( VL.GT.VU ) THEN
+ MYIL = INT( DLARAN( ISEED )*DBLE( N ) ) + 1
+ MYIU = INT( DLARAN( ISEED )*DBLE( N-MYIL ) ) + MYIL
+ VL = WIN( MYIL ) - TWENTY*EPS*ABS( WIN( MYIL ) )
+ VU = WIN( MYIU ) + TWENTY*EPS*ABS( WIN( MYIU ) )
+ VU = MAX( VU, VL+EPS*TWENTY*ABS( VL )+SAFMIN )
+ END IF
+ END IF
+*
+ END IF
+ IF( LSAME( RANGE, 'V' ) ) THEN
+* We do not know how many eigenvalues will be computed
+ ILMIN = 1
+ IUMAX = N
+ ELSE IF( LSAME( RANGE, 'I' ) ) THEN
+ ILMIN = IL
+ IUMAX = IU
+ ELSE IF( LSAME( RANGE, 'A' ) ) THEN
+ ILMIN = 1
+ IUMAX = N
+ END IF
+*
+ NEIG = IUMAX - ILMIN + 1
+*
+ MQ0 = NUMROC( MAX( NEIG, NB, 2 ), NB, 0, 0, NPCOL )
+*
+ VECSIZE = 3 + 5*N + MAX( 18*NN, NP0*MQ0+2*NB*NB ) +
+ $ (2 + ICEIL( NEIG, NPROW*NPCOL ))*NN
+
+ VALSIZE = MAX(3, VALSIZE)
+ VECSIZE = MAX(3, VECSIZE)
+ MAXSIZE = VECSIZE
+*
+ RETURN
+*
+* End of PDLASIZESYEVR
+*
+ END
diff --git a/TESTING/EIG/pdmatgen2.f b/TESTING/EIG/pdmatgen2.f
new file mode 100644
index 0000000..4fe4b16
--- /dev/null
+++ b/TESTING/EIG/pdmatgen2.f
@@ -0,0 +1,702 @@
+ SUBROUTINE PDMATGEN2( ICTXT, AFORM, DIAG, M, N, MB, NB, A, LDA,
+ $ IAROW, IACOL, ISEED, IROFF, IRNUM, ICOFF,
+ $ ICNUM, MYROW, MYCOL, NPROW, NPCOL )
+*
+*
+* Modified version by K. L. Dackland (U added)
+* Modified version by Peter Poromaa, Heavy DIAG
+* Modified version by Robert Granat, R(andom) added
+*
+* .. Scalar Arguments ..
+ CHARACTER*1 AFORM, DIAG
+ INTEGER IACOL, IAROW, ICNUM, ICOFF, ICTXT, IRNUM,
+ $ IROFF, ISEED, LDA, M, MB, MYCOL, MYROW, N,
+ $ NB, NPCOL, NPROW
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION A( LDA, * )
+* ..
+*
+* Purpose
+* =======
+*
+* PDMATGEN2 : Parallel Real Double precision MATrix GENerator.
+* Generate (or regenerate) a distributed matrix A (or sub-matrix of A).
+*
+* Arguments
+* =========
+*
+* ICTXT (global input) INTEGER
+* The BLACS context handle, indicating the global context of
+* the operation. The context itself is global.
+*
+* AFORM (global input) CHARACTER*1
+* if AFORM = 'U' : A returned is an Upper triangular matrix.
+* if AFORM = 'S' : A is returned is a symmetric matrix.
+* if AFORM = 'H' : A is returned is a Hermitian matrix.
+* if AFORM = 'T' : A is overwritten with the transpose of
+* what would normally be generated.
+* if AFORM = 'C' : A is overwritten with the conjugate trans-
+* pose of what would normally be generated.
+* if AFORM = 'R' A random matrix is generated.
+*
+* DIAG (global input) CHARACTER*1
+* if DIAG = 'D' : A is diagonally dominant.
+*
+* M (global input) INTEGER
+* The number of rows in the generated distributed matrix.
+*
+* N (global input) INTEGER
+* The number of columns in the generated distributed
+* matrix.
+*
+* MB (global input) INTEGER
+* The row blocking factor of the distributed matrix A.
+*
+* NB (global input) INTEGER
+* The column blocking factor of the distributed matrix A.
+*
+* A (local output) DOUBLE PRECISION, pointer into the local
+* memory to an array of dimension ( LDA, * ) containing the
+* local pieces of the distributed matrix.
+*
+* LDA (local input) INTEGER
+* The leading dimension of the array containing the local
+* pieces of the distributed matrix A.
+*
+* IAROW (global input) INTEGER
+* The row processor coordinate which holds the first block
+* of the distributed matrix A.
+*
+* IACOL (global input) INTEGER
+* The column processor coordinate which holds the first
+* block of the distributed matrix A.
+*
+* ISEED (global input) INTEGER
+* The seed number to generate the distributed matrix A.
+*
+* IROFF (local input) INTEGER
+* The number of local rows of A that have already been
+* generated. It should be a multiple of MB.
+*
+* IRNUM (local input) INTEGER
+* The number of local rows to be generated.
+*
+* ICOFF (local input) INTEGER
+* The number of local columns of A that have already been
+* generated. It should be a multiple of NB.
+*
+* ICNUM (local input) INTEGER
+* The number of local columns to be generated.
+*
+* MYROW (local input) INTEGER
+* The row process coordinate of the calling process.
+*
+* MYCOL (local input) INTEGER
+* The column process coordinate of the calling process.
+*
+* NPROW (global input) INTEGER
+* The number of process rows in the grid.
+*
+* NPCOL (global input) INTEGER
+* The number of process columns in the grid.
+*
+* Notes
+* =====
+*
+* The code is originally developed by David Walker, ORNL,
+* and modified by Jaeyoung Choi, ORNL.
+*
+* Reference: G. Fox et al.
+* Section 12.3 of "Solving problems on concurrent processors Vol. I"
+*
+* =====================================================================
+*
+* .. Parameters ..
+ INTEGER MULT0, MULT1, IADD0, IADD1
+ PARAMETER ( MULT0=20077, MULT1=16838, IADD0=12345,
+ $ IADD1=0 )
+ DOUBLE PRECISION ONE, TWO, ZERO
+ PARAMETER ( ONE = 1.0D+0, TWO = 2.0D+0, ZERO = 0.0D+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL SYMM, HERM, TRAN, UPPR, RANDOM
+ INTEGER I, IC, IK, INFO, IOFFC, IOFFR, IR, J, JK,
+ $ JUMP1, JUMP2, JUMP3, JUMP4, JUMP5, JUMP6,
+ $ JUMP7, MAXMN, MEND, MOFF, MP, MRCOL, MRROW,
+ $ NEND, NOFF, NPMB, NQ, NQNB
+* ..
+* .. Local Arrays ..
+ INTEGER IADD(2), IA1(2), IA2(2), IA3(2), IA4(2),
+ $ IA5(2), IB1(2), IB2(2), IB3(2), IC1(2), IC2(2),
+ $ IC3(2), IC4(2), IC5(2), IRAN1(2), IRAN2(2),
+ $ IRAN3(2), IRAN4(2), ITMP1(2), ITMP2(2),
+ $ ITMP3(2), JSEED(2), MULT(2)
+* ..
+* .. External Subroutines ..
+ EXTERNAL JUMPIT, PXERBLA, SETRAN, XJUMPM
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX, MOD
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ INTEGER ICEIL, NUMROC
+ DOUBLE PRECISION PDRAND
+ EXTERNAL ICEIL, NUMROC, LSAME, PDRAND
+* ..
+* .. Executable Statements ..
+*
+* Test the input arguments
+*
+ MP = NUMROC( M, MB, MYROW, IAROW, NPROW )
+ NQ = NUMROC( N, NB, MYCOL, IACOL, NPCOL )
+ SYMM = LSAME( AFORM, 'S' )
+ UPPR = LSAME( AFORM, 'U' )
+ HERM = LSAME( AFORM, 'H' )
+ TRAN = LSAME( AFORM, 'T' )
+ RANDOM = LSAME( AFORM, 'R' )
+*
+ INFO = 0
+ IF( .NOT.( UPPR.OR.SYMM.OR.HERM.OR.TRAN.OR.RANDOM ) .AND.
+ $ .NOT.LSAME( AFORM, 'C' ) .AND.
+ $ .NOT.LSAME( AFORM, 'N' ) ) THEN
+ INFO = 2
+ ELSE IF( .NOT.LSAME( DIAG, 'D' ) .AND.
+ $ .NOT.LSAME( DIAG, 'N' ) ) THEN
+ INFO = 3
+ ELSE IF( UPPR.OR.SYMM.OR.HERM ) THEN
+ IF( M.NE.N ) THEN
+ INFO = 5
+ ELSE IF( MB.NE.NB ) THEN
+ INFO = 7
+ END IF
+ ELSE IF( M.LT.0 ) THEN
+ INFO = 4
+ ELSE IF( N.LT.0 ) THEN
+ INFO = 5
+ ELSE IF( MB.LT.1 ) THEN
+ INFO = 6
+ ELSE IF( NB.LT.1 ) THEN
+ INFO = 7
+ ELSE IF( LDA.LT.0 ) THEN
+ INFO = 9
+ ELSE IF( ( IAROW.LT.0 ).OR.( IAROW.GE.NPROW ) ) THEN
+ INFO = 10
+ ELSE IF( ( IACOL.LT.0 ).OR.( IACOL.GE.NPCOL ) ) THEN
+ INFO = 11
+ ELSE IF( MOD(IROFF,MB).GT.0 ) THEN
+ INFO = 13
+ ELSE IF( IRNUM.GT.(MP-IROFF) ) THEN
+ INFO = 14
+ ELSE IF( MOD(ICOFF,NB).GT.0 ) THEN
+ INFO = 15
+ ELSE IF( ICNUM.GT.(NQ-ICOFF) ) THEN
+ INFO = 16
+ ELSE IF( ( MYROW.LT.0 ).OR.( MYROW.GE.NPROW ) ) THEN
+ INFO = 17
+ ELSE IF( ( MYCOL.LT.0 ).OR.( MYCOL.GE.NPCOL ) ) THEN
+ INFO = 18
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL PXERBLA( ICTXT, 'PDMATGEN2', INFO )
+ RETURN
+ END IF
+ MRROW = MOD( NPROW+MYROW-IAROW, NPROW )
+ MRCOL = MOD( NPCOL+MYCOL-IACOL, NPCOL )
+ NPMB = NPROW * MB
+ NQNB = NPCOL * NB
+ MOFF = IROFF / MB
+ NOFF = ICOFF / NB
+ MEND = ICEIL(IRNUM, MB) + MOFF
+ NEND = ICEIL(ICNUM, NB) + NOFF
+*
+ MULT(1) = MULT0
+ MULT(2) = MULT1
+ IADD(1) = IADD0
+ IADD(2) = IADD1
+ JSEED(1) = ISEED
+ JSEED(2) = 0
+*
+* Symmetric or Hermitian matrix will be generated.
+*
+ IF( SYMM.OR.HERM ) THEN
+*
+* First, generate the lower triangular part (with diagonal block)
+*
+ JUMP1 = 1
+ JUMP2 = NPMB
+ JUMP3 = M
+ JUMP4 = NQNB
+ JUMP5 = NB
+ JUMP6 = MRCOL
+ JUMP7 = MB*MRROW
+*
+ CALL XJUMPM( JUMP1, MULT, IADD, JSEED, IRAN1, IA1, IC1 )
+ CALL XJUMPM( JUMP2, MULT, IADD, IRAN1, ITMP1, IA2, IC2 )
+ CALL XJUMPM( JUMP3, MULT, IADD, IRAN1, ITMP1, IA3, IC3 )
+ CALL XJUMPM( JUMP4, IA3, IC3, IRAN1, ITMP1, IA4, IC4 )
+ CALL XJUMPM( JUMP5, IA3, IC3, IRAN1, ITMP1, IA5, IC5 )
+ CALL XJUMPM( JUMP6, IA5, IC5, IRAN1, ITMP3, ITMP1, ITMP2 )
+ CALL XJUMPM( JUMP7, MULT, IADD, ITMP3, IRAN1, ITMP1, ITMP2 )
+ CALL XJUMPM( NOFF, IA4, IC4, IRAN1, ITMP1, ITMP2, ITMP3 )
+ CALL XJUMPM( MOFF, IA2, IC2, ITMP1, IRAN1, ITMP2, ITMP3 )
+ CALL SETRAN( IRAN1, IA1, IC1 )
+*
+ DO 10 I = 1, 2
+ IB1(I) = IRAN1(I)
+ IB2(I) = IRAN1(I)
+ IB3(I) = IRAN1(I)
+ 10 CONTINUE
+*
+ JK = 1
+ DO 80 IC = NOFF+1, NEND
+ IOFFC = ((IC-1)*NPCOL+MRCOL) * NB
+ DO 70 I = 1, NB
+ IF( JK .GT. ICNUM ) GO TO 90
+*
+ IK = 1
+ DO 50 IR = MOFF+1, MEND
+ IOFFR = ((IR-1)*NPROW+MRROW) * MB
+*
+ IF( IOFFR .GT. IOFFC ) THEN
+ DO 20 J = 1, MB
+ IF( IK .GT. IRNUM ) GO TO 60
+ A(IK,JK) = ONE - TWO*PDRAND(0)
+ IK = IK + 1
+ 20 CONTINUE
+*
+ ELSE IF( IOFFC .EQ. IOFFR ) THEN
+ IK = IK + I - 1
+ IF( IK .GT. IRNUM ) GO TO 60
+ DO 30 J = 1, I-1
+ A(IK,JK) = ONE - TWO*PDRAND(0)
+ 30 CONTINUE
+ A(IK,JK) = ONE - TWO*PDRAND(0)
+ DO 40 J = 1, MB-I
+ IF( IK+J .GT. IRNUM ) GO TO 60
+ A(IK+J,JK) = ONE - TWO*PDRAND(0)
+ A(IK,JK+J) = A(IK+J,JK)
+ 40 CONTINUE
+ IK = IK + MB - I + 1
+ ELSE
+ IK = IK + MB
+ END IF
+*
+ CALL JUMPIT( IA2, IC2, IB1, IRAN2 )
+ IB1(1) = IRAN2(1)
+ IB1(2) = IRAN2(2)
+ 50 CONTINUE
+*
+ 60 CONTINUE
+ JK = JK + 1
+ CALL JUMPIT( IA3, IC3, IB2, IRAN3 )
+ IB1(1) = IRAN3(1)
+ IB1(2) = IRAN3(2)
+ IB2(1) = IRAN3(1)
+ IB2(2) = IRAN3(2)
+ 70 CONTINUE
+*
+ CALL JUMPIT( IA4, IC4, IB3, IRAN4 )
+ IB1(1) = IRAN4(1)
+ IB1(2) = IRAN4(2)
+ IB2(1) = IRAN4(1)
+ IB2(2) = IRAN4(2)
+ IB3(1) = IRAN4(1)
+ IB3(2) = IRAN4(2)
+ 80 CONTINUE
+*
+* Next, generate the upper triangular part.
+*
+ 90 CONTINUE
+ MULT(1) = MULT0
+ MULT(2) = MULT1
+ IADD(1) = IADD0
+ IADD(2) = IADD1
+ JSEED(1) = ISEED
+ JSEED(2) = 0
+*
+ JUMP1 = 1
+ JUMP2 = NQNB
+ JUMP3 = N
+ JUMP4 = NPMB
+ JUMP5 = MB
+ JUMP6 = MRROW
+ JUMP7 = NB*MRCOL
+*
+ CALL XJUMPM( JUMP1, MULT, IADD, JSEED, IRAN1, IA1, IC1 )
+ CALL XJUMPM( JUMP2, MULT, IADD, IRAN1, ITMP1, IA2, IC2 )
+ CALL XJUMPM( JUMP3, MULT, IADD, IRAN1, ITMP1, IA3, IC3 )
+ CALL XJUMPM( JUMP4, IA3, IC3, IRAN1, ITMP1, IA4, IC4 )
+ CALL XJUMPM( JUMP5, IA3, IC3, IRAN1, ITMP1, IA5, IC5 )
+ CALL XJUMPM( JUMP6, IA5, IC5, IRAN1, ITMP3, ITMP1, ITMP2 )
+ CALL XJUMPM( JUMP7, MULT, IADD, ITMP3, IRAN1, ITMP1, ITMP2 )
+ CALL XJUMPM( MOFF, IA4, IC4, IRAN1, ITMP1, ITMP2, ITMP3 )
+ CALL XJUMPM( NOFF, IA2, IC2, ITMP1, IRAN1, ITMP2, ITMP3 )
+ CALL SETRAN( IRAN1, IA1, IC1 )
+*
+ DO 100 I = 1, 2
+ IB1(I) = IRAN1(I)
+ IB2(I) = IRAN1(I)
+ IB3(I) = IRAN1(I)
+ 100 CONTINUE
+*
+ IK = 1
+ DO 150 IR = MOFF+1, MEND
+ IOFFR = ((IR-1)*NPROW+MRROW) * MB
+ DO 140 J = 1, MB
+ IF( IK .GT. IRNUM ) GO TO 160
+ JK = 1
+ DO 120 IC = NOFF+1, NEND
+ IOFFC = ((IC-1)*NPCOL+MRCOL) * NB
+ IF( IOFFC .GT. IOFFR ) THEN
+ DO 110 I = 1, NB
+ IF( JK .GT. ICNUM ) GO TO 130
+ A(IK,JK) = ONE - TWO*PDRAND(0)
+ JK = JK + 1
+ 110 CONTINUE
+ ELSE
+ JK = JK + NB
+ END IF
+ CALL JUMPIT( IA2, IC2, IB1, IRAN2 )
+ IB1(1) = IRAN2(1)
+ IB1(2) = IRAN2(2)
+ 120 CONTINUE
+*
+ 130 CONTINUE
+ IK = IK + 1
+ CALL JUMPIT( IA3, IC3, IB2, IRAN3 )
+ IB1(1) = IRAN3(1)
+ IB1(2) = IRAN3(2)
+ IB2(1) = IRAN3(1)
+ IB2(2) = IRAN3(2)
+ 140 CONTINUE
+*
+ CALL JUMPIT( IA4, IC4, IB3, IRAN4 )
+ IB1(1) = IRAN4(1)
+ IB1(2) = IRAN4(2)
+ IB2(1) = IRAN4(1)
+ IB2(2) = IRAN4(2)
+ IB3(1) = IRAN4(1)
+ IB3(2) = IRAN4(2)
+ 150 CONTINUE
+ 160 CONTINUE
+*
+* Generate an upper triangular matrix.
+*
+ ELSE IF ( UPPR ) THEN
+ JUMP1 = 1
+ JUMP2 = NPMB
+ JUMP3 = M
+ JUMP4 = NQNB
+ JUMP5 = NB
+ JUMP6 = MRCOL
+ JUMP7 = MB*MRROW
+*
+ CALL XJUMPM( JUMP1, MULT, IADD, JSEED, IRAN1, IA1, IC1 )
+ CALL XJUMPM( JUMP2, MULT, IADD, IRAN1, ITMP1, IA2, IC2 )
+ CALL XJUMPM( JUMP3, MULT, IADD, IRAN1, ITMP1, IA3, IC3 )
+ CALL XJUMPM( JUMP4, IA3, IC3, IRAN1, ITMP1, IA4, IC4 )
+ CALL XJUMPM( JUMP5, IA3, IC3, IRAN1, ITMP1, IA5, IC5 )
+ CALL XJUMPM( JUMP6, IA5, IC5, IRAN1, ITMP3, ITMP1, ITMP2 )
+ CALL XJUMPM( JUMP7, MULT, IADD, ITMP3, IRAN1, ITMP1, ITMP2 )
+ CALL XJUMPM( NOFF, IA4, IC4, IRAN1, ITMP1, ITMP2, ITMP3 )
+ CALL XJUMPM( MOFF, IA2, IC2, ITMP1, IRAN1, ITMP2, ITMP3 )
+ CALL SETRAN( IRAN1, IA1, IC1 )
+*
+ DO 1000 I = 1, 2
+ IB1(I) = IRAN1(I)
+ IB2(I) = IRAN1(I)
+ IB3(I) = IRAN1(I)
+ 1000 CONTINUE
+*
+ JK = 1
+ DO 8000 IC = NOFF+1, NEND
+ IOFFC = ((IC-1)*NPCOL+MRCOL) * NB
+ DO 7000 I = 1, NB
+ IF( JK .GT. ICNUM ) GO TO 8000
+*
+ IK = 1
+ DO 5000 IR = MOFF+1, MEND
+ IOFFR = ((IR-1)*NPROW+MRROW) * MB
+*
+ IF( IOFFC .EQ. IOFFR ) THEN
+ IK = IK + I - 1
+ IF( IK .GT. IRNUM ) GO TO 6000
+ DO 3000 J = 1, I-1
+ A(IK,JK) = ONE - TWO*PDRAND(0)
+ 3000 CONTINUE
+ A(IK,JK) = ONE - TWO*PDRAND(0)
+ DO 4000 J = 1, MB-I
+ IF( IK+J .GT. IRNUM ) GO TO 6000
+ A(IK,JK+J) = ONE - TWO*PDRAND(0)
+ 4000 CONTINUE
+ IK = IK + MB - I + 1
+ ELSE
+ IK = IK + MB
+ END IF
+*
+ CALL JUMPIT( IA2, IC2, IB1, IRAN2 )
+ IB1(1) = IRAN2(1)
+ IB1(2) = IRAN2(2)
+ 5000 CONTINUE
+*
+ 6000 CONTINUE
+ JK = JK + 1
+ CALL JUMPIT( IA3, IC3, IB2, IRAN3 )
+ IB1(1) = IRAN3(1)
+ IB1(2) = IRAN3(2)
+ IB2(1) = IRAN3(1)
+ IB2(2) = IRAN3(2)
+ 7000 CONTINUE
+*
+ CALL JUMPIT( IA4, IC4, IB3, IRAN4 )
+ IB1(1) = IRAN4(1)
+ IB1(2) = IRAN4(2)
+ IB2(1) = IRAN4(1)
+ IB2(2) = IRAN4(2)
+ IB3(1) = IRAN4(1)
+ IB3(2) = IRAN4(2)
+ 8000 CONTINUE
+ MULT(1) = MULT0
+ MULT(2) = MULT1
+ IADD(1) = IADD0
+ IADD(2) = IADD1
+ JSEED(1) = ISEED
+ JSEED(2) = 0
+*
+ JUMP1 = 1
+ JUMP2 = NQNB
+ JUMP3 = N
+ JUMP4 = NPMB
+ JUMP5 = MB
+ JUMP6 = MRROW
+ JUMP7 = NB*MRCOL
+*
+ CALL XJUMPM( JUMP1, MULT, IADD, JSEED, IRAN1, IA1, IC1 )
+ CALL XJUMPM( JUMP2, MULT, IADD, IRAN1, ITMP1, IA2, IC2 )
+ CALL XJUMPM( JUMP3, MULT, IADD, IRAN1, ITMP1, IA3, IC3 )
+ CALL XJUMPM( JUMP4, IA3, IC3, IRAN1, ITMP1, IA4, IC4 )
+ CALL XJUMPM( JUMP5, IA3, IC3, IRAN1, ITMP1, IA5, IC5 )
+ CALL XJUMPM( JUMP6, IA5, IC5, IRAN1, ITMP3, ITMP1, ITMP2 )
+ CALL XJUMPM( JUMP7, MULT, IADD, ITMP3, IRAN1, ITMP1, ITMP2 )
+ CALL XJUMPM( MOFF, IA4, IC4, IRAN1, ITMP1, ITMP2, ITMP3 )
+ CALL XJUMPM( NOFF, IA2, IC2, ITMP1, IRAN1, ITMP2, ITMP3 )
+ CALL SETRAN( IRAN1, IA1, IC1 )
+*
+ DO 1110 I = 1, 2
+ IB1(I) = IRAN1(I)
+ IB2(I) = IRAN1(I)
+ IB3(I) = IRAN1(I)
+ 1110 CONTINUE
+*
+ IK = 1
+ DO 1500 IR = MOFF+1, MEND
+ IOFFR = ((IR-1)*NPROW+MRROW) * MB
+ DO 1400 J = 1, MB
+ IF( IK .GT. IRNUM ) GO TO 1600
+ JK = 1
+ DO 1200 IC = NOFF+1, NEND
+ IOFFC = ((IC-1)*NPCOL+MRCOL) * NB
+ IF( IOFFC .GT. IOFFR ) THEN
+ DO 1100 I = 1, NB
+ IF( JK .GT. ICNUM ) GO TO 1300
+ A(IK,JK) = ONE - TWO*PDRAND(0)
+ JK = JK + 1
+ 1100 CONTINUE
+ ELSE
+ JK = JK + NB
+ END IF
+ CALL JUMPIT( IA2, IC2, IB1, IRAN2 )
+ IB1(1) = IRAN2(1)
+ IB1(2) = IRAN2(2)
+ 1200 CONTINUE
+*
+ 1300 CONTINUE
+ IK = IK + 1
+ CALL JUMPIT( IA3, IC3, IB2, IRAN3 )
+ IB1(1) = IRAN3(1)
+ IB1(2) = IRAN3(2)
+ IB2(1) = IRAN3(1)
+ IB2(2) = IRAN3(2)
+ 1400 CONTINUE
+*
+ CALL JUMPIT( IA4, IC4, IB3, IRAN4 )
+ IB1(1) = IRAN4(1)
+ IB1(2) = IRAN4(2)
+ IB2(1) = IRAN4(1)
+ IB2(2) = IRAN4(2)
+ IB3(1) = IRAN4(1)
+ IB3(2) = IRAN4(2)
+ 1500 CONTINUE
+ 1600 CONTINUE
+*
+* (Conjugate) Transposed matrix A will be generated.
+*
+ ELSE IF( TRAN .OR. LSAME( AFORM, 'C' ) ) THEN
+*
+ JUMP1 = 1
+ JUMP2 = NQNB
+ JUMP3 = N
+ JUMP4 = NPMB
+ JUMP5 = MB
+ JUMP6 = MRROW
+ JUMP7 = NB*MRCOL
+*
+ CALL XJUMPM( JUMP1, MULT, IADD, JSEED, IRAN1, IA1, IC1 )
+ CALL XJUMPM( JUMP2, MULT, IADD, IRAN1, ITMP1, IA2, IC2 )
+ CALL XJUMPM( JUMP3, MULT, IADD, IRAN1, ITMP1, IA3, IC3 )
+ CALL XJUMPM( JUMP4, IA3, IC3, IRAN1, ITMP1, IA4, IC4 )
+ CALL XJUMPM( JUMP5, IA3, IC3, IRAN1, ITMP1, IA5, IC5 )
+ CALL XJUMPM( JUMP6, IA5, IC5, IRAN1, ITMP3, ITMP1, ITMP2 )
+ CALL XJUMPM( JUMP7, MULT, IADD, ITMP3, IRAN1, ITMP1, ITMP2 )
+ CALL XJUMPM( MOFF, IA4, IC4, IRAN1, ITMP1, ITMP2, ITMP3 )
+ CALL XJUMPM( NOFF, IA2, IC2, ITMP1, IRAN1, ITMP2, ITMP3 )
+ CALL SETRAN( IRAN1, IA1, IC1 )
+*
+ DO 170 I = 1, 2
+ IB1(I) = IRAN1(I)
+ IB2(I) = IRAN1(I)
+ IB3(I) = IRAN1(I)
+ 170 CONTINUE
+*
+ IK = 1
+ DO 220 IR = MOFF+1, MEND
+ IOFFR = ((IR-1)*NPROW+MRROW) * MB
+ DO 210 J = 1, MB
+ IF( IK .GT. IRNUM ) GO TO 230
+ JK = 1
+ DO 190 IC = NOFF+1, NEND
+ IOFFC = ((IC-1)*NPCOL+MRCOL) * NB
+ DO 180 I = 1, NB
+ IF( JK .GT. ICNUM ) GO TO 200
+ A(IK,JK) = ONE - TWO*PDRAND(0)
+ JK = JK + 1
+ 180 CONTINUE
+ CALL JUMPIT( IA2, IC2, IB1, IRAN2 )
+ IB1(1) = IRAN2(1)
+ IB1(2) = IRAN2(2)
+ 190 CONTINUE
+*
+ 200 CONTINUE
+ IK = IK + 1
+ CALL JUMPIT( IA3, IC3, IB2, IRAN3 )
+ IB1(1) = IRAN3(1)
+ IB1(2) = IRAN3(2)
+ IB2(1) = IRAN3(1)
+ IB2(2) = IRAN3(2)
+ 210 CONTINUE
+*
+ CALL JUMPIT( IA4, IC4, IB3, IRAN4 )
+ IB1(1) = IRAN4(1)
+ IB1(2) = IRAN4(2)
+ IB2(1) = IRAN4(1)
+ IB2(2) = IRAN4(2)
+ IB3(1) = IRAN4(1)
+ IB3(2) = IRAN4(2)
+ 220 CONTINUE
+ 230 CONTINUE
+*
+* A random matrix is generated.
+*
+ ELSEIF( RANDOM ) THEN
+*
+ JUMP1 = 1
+ JUMP2 = NPMB
+ JUMP3 = M
+ JUMP4 = NQNB
+ JUMP5 = NB
+ JUMP6 = MRCOL
+ JUMP7 = MB*MRROW
+*
+ CALL XJUMPM( JUMP1, MULT, IADD, JSEED, IRAN1, IA1, IC1 )
+ CALL XJUMPM( JUMP2, MULT, IADD, IRAN1, ITMP1, IA2, IC2 )
+ CALL XJUMPM( JUMP3, MULT, IADD, IRAN1, ITMP1, IA3, IC3 )
+ CALL XJUMPM( JUMP4, IA3, IC3, IRAN1, ITMP1, IA4, IC4 )
+ CALL XJUMPM( JUMP5, IA3, IC3, IRAN1, ITMP1, IA5, IC5 )
+ CALL XJUMPM( JUMP6, IA5, IC5, IRAN1, ITMP3, ITMP1, ITMP2 )
+ CALL XJUMPM( JUMP7, MULT, IADD, ITMP3, IRAN1, ITMP1, ITMP2 )
+ CALL XJUMPM( NOFF, IA4, IC4, IRAN1, ITMP1, ITMP2, ITMP3 )
+ CALL XJUMPM( MOFF, IA2, IC2, ITMP1, IRAN1, ITMP2, ITMP3 )
+ CALL SETRAN( IRAN1, IA1, IC1 )
+*
+ DO 240 I = 1, 2
+ IB1(I) = IRAN1(I)
+ IB2(I) = IRAN1(I)
+ IB3(I) = IRAN1(I)
+ 240 CONTINUE
+*
+ JK = 1
+ DO 290 IC = NOFF+1, NEND
+ IOFFC = ((IC-1)*NPCOL+MRCOL) * NB
+ DO 280 I = 1, NB
+ IF( JK .GT. ICNUM ) GO TO 300
+ IK = 1
+ DO 260 IR = MOFF+1, MEND
+ IOFFR = ((IR-1)*NPROW+MRROW) * MB
+ DO 250 J = 1, MB
+ IF( IK .GT. IRNUM ) GO TO 270
+ A(IK,JK) = ONE - TWO*PDRAND(0)
+ IK = IK + 1
+ 250 CONTINUE
+ CALL JUMPIT( IA2, IC2, IB1, IRAN2 )
+ IB1(1) = IRAN2(1)
+ IB1(2) = IRAN2(2)
+ 260 CONTINUE
+*
+ 270 CONTINUE
+ JK = JK + 1
+ CALL JUMPIT( IA3, IC3, IB2, IRAN3 )
+ IB1(1) = IRAN3(1)
+ IB1(2) = IRAN3(2)
+ IB2(1) = IRAN3(1)
+ IB2(2) = IRAN3(2)
+ 280 CONTINUE
+*
+ CALL JUMPIT( IA4, IC4, IB3, IRAN4 )
+ IB1(1) = IRAN4(1)
+ IB1(2) = IRAN4(2)
+ IB2(1) = IRAN4(1)
+ IB2(2) = IRAN4(2)
+ IB3(1) = IRAN4(1)
+ IB3(2) = IRAN4(2)
+ 290 CONTINUE
+ 300 CONTINUE
+ END IF
+*
+* Diagonally dominant matrix will be generated.
+*
+ IF( LSAME( DIAG, 'D' ) ) THEN
+ IF( MB.NE.NB ) THEN
+ WRITE(*,*) 'Diagonally dominant matrices with rowNB not'//
+ $ ' equal colNB is not supported!'
+ RETURN
+ END IF
+*
+ MAXMN = MAX(M, N)
+ JK = 1
+ DO 340 IC = NOFF+1, NEND
+ IOFFC = ((IC-1)*NPCOL+MRCOL) * NB
+ IK = 1
+ DO 320 IR = MOFF+1, MEND
+ IOFFR = ((IR-1)*NPROW+MRROW) * MB
+ IF( IOFFC.EQ.IOFFR ) THEN
+ DO 310 J = 0, MB-1
+ IF( IK .GT. IRNUM ) GO TO 330
+ A(IK,JK+J) = ABS(A(IK,JK+J)) + MAXMN
+ IK = IK + 1
+ 310 CONTINUE
+ ELSE
+ IK = IK + MB
+ END IF
+ 320 CONTINUE
+ 330 CONTINUE
+ JK = JK + NB
+ 340 CONTINUE
+ END IF
+*
+ RETURN
+*
+* End of PDMATGEN2
+*
+ END
diff --git a/TESTING/EIG/pdsepchk.f b/TESTING/EIG/pdsepchk.f
index 5c21109..3427aa3 100644
--- a/TESTING/EIG/pdsepchk.f
+++ b/TESTING/EIG/pdsepchk.f
@@ -4,10 +4,9 @@
$ Q, IQ, JQ, DESCQ, C, IC, JC, DESCC, W, WORK,
$ LWORK, TSTNRM, RESULT )
*
-* -- ScaLAPACK routine (version 1.7) --
-* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
-* and University of California, Berkeley.
-* November 15, 1997
+* -- ScaLAPACK routine (version 2.0.2) --
+* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver
+* May 1 2012
*
* .. Scalar Arguments ..
INTEGER IA, IC, IQ, JA, JC, JQ, LWORK, MS, NV, RESULT
@@ -215,7 +214,7 @@
CALL BLACS_GRIDINFO( DESCA( CTXT_ ), NPROW, NPCOL, MYROW, MYCOL )
*
INFO = 0
- CALL CHK1MAT( MS, 1, MS, 2, IA, JA, DESCA, 6, INFO )
+ CALL CHK1MAT( MS, 1, MS, 1, IA, JA, DESCA, 6, INFO )
CALL CHK1MAT( MS, 1, NV, 2, IQ, JQ, DESCQ, 12, INFO )
CALL CHK1MAT( MS, 1, NV, 2, IC, JC, DESCC, 16, INFO )
*
diff --git a/TESTING/EIG/pdsepinfo.f b/TESTING/EIG/pdsepinfo.f
index 83b46d7..350b86b 100644
--- a/TESTING/EIG/pdsepinfo.f
+++ b/TESTING/EIG/pdsepinfo.f
@@ -162,6 +162,7 @@
IF( BLOCK_CYCLIC_2D*CSRC_*CTXT_*DLEN_*DTYPE_*LLD_*MB_*M_*NB_*N_*
$ RSRC_.LT.0 )RETURN
*
+ INFO = 0
IF( IAM.EQ.0 ) THEN
READ( NIN, FMT = 9997 )TESTSUMMRY
TESTSUMMRY = ' '
diff --git a/TESTING/EIG/pdseprdriver.f b/TESTING/EIG/pdseprdriver.f
new file mode 100644
index 0000000..1303602
--- /dev/null
+++ b/TESTING/EIG/pdseprdriver.f
@@ -0,0 +1,260 @@
+ PROGRAM PDSEPRDRIVER
+*
+* Parallel DOUBLE PRECISION symmetric eigenproblem test driver for PDSYEVR
+*
+ IMPLICIT NONE
+*
+* The user should modify TOTMEM to indicate the maximum amount of
+* memory in bytes her system has. Remember to leave room in memory
+* for operating system, the BLACS buffer, etc. DBLESZ
+* indicates the length in bytes on the given platform for a number,
+* real for SINGLE/DOUBLE PRECISION, and complex for COMPLEX/COMPLEX*16.
+* For example, on a standard system, the length of a
+* DBLE is 8, and an integer takes up 4 bytes. Some playing around
+* to discover what the maximum value you can set MEMSIZ to may be
+* required.
+* All arrays used by factorization and solve are allocated out of
+* big array called MEM.
+*
+* TESTS PERFORMED
+* ===============
+*
+* This routine performs tests for combinations of: matrix size, process
+* configuration (nprow and npcol), block size (nb),
+* matrix type, range of eigenvalue (all, by value, by index),
+* and upper vs. lower storage.
+*
+* It returns an error message when heterogeneity is detected.
+*
+* The input file allows multiple requests where each one is
+* of the following sets:
+* matrix sizes: n
+* process configuration triples: nprow, npcol, nb
+* matrix types:
+* eigenvalue requests: all, by value, by position
+* storage (upper vs. lower): uplo
+*
+* TERMS:
+* Request - means a set of tests, which is the cross product of
+* a set of specifications from the input file.
+* Test - one element in the cross product, i.e. a specific input
+* size and type, process configuration, etc.
+*
+* .. Parameters ..
+*
+ INTEGER TOTMEM, DBLESZ, NIN
+ PARAMETER ( TOTMEM = 100000000, DBLESZ = 8, NIN = 11 )
+ INTEGER MEMSIZ
+ PARAMETER ( MEMSIZ = TOTMEM / DBLESZ )
+* ..
+* .. Local Scalars ..
+ CHARACTER HETERO
+ CHARACTER*80 SUMMRY, USRINFO
+ INTEGER CONTEXT, IAM, INFO, ISIEEE, MAXNODES, NNOCHECK,
+ $ NOUT, NPASSED, NPROCS, NSKIPPED, NTESTS
+* ..
+* .. Local Arrays ..
+*
+ INTEGER ISEED( 4 )
+ DOUBLE PRECISION MEM( MEMSIZ )
+* ..
+* .. External Functions ..
+ DOUBLE PRECISION DLAMCH
+ EXTERNAL DLAMCH
+* ..
+* .. External Subroutines ..
+*
+ EXTERNAL BLACS_EXIT, BLACS_GET, BLACS_GRIDEXIT,
+ $ BLACS_GRIDINIT, BLACS_PINFO, BLACS_SETUP,
+ $ IGAMN2D, PDLACHKIEEE, PDLASNBT, PDSEPRREQ
+* ..
+* .. Executable Statements ..
+*
+* Get starting information
+*
+ CALL BLACS_PINFO( IAM, NPROCS )
+*
+*
+ IF( IAM.EQ.0 ) THEN
+*
+* Open file and skip data file header
+*
+ OPEN( UNIT = NIN, FILE = 'SEPR.dat', STATUS = 'OLD' )
+ READ( NIN, FMT = * )SUMMRY
+ SUMMRY = ' '
+*
+* Read in user-supplied info about machine type, compiler, etc.
+*
+ READ( NIN, FMT = 9999 )USRINFO
+*
+* Read name and unit number for summary output file
+*
+ READ( NIN, FMT = * )SUMMRY
+ READ( NIN, FMT = * )NOUT
+ IF( NOUT.NE.0 .AND. NOUT.NE.6 )
+ $ OPEN( NOUT, FILE = SUMMRY, STATUS = 'UNKNOWN' )
+ READ( NIN, FMT = * )MAXNODES
+ READ( NIN, FMT = * )HETERO
+ END IF
+*
+ IF( NPROCS.LT.1 ) THEN
+ CALL BLACS_SETUP( IAM, MAXNODES )
+ NPROCS = MAXNODES
+ END IF
+*
+ CALL BLACS_GET( -1, 0, CONTEXT )
+ CALL BLACS_GRIDINIT( CONTEXT, 'R', 1, NPROCS )
+*
+ CALL PDLASNBT( ISIEEE )
+*
+ CALL IGAMN2D( CONTEXT, 'a', ' ', 1, 1, ISIEEE, 1, 1, 1, -1, -1,
+ $ 0 )
+*
+ IF( ( ISIEEE.NE.0 ) ) THEN
+ IF( IAM.EQ.0 ) THEN
+ WRITE( NOUT, FMT = 9997 )
+ WRITE( NOUT, FMT = 9996 )
+ WRITE( NOUT, FMT = 9995 )
+ END IF
+*
+ CALL PDLACHKIEEE( ISIEEE, DLAMCH( 'O' ), DLAMCH( 'U' ) )
+*
+ CALL IGAMN2D( CONTEXT, 'a', ' ', 1, 1, ISIEEE, 1, 1, 1, -1, -1,
+ $ 0 )
+*
+ IF( ISIEEE.EQ.0 ) THEN
+ GO TO 20
+ END IF
+*
+ IF( IAM.EQ.0 ) THEN
+ WRITE( NOUT, FMT = 9986 )
+ END IF
+*
+ END IF
+*
+ IF( IAM.EQ.0 ) THEN
+ WRITE( NOUT, FMT = 9999 )
+ $ 'Test ScaLAPACK symmetric eigendecomposition routine.'
+ WRITE( NOUT, FMT = 9999 )USRINFO
+ WRITE( NOUT, FMT = 9999 )' '
+ WRITE( NOUT, FMT = 9999 )'Running tests of the parallel ' //
+ $ 'symmetric eigenvalue routine: PDSYEVR.'
+ WRITE( NOUT, FMT = 9999 )'The following scaled residual ' //
+ $ 'checks will be computed:'
+ WRITE( NOUT, FMT = 9999 )' ||AQ - QL|| ' //
+ $ '/ ((abstol + ||A|| * eps) * N)'
+ WRITE( NOUT, FMT = 9999 )' ||Q^T*Q - I|| ' // '/ (N * eps)'
+ WRITE( NOUT, FMT = 9999 )
+ WRITE( NOUT, FMT = 9999 )'An explanation of the ' //
+ $ 'input/output parameters follows:'
+ WRITE( NOUT, FMT = 9999 )'RESULT : passed; or ' //
+ $ 'an indication of which eigen request test failed'
+ WRITE( NOUT, FMT = 9999 )
+ $ 'N : The number of rows and columns ' //
+ $ 'of the matrix A.'
+ WRITE( NOUT, FMT = 9999 )
+ $ 'P : The number of process rows.'
+ WRITE( NOUT, FMT = 9999 )
+ $ 'Q : The number of process columns.'
+ WRITE( NOUT, FMT = 9999 )
+ $ 'NB : The size of the square blocks' //
+ $ ' the matrix A is split into.'
+ WRITE( NOUT, FMT = 9999 )
+ $ 'THRESH : If a residual value is less ' //
+ $ 'than THRESH, RESULT = PASSED.'
+ WRITE( NOUT, FMT = 9999 )
+ $ 'TYP : matrix type (see PDSEPRTST).'
+ WRITE( NOUT, FMT = 9999 )'SUB : Subtests (Y/N).'
+ WRITE( NOUT, FMT = 9999 )'WALL : Wallclock time.'
+ WRITE( NOUT, FMT = 9999 )'CPU : CPU time.'
+ WRITE( NOUT, FMT = 9999 )'CHK : ||AQ - QL|| ' //
+ $ '/ ((abstol + ||A|| * eps) * N)'
+ WRITE( NOUT, FMT = 9999 )'QTQ : ||Q^T*Q - I||/ (N * eps)'
+ WRITE( NOUT, FMT = 9999 )
+ $ ' : when the adjusted QTQ norm exceeds THRESH',
+ $ ' it is printed,'
+ WRITE( NOUT, FMT = 9999 )
+ $ ' otherwise the true QTQ norm is printed.'
+ WRITE( NOUT, FMT = 9999 )
+ $ ' : If more than one test is done, CHK and QTQ '
+ WRITE( NOUT, FMT = 9999 )
+ $ ' are the max over all eigentests performed.'
+ WRITE( NOUT, FMT = 9999 )
+ $ 'TEST : EVR - testing PDSYEVR'
+ WRITE( NOUT, FMT = 9999 )' '
+ END IF
+*
+ NTESTS = 0
+ NPASSED = 0
+ NSKIPPED = 0
+ NNOCHECK = 0
+*
+ IF( IAM.EQ.0 ) THEN
+ WRITE( NOUT, FMT = 9979 )
+ WRITE( NOUT, FMT = 9978 )
+ END IF
+*
+ 10 CONTINUE
+*
+ ISEED( 1 ) = 139
+ ISEED( 2 ) = 1139
+ ISEED( 3 ) = 2139
+ ISEED( 4 ) = 3139
+*
+ CALL PDSEPRREQ( HETERO, NIN, MEM, MEMSIZ, NOUT, ISEED, NTESTS,
+ $ NSKIPPED, NNOCHECK, NPASSED, INFO )
+ IF( INFO.EQ.0 )
+ $ GO TO 10
+*
+ IF( IAM.EQ.0 ) THEN
+ WRITE( NOUT, FMT = 9985 )NTESTS
+ WRITE( NOUT, FMT = 9984 )NPASSED
+ WRITE( NOUT, FMT = 9983 )NNOCHECK
+ WRITE( NOUT, FMT = 9982 )NSKIPPED
+ WRITE( NOUT, FMT = 9981 )NTESTS - NPASSED - NSKIPPED -
+ $ NNOCHECK
+ WRITE( NOUT, FMT = * )
+ WRITE( NOUT, FMT = * )
+ WRITE( NOUT, FMT = 9980 )
+ END IF
+*
+* Uncomment this line on SUN systems to avoid the useless print out
+*
+c CALL IEEE_FLAGS( 'clear', 'exception', 'underflow', ' ')
+*
+ 20 CONTINUE
+ IF( IAM.EQ.0 ) THEN
+ CLOSE ( NIN )
+ IF( NOUT.NE.6 .AND. NOUT.NE.0 )
+ $ CLOSE ( NOUT )
+ END IF
+*
+ CALL BLACS_GRIDEXIT( CONTEXT )
+*
+ CALL BLACS_EXIT( 0 )
+ STOP
+*
+ 9999 FORMAT( A )
+ 9997 FORMAT( 'Check if overflow is handled in ieee default manner.' )
+ 9996 FORMAT( 'If this is the last output you see, you should assume')
+ 9995 FORMAT( 'that overflow caused a floating point exception.' )
+*
+ 9986 FORMAT( 'Test ok. The system appears to handle ieee overflow.' )
+*
+ 9985 FORMAT( 'Finished ', I6, ' tests, with the following results:' )
+ 9984 FORMAT( I5, ' tests completed and passed residual checks.' )
+ 9983 FORMAT( I5, ' tests completed without checking.' )
+ 9982 FORMAT( I5, ' tests skipped for lack of memory.' )
+ 9981 FORMAT( I5, ' tests completed and failed.' )
+ 9980 FORMAT( 'END OF TESTS.' )
+ 9979 FORMAT( ' N NB P Q TYP SUB WALL CPU ',
+ $ ' CHK QTQ CHECK TEST' )
+ 9978 FORMAT( ' ----- --- --- --- --- --- -------- --------',
+ $ ' --------- --------- ----- ----' )
+*
+* End of PDSEPRDRIVER
+*
+ END
+
+
+
diff --git a/TESTING/EIG/pdseprreq.f b/TESTING/EIG/pdseprreq.f
new file mode 100644
index 0000000..052c5e8
--- /dev/null
+++ b/TESTING/EIG/pdseprreq.f
@@ -0,0 +1,220 @@
+ SUBROUTINE PDSEPRREQ( HETERO, NIN, MEM, MEMSIZE, NOUT, ISEED,
+ $ NTESTS, NSKIPPED, NNOCHECK, NPASSED, INFO )
+*
+* -- ScaLAPACK routine (@(MODE)version *TBA*) --
+* University of California, Berkeley and
+* University of Tennessee, Knoxville.
+* October 21, 2006
+*
+ IMPLICIT NONE
+*
+* .. Scalar Arguments ..
+ CHARACTER HETERO
+ INTEGER INFO, MEMSIZE, NIN, NNOCHECK, NOUT, NPASSED,
+ $ NSKIPPED, NTESTS
+* ..
+* .. Array Arguments ..
+ INTEGER ISEED( 4 )
+ DOUBLE PRECISION MEM( MEMSIZE )
+*
+* Purpose
+* =======
+*
+* PDSEPRREQ performs one request from the input file 'SEPR.dat'
+* A request is the cross product of the specifications in the
+* input file. It prints one line per test.
+*
+* Arguments
+* =========
+*
+* NIN (local input) INTEGER
+* The unit number for the input file 'SEPR.dat'
+*
+* MEM (local input ) DOUBLE PRECISION ARRAY, dimension MEMSIZE
+* Array encompassing the available single precision memory
+*
+* MEMSIZE (local input) INTEGER
+* Size of MEM array
+*
+* NOUT (local input) INTEGER
+* The unit number for output file.
+* NOUT = 6, output to screen,
+* NOUT = 0, output to stderr.
+* NOUT = 13, output to file, divide thresh by 10
+* NOUT = 14, output to file, divide thresh by 20
+* Only used on node 0.
+* NOUT = 13, 14 allow the threshold to be tighter for our
+* internal testing which means that when a user reports
+* a threshold error, it is more likely to be significant.
+*
+* ISEED (global input/output) INTEGER array, dimension 4
+* Random number generator seed
+*
+* NTESTS (global input/output) INTEGER
+* NTESTS = NTESTS + tests requested
+*
+* NSKIPPED (global input/output) INTEGER
+* NSKIPPED = NSKIPPED + tests skipped
+*
+* NNOCHECK (global input/output) INTEGER
+* NNOCHECK = NNOCHECK + tests completed but not checked
+*
+* NPASSED (global input/output) INTEGER
+* NPASSED = NPASSED + tests which passed all checks
+*
+* INFO (global output) INTEGER
+* 0 = test request ran
+* -1 = end of file
+* -2 = incorrect .dat file
+*
+* .. Parameters ..
+*
+ INTEGER DLEN_
+ PARAMETER ( DLEN_ = 9 )
+ INTEGER DBLESZ, INTGSZ
+ PARAMETER ( DBLESZ = 8, INTGSZ = 4 )
+ INTEGER MAXSETSIZE
+ PARAMETER ( MAXSETSIZE = 50 )
+* ..
+* .. Local Scalars ..
+ CHARACTER SUBTESTS
+ INTEGER CONTEXT, IAM, IMIDPAD, INITCON, IPOSTPAD,
+ $ IPREPAD, ISIZESUBTST, ISIZEEVR, ISIZETST,
+ $ LDA, LLWORK, MATSIZE, MATTYPE, MYCOL, MYROW, N,
+ $ NB, NMATSIZES, NMATTYPES, NNODES, NP, NPCOL,
+ $ NPCONFIGS, NPROW, NQ, NUPLOS, ORDER, PCONFIG,
+ $ PTRA, PTRCOPYA, PTRGAP, PTRICLUS, PTRIFAIL,
+ $ PTRIWRK, PTRW, PTRW2, PTRWORK, PTRZ, RES,
+ $ SIZECHK, SIZEMQRLEFT, SIZEMQRRIGHT, SIZEQRF,
+ $ SIZEQTQ, SIZESUBTST, SIZEEVR,
+ $ SIZETMS, SIZETST, UPLO
+*
+ DOUBLE PRECISION ABSTOL, THRESH
+* ..
+* .. Local Arrays ..
+ CHARACTER UPLOS( 2 )
+ INTEGER DESCA( DLEN_ ), MATSIZES( MAXSETSIZE ),
+ $ MATTYPES( MAXSETSIZE ), NBS( MAXSETSIZE ),
+ $ NPCOLS( MAXSETSIZE ), NPROWS( MAXSETSIZE )
+* ..
+* .. External Functions ..
+ INTEGER ICEIL, NUMROC
+ EXTERNAL ICEIL, NUMROC
+* ..
+* .. External Subroutines ..
+ EXTERNAL BLACS_ABORT, BLACS_GET, BLACS_GRIDEXIT,
+ $ BLACS_GRIDINFO, BLACS_GRIDINIT, BLACS_PINFO,
+ $ DESCINIT, PDLASIZESEPR, PDSEPINFO, PDSEPRTST
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX
+* ..
+* .. Executable Statements ..
+*
+ CALL BLACS_PINFO( IAM, NNODES )
+ CALL BLACS_GET( -1, 0, INITCON )
+ CALL BLACS_GRIDINIT( INITCON, 'R', 1, NNODES )
+*
+ CALL PDSEPINFO( INITCON, IAM, NIN, NOUT, MAXSETSIZE, NMATSIZES,
+ $ MATSIZES, NUPLOS, UPLOS, NPCONFIGS, NPROWS,
+ $ NPCOLS, NBS, NMATTYPES, MATTYPES, 22, SUBTESTS,
+ $ THRESH, ORDER, ABSTOL, INFO )
+*
+ CALL BLACS_GRIDEXIT( INITCON )
+*
+ IF( INFO.EQ.0 ) THEN
+*
+ DO 40 MATSIZE = 1, NMATSIZES
+*
+ DO 30 PCONFIG = 1, NPCONFIGS
+*
+ DO 20 MATTYPE = 1, NMATTYPES
+*
+ DO 10 UPLO = 1, NUPLOS
+*
+ N = MATSIZES( MATSIZE )
+ ORDER = N
+*
+ NPROW = NPROWS( PCONFIG )
+ NPCOL = NPCOLS( PCONFIG )
+ NB = NBS( PCONFIG )
+*
+ NP = NUMROC( N, NB, 0, 0, NPROW )
+ NQ = NUMROC( N, NB, 0, 0, NPCOL )
+ IPREPAD = MAX( NB, NP )
+ IMIDPAD = NB
+ IPOSTPAD = MAX( NB, NQ )
+*
+ LDA = MAX( NP, 1 ) + IMIDPAD
+*
+ CALL BLACS_GET( -1, 0, CONTEXT )
+ CALL BLACS_GRIDINIT( CONTEXT, 'R', NPROW, NPCOL )
+ CALL BLACS_GRIDINFO( CONTEXT, NPROW, NPCOL, MYROW,
+ $ MYCOL )
+*
+ IF( MYROW.GE.0 ) THEN
+ CALL DESCINIT( DESCA, N, N, NB, NB, 0, 0,
+ $ CONTEXT, LDA, INFO )
+ CALL PDLASIZESEPR( DESCA, IPREPAD, IPOSTPAD,
+ $ SIZEMQRLEFT, SIZEMQRRIGHT,
+ $ SIZEQRF, SIZETMS, SIZEQTQ,
+ $ SIZECHK, SIZEEVR, ISIZEEVR,
+ $ SIZESUBTST, ISIZESUBTST,
+ $ SIZETST, ISIZETST )
+*
+ PTRA = 1
+ PTRZ = PTRA + LDA*NQ + IPREPAD + IPOSTPAD
+ PTRCOPYA = PTRZ + LDA*NQ + IPREPAD + IPOSTPAD
+ PTRW = PTRCOPYA + LDA*NQ + IPREPAD + IPOSTPAD
+ PTRW2 = PTRW + MAX( N, 1 ) + IPREPAD + IPOSTPAD
+ PTRGAP = PTRW2 + MAX( N, 1 ) + IPREPAD +
+ $ IPOSTPAD
+ PTRIFAIL = PTRGAP + NPROW*NPCOL + IPREPAD +
+ $ IPOSTPAD
+ PTRICLUS = PTRIFAIL + ICEIL( N+IPREPAD+IPOSTPAD,
+ $ DBLESZ / INTGSZ )
+ PTRIWRK = PTRICLUS + ICEIL( 2*NPROW*NPCOL+
+ $ IPREPAD+IPOSTPAD, DBLESZ / INTGSZ )
+ PTRWORK = PTRIWRK + ICEIL( ISIZETST+IPREPAD+
+ $ IPOSTPAD, DBLESZ / INTGSZ )
+ LLWORK = MEMSIZE - PTRWORK + 1
+
+ NTESTS = NTESTS + 1
+ IF( LLWORK.LT.SIZETST ) THEN
+ NSKIPPED = NSKIPPED + 1
+ ELSE
+ CALL PDSEPRTST( DESCA, UPLOS( UPLO ), N,
+ $ MATTYPES( MATTYPE ), SUBTESTS,
+ $ THRESH, N, ABSTOL, ISEED,
+ $ MEM( PTRA ), MEM( PTRCOPYA ),
+ $ MEM( PTRZ ), LDA, MEM( PTRW ),
+ $ MEM( PTRW2 ), MEM( PTRIFAIL ),
+ $ MEM( PTRICLUS ),
+ $ MEM( PTRGAP ), IPREPAD,
+ $ IPOSTPAD, MEM( PTRWORK ),
+ $ LLWORK, MEM( PTRIWRK ),
+ $ ISIZETST, HETERO, NOUT, RES )
+*
+ IF( RES.EQ.0 ) THEN
+ NPASSED = NPASSED + 1
+ ELSE IF( RES.EQ.2 ) THEN
+ NNOCHECK = NNOCHECK + 1
+ ELSE IF( RES.EQ.3 ) THEN
+ NSKIPPED = NSKIPPED + 1
+ WRITE( NOUT, FMT = * )' PDSEPRREQ failed'
+ CALL BLACS_ABORT( CONTEXT, -1 )
+ END IF
+ END IF
+ CALL BLACS_GRIDEXIT( CONTEXT )
+ END IF
+ 10 CONTINUE
+ 20 CONTINUE
+ 30 CONTINUE
+ 40 CONTINUE
+ END IF
+*
+ RETURN
+*
+* End of PDSEPRREQ
+*
+ END
diff --git a/TESTING/EIG/pdseprsubtst.f b/TESTING/EIG/pdseprsubtst.f
new file mode 100644
index 0000000..125463f
--- /dev/null
+++ b/TESTING/EIG/pdseprsubtst.f
@@ -0,0 +1,802 @@
+ SUBROUTINE PDSEPRSUBTST( WKNOWN, JOBZ, RANGE, UPLO, N, VL, VU, IL,
+ $ IU, THRESH, ABSTOL, A, COPYA, Z, IA, JA,
+ $ DESCA, WIN, WNEW, IFAIL, ICLUSTR, GAP,
+ $ IPREPAD, IPOSTPAD, WORK, LWORK, LWORK1,
+ $ IWORK, LIWORK, RESULT, TSTNRM, QTQNRM,
+ $ NOUT )
+*
+* -- ScaLAPACK routine (@(MODE)version *TBA*) --
+* University of California, Berkeley and
+* University of Tennessee, Knoxville.
+* October 21, 2006
+*
+ IMPLICIT NONE
+*
+* .. Scalar Arguments ..
+ LOGICAL WKNOWN
+ CHARACTER JOBZ, RANGE, UPLO
+ INTEGER IA, IL, IPOSTPAD, IPREPAD, IU, JA, LIWORK,
+ $ LWORK, LWORK1, N, NOUT, RESULT
+ DOUBLE PRECISION ABSTOL, QTQNRM, THRESH, TSTNRM, VL, VU
+* ..
+* .. Array Arguments ..
+ INTEGER DESCA( * ), ICLUSTR( * ), IFAIL( * ),
+ $ IWORK( * )
+ DOUBLE PRECISION A( * ), COPYA( * ), GAP( * ), WIN( * ),
+ $ WNEW( * ), WORK( * ), Z( * )
+* ..
+*
+* Purpose
+* =======
+*
+* PDSEPRSUBTST calls PDSYEVR and then tests its output.
+* If JOBZ = 'V' then the following two tests are performed:
+* |AQ -QL| / (abstol + eps * norm(A) ) < N*THRESH
+* |QT * Q - I| / eps < N*THRESH
+* If WKNOWN then
+* we check to make sure that the eigenvalues match expectations
+* i.e. |WIN - WNEW(1+IPREPAD)| / (eps * |WIN|) < THRESH
+* where WIN is the array of eigenvalues computed.
+*
+* Arguments
+* =========
+*
+* NP = the number of rows local to a given process.
+* NQ = the number of columns local to a given process.
+*
+* WKNOWN (global input) INTEGER
+* .FALSE.: WIN does not contain the eigenvalues
+* .TRUE.: WIN does contain the eigenvalues
+*
+* JOBZ (global input) CHARACTER*1
+* Specifies whether or not to compute the eigenvectors:
+* = 'N': Compute eigenvalues only.
+* = 'V': Compute eigenvalues and eigenvectors.
+* Must be 'V' on first call.
+*
+* RANGE (global input) CHARACTER*1
+* = 'A': all eigenvalues will be found.
+* = 'V': all eigenvalues in the interval [VL,VU]
+* will be found.
+* = 'I': the IL-th through IU-th eigenvalues will be found.
+* Must be 'A' on first call.
+*
+* UPLO (global input) CHARACTER*1
+* Specifies whether the upper or lower triangular part of the
+* matrix A is stored:
+* = 'U': Upper triangular
+* = 'L': Lower triangular
+*
+* N (global input) INTEGER
+* Size of the matrix to be tested. (global size)
+*
+* VL (global input) DOUBLE PRECISION
+* If RANGE='V', the lower bound of the interval to be searched
+* for eigenvalues. Not referenced if RANGE = 'A' or 'I'.
+*
+* VU (global input) DOUBLE PRECISION
+* If RANGE='V', the upper bound of the interval to be searched
+* for eigenvalues. Not referenced if RANGE = 'A' or 'I'.
+*
+* IL (global input) INTEGER
+* If RANGE='I', the index (from smallest to largest) of the
+* smallest eigenvalue to be returned. IL >= 1.
+* Not referenced if RANGE = 'A' or 'V'.
+*
+* IU (global input) INTEGER
+* If RANGE='I', the index (from smallest to largest) of the
+* largest eigenvalue to be returned. min(IL,N) <= IU <= N.
+* Not referenced if RANGE = 'A' or 'V'.
+*
+* THRESH (global input) DOUBLE PRECISION
+* A test will count as "failed" if the "error", computed as
+* described below, exceeds THRESH. Note that the error
+* is scaled to be O(1), so THRESH should be a reasonably
+* small multiple of 1, e.g., 100 or 250. In particular,
+* it should not depend on the size of the matrix.
+* It must be at least zero.
+*
+* ABSTOL (global input) DOUBLE PRECISION
+* The absolute tolerance for the residual test.
+*
+* A (local workspace) DOUBLE PRECISION array
+* global dimension (N, N), local dimension (DESCA(DLEN_), NQ)
+* The test matrix, which is subsequently overwritten.
+* A is distributed in a 2D-block cyclic manner over both rows
+* and columns.
+* A has already been padded front and back, use A(1+IPREPAD)
+*
+* COPYA (local input) DOUBLE PRECISION array, dimension(N*N)
+* COPYA holds a copy of the original matrix A
+* identical in both form and content to A
+*
+* Z (local workspace) DOUBLE PRECISION array, dim (N*N)
+* Z is distributed in the same manner as A
+* Z contains the eigenvector matrix
+* Z is used as workspace by the test routines
+* PDSEPCHK and PDSEPQTQ.
+* Z has already been padded front and back, use Z(1+IPREPAD)
+*
+* IA (global input) INTEGER
+* On entry, IA specifies the global row index of the submatrix
+* of the global matrix A, COPYA and Z to operate on.
+*
+* JA (global input) INTEGER
+* On entry, IA specifies the global column index of the submat
+* of the global matrix A, COPYA and Z to operate on.
+*
+* DESCA (global/local input) INTEGER array of dimension 8
+* The array descriptor for the matrix A, COPYA and Z.
+*
+* WIN (global input) DOUBLE PRECISION array, dimension (N)
+* If .not. WKNOWN, WIN is ignored on input
+* Otherwise, WIN() is taken as the standard by which the
+* eigenvalues are to be compared against.
+*
+* WNEW (global workspace) DOUBLE PRECISION array, dimension (N)
+* The computed eigenvalues.
+* If JOBZ <> 'V' or RANGE <> 'A' these eigenvalues are
+* compared against those in WIN().
+* WNEW has already been padded front and back,
+* use WNEW(1+IPREPAD)
+*
+* IFAIL (global output) INTEGER array, dimension (N)
+* If JOBZ = 'V', then on normal exit, the first M elements of
+* IFAIL are zero. If INFO > 0 on exit, then IFAIL contains the
+* indices of the eigenvectors that failed to converge.
+* If JOBZ = 'N', then IFAIL is not referenced.
+* IFAIL has already been padded front and back,
+* use IFAIL(1+IPREPAD)
+*
+* ICLUSTR (global workspace) integer array, dimension (2*NPROW*NPCOL)
+*
+* GAP (global workspace) DOUBLE PRECISION array,
+* dimension (NPROW*NPCOL)
+*
+* WORK (local workspace) DOUBLE PRECISION array, dimension (LWORK)
+* WORK has already been padded front and back,
+* use WORK(1+IPREPAD)
+*
+* LWORK (local input) INTEGER
+* The actual length of the array WORK after padding.
+*
+* LWORK1 (local input) INTEGER
+* The amount of real workspace to pass to the eigensolver.
+*
+* IWORK (local workspace) INTEGER array, dimension (LIWORK)
+* IWORK has already been padded front and back,
+* use IWORK(1+IPREPAD)
+*
+* LIWORK (local input) INTEGER
+* The length of the array IWORK after padding.
+*
+* RESULT (global output) INTEGER
+* The result of this call.
+* RESULT = -3 => This process did not participate
+* RESULT = 0 => All tests passed
+* RESULT = 1 => ONe or more tests failed
+*
+* TSTNRM (global output) DOUBLE PRECISION
+* |AQ- QL| / (ABSTOL+EPS*|A|)*N
+*
+* QTQNRM (global output) DOUBLE PRECISION
+* |QTQ -I| / N*EPS
+*
+* .. Parameters ..
+*
+ INTEGER DLEN_, CTXT_, M_, N_,
+ $ MB_, NB_, RSRC_, CSRC_, LLD_
+ PARAMETER ( DLEN_ = 9,
+ $ CTXT_ = 2, M_ = 3, N_ = 4, MB_ = 5, NB_ = 6,
+ $ RSRC_ = 7, CSRC_ = 8, LLD_ = 9 )
+ DOUBLE PRECISION PADVAL, FIVE, NEGONE
+ PARAMETER ( PADVAL = 13.5285D0, FIVE = 5.0D0,
+ $ NEGONE = -1.0D0 )
+ INTEGER IPADVAL
+ PARAMETER ( IPADVAL = 927 )
+* ..
+* .. Local Scalars ..
+ LOGICAL MISSLARGEST, MISSSMALLEST
+ INTEGER I, IAM, INDIWRK, INFO, ISIZESUBTST, ISIZEEVR,
+ $ ISIZETST, J, M, MAXEIGS, MAXIL, MAXIU, MAXSIZE,
+ $ MINIL, MQ, MYCOL, MYIL, MYROW, NCLUSTERS, NP,
+ $ NPCOL, NPROW, NQ, NZ, OLDIL, OLDIU, OLDNZ, RES,
+ $ SIZECHK, SIZEMQRLEFT, SIZEMQRRIGHT, SIZEQRF,
+ $ SIZEQTQ, SIZESUBTST, SIZEEVR, SIZETMS,
+ $ SIZETST, VALSIZE, VECSIZE
+ DOUBLE PRECISION EPS, EPSNORMA, ERROR, MAXERROR, MAXVU,
+ $ MINERROR, MINVL, NORMWIN, OLDVL, OLDVU,
+ $ SAFMIN
+* ..
+* .. Local Arrays ..
+ INTEGER DESCZ( DLEN_ ), ISEED( 4 ), ITMP( 2 )
+* ..
+* .. External Functions ..
+*
+ LOGICAL LSAME
+ INTEGER NUMROC
+ DOUBLE PRECISION PDLAMCH, PDLANSY
+ EXTERNAL LSAME, NUMROC, PDLAMCH, PDLANSY
+* ..
+* .. External Subroutines ..
+ EXTERNAL BLACS_GRIDINFO, DESCINIT, DGAMN2D, DGAMX2D,
+ $ DLACPY, IGAMN2D, IGAMX2D, PDCHEKPAD, PDELSET,
+ $ PDFILLPAD, PDLASIZESEPR, PDLASIZESYEVR,
+ $ PDSEPCHK, PDSEPQTQ, PDSYEVR, PICHEKPAD,
+ $ PIFILLPAD, SLBOOT, SLTIMER
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX, MIN, MOD
+* ..
+* .. Executable Statements ..
+*
+ CALL PDLASIZESEPR( DESCA, IPREPAD, IPOSTPAD, SIZEMQRLEFT,
+ $ SIZEMQRRIGHT, SIZEQRF, SIZETMS, SIZEQTQ,
+ $ SIZECHK, SIZEEVR, ISIZEEVR, SIZESUBTST,
+ $ ISIZESUBTST, SIZETST, ISIZETST )
+*
+ TSTNRM = NEGONE
+ QTQNRM = NEGONE
+ EPS = PDLAMCH( DESCA( CTXT_ ), 'Eps' )
+ SAFMIN = PDLAMCH( DESCA( CTXT_ ), 'Safe min' )
+*
+ NORMWIN = SAFMIN / EPS
+ IF( N.GE.1 )
+ $ NORMWIN = MAX( ABS( WIN( 1 ) ), ABS( WIN( N ) ), NORMWIN )
+*
+* Make sure that no information from previous calls is used
+*
+ NZ = -13
+ OLDNZ = NZ
+ OLDIL = IL
+ OLDIU = IU
+ OLDVL = VL
+ OLDVU = VU
+*
+ DO 10 I = 1, LWORK1, 1
+ WORK( I+IPREPAD ) = 14.3D0
+ 10 CONTINUE
+*
+ DO 20 I = 1, LIWORK, 1
+ IWORK( I+IPREPAD ) = 14
+ 20 CONTINUE
+*
+ DO 30 I = 1, N
+ WNEW( I+IPREPAD ) = 3.14159D0
+ 30 CONTINUE
+*
+ ICLUSTR( 1+IPREPAD ) = 139
+*
+ IF (LSAME( RANGE, 'V' ) ) THEN
+* WRITE(*,*) 'VL VU = ', VL, ' ', VU
+ END IF
+
+ IF( LSAME( JOBZ, 'N' ) ) THEN
+ MAXEIGS = 0
+ ELSE
+ IF( LSAME( RANGE, 'A' ) ) THEN
+ MAXEIGS = N
+ ELSE IF( LSAME( RANGE, 'I' ) ) THEN
+ MAXEIGS = IU - IL + 1
+ ELSE
+ MINVL = VL - NORMWIN*FIVE*EPS - ABSTOL
+ MAXVU = VU + NORMWIN*FIVE*EPS + ABSTOL
+* WRITE(*,*) 'MINVL = ', MINVL, ' MAXVU = ', MAXVU
+* WRITE(*,*) 'WIN = ', WIN( 1 )
+ MINIL = 1
+ MAXIU = 0
+ DO 40 I = 1, N
+ IF( WIN( I ).LT.MINVL )
+ $ MINIL = MINIL + 1
+ IF( WIN( I ).LE.MAXVU )
+ $ MAXIU = MAXIU + 1
+ 40 CONTINUE
+*
+ MAXEIGS = MAXIU - MINIL + 1
+ END IF
+ END IF
+*
+*
+ CALL DESCINIT( DESCZ, DESCA( M_ ), DESCA( N_ ), DESCA( MB_ ),
+ $ DESCA( NB_ ), DESCA( RSRC_ ), DESCA( CSRC_ ),
+ $ DESCA( CTXT_ ), DESCA( LLD_ ), INFO )
+*
+ CALL BLACS_GRIDINFO( DESCA( CTXT_ ), NPROW, NPCOL, MYROW, MYCOL )
+ INDIWRK = 1 + IPREPAD + NPROW*NPCOL + 1
+*
+ IAM = 1
+ IF( MYROW.EQ.0 .AND. MYCOL.EQ.0 )
+ $ IAM = 0
+*
+* If this process is not involved in this test, bail out now
+*
+ RESULT = -3
+ IF( MYROW.GE.NPROW .OR. MYROW.LT.0 )
+ $ GO TO 150
+ RESULT = 0
+*
+ ISEED( 1 ) = 1
+*
+ CALL PDLASIZESYEVR( WKNOWN, RANGE, N, DESCA, VL, VU, IL, IU,
+ $ ISEED, WIN, MAXSIZE, VECSIZE, VALSIZE )
+*
+ NP = NUMROC( N, DESCA( MB_ ), MYROW, 0, NPROW )
+ NQ = NUMROC( N, DESCA( NB_ ), MYCOL, 0, NPCOL )
+ MQ = NUMROC( MAXEIGS, DESCA( NB_ ), MYCOL, 0, NPCOL )
+*
+ CALL DLACPY( 'A', NP, NQ, COPYA, DESCA( LLD_ ), A( 1+IPREPAD ),
+ $ DESCA( LLD_ ) )
+*
+ CALL PDFILLPAD( DESCA( CTXT_ ), NP, NQ, A, DESCA( LLD_ ), IPREPAD,
+ $ IPOSTPAD, PADVAL )
+*
+ CALL PDFILLPAD( DESCZ( CTXT_ ), NP, MQ, Z, DESCZ( LLD_ ), IPREPAD,
+ $ IPOSTPAD, PADVAL+1.0D0 )
+*
+* WRITE(*,*) ' NP = ', NP, ' MQ = ', MQ, ' LDZ = ', DESCZ( LLD_ ),
+* $ ' IPREPAD = ', IPREPAD, ' IPOSTPAD = ', IPOSTPAD,
+* $ ' MAXEIGS = ', MAXEIGS
+* WRITE(*,*) ' PADZ( 1 ) = ', Z( 1 ), ' PADZ( 2 ) = ', Z( 2 ),
+* $ ' PADZ( 3 ) = ', Z( 3 ), ' PADZ( 4 ) = ', Z( 4 )
+*
+ CALL PDFILLPAD( DESCA( CTXT_ ), N, 1, WNEW, N, IPREPAD, IPOSTPAD,
+ $ PADVAL+2.0D0 )
+*
+ CALL PDFILLPAD( DESCA( CTXT_ ), NPROW*NPCOL, 1, GAP, NPROW*NPCOL,
+ $ IPREPAD, IPOSTPAD, PADVAL+3.0D0 )
+*
+ CALL PDFILLPAD( DESCA( CTXT_ ), LWORK1, 1, WORK, LWORK1, IPREPAD,
+ $ IPOSTPAD, PADVAL+4.0D0 )
+*
+ CALL PIFILLPAD( DESCA( CTXT_ ), LIWORK, 1, IWORK, LIWORK, IPREPAD,
+ $ IPOSTPAD, IPADVAL )
+*
+ CALL PIFILLPAD( DESCA( CTXT_ ), N, 1, IFAIL, N, IPREPAD, IPOSTPAD,
+ $ IPADVAL )
+*
+ CALL PIFILLPAD( DESCA( CTXT_ ), 2*NPROW*NPCOL, 1, ICLUSTR,
+ $ 2*NPROW*NPCOL, IPREPAD, IPOSTPAD, IPADVAL )
+*
+* Make sure that PDSYEVR does not cheat (i.e. use answers
+* already computed.)
+*
+ DO 60 I = 1, N, 1
+ DO 50 J = 1, MAXEIGS, 1
+ CALL PDELSET( Z( 1+IPREPAD ), I, J, DESCA, 13.0D0 )
+ 50 CONTINUE
+ 60 CONTINUE
+*
+* Reset and start the timer
+*
+ CALL SLBOOT
+ CALL SLTIMER( 1 )
+ CALL SLTIMER( 6 )
+
+*********************************
+*
+* Main call to PDSYEVR
+*
+ CALL PDSYEVR( JOBZ, RANGE, UPLO, N, A( 1+IPREPAD ), IA, JA, DESCA,
+ $ VL, VU, IL, IU, M, NZ, WNEW( 1+IPREPAD ),
+ $ Z( 1+IPREPAD ), IA, JA, DESCA,
+ $ WORK( 1+IPREPAD ), LWORK1, IWORK( 1+IPREPAD ),
+ $ LIWORK, INFO )
+*
+*********************************
+*
+* Stop timer
+*
+ CALL SLTIMER( 6 )
+ CALL SLTIMER( 1 )
+*
+* Indicate that there are no unresolved clusters.
+* This is necessary so that the tester
+* (adapted from the one originally made for PDSYEVX)
+* works correctly.
+ ICLUSTR( 1+IPREPAD ) = 0
+*
+ IF( THRESH.LE.0 ) THEN
+ RESULT = 0
+ ELSE
+ CALL PDCHEKPAD( DESCA( CTXT_ ), 'PDSYEVR-A', NP, NQ, A,
+ $ DESCA( LLD_ ), IPREPAD, IPOSTPAD, PADVAL )
+*
+ CALL PDCHEKPAD( DESCZ( CTXT_ ), 'PDSYEVR-Z', NP, MQ, Z,
+ $ DESCZ( LLD_ ), IPREPAD, IPOSTPAD,
+ $ PADVAL+1.0D0 )
+*
+ CALL PDCHEKPAD( DESCA( CTXT_ ), 'PDSYEVR-WNEW', N, 1, WNEW, N,
+ $ IPREPAD, IPOSTPAD, PADVAL+2.0D0 )
+*
+ CALL PDCHEKPAD( DESCA( CTXT_ ), 'PDSYEVR-GAP', NPROW*NPCOL, 1,
+ $ GAP, NPROW*NPCOL, IPREPAD, IPOSTPAD,
+ $ PADVAL+3.0D0 )
+*
+ CALL PDCHEKPAD( DESCA( CTXT_ ), 'PDSYEVR-WORK', LWORK1, 1,
+ $ WORK, LWORK1, IPREPAD, IPOSTPAD,
+ $ PADVAL+4.0D0 )
+*
+ CALL PICHEKPAD( DESCA( CTXT_ ), 'PDSYEVR-IWORK', LIWORK, 1,
+ $ IWORK, LIWORK, IPREPAD, IPOSTPAD, IPADVAL )
+*
+ CALL PICHEKPAD( DESCA( CTXT_ ), 'PDSYEVR-IFAIL', N, 1, IFAIL,
+ $ N, IPREPAD, IPOSTPAD, IPADVAL )
+*
+ CALL PICHEKPAD( DESCA( CTXT_ ), 'PDSYEVR-ICLUSTR',
+ $ 2*NPROW*NPCOL, 1, ICLUSTR, 2*NPROW*NPCOL,
+ $ IPREPAD, IPOSTPAD, IPADVAL )
+*
+* If we now know the spectrum, we can potentially reduce MAXSIZE.
+*
+ IF( LSAME( RANGE, 'A' ) ) THEN
+ CALL PDLASIZESYEVR( .TRUE., RANGE, N, DESCA, VL, VU, IL, IU,
+ $ ISEED, WNEW( 1+IPREPAD ), MAXSIZE,
+ $ VECSIZE, VALSIZE )
+ END IF
+*
+* Check INFO
+* Make sure that all processes return the same value of INFO
+*
+ ITMP( 1 ) = INFO
+ ITMP( 2 ) = INFO
+*
+ CALL IGAMN2D( DESCA( CTXT_ ), 'a', ' ', 1, 1, ITMP, 1, 1, 1,
+ $ -1, -1, 0 )
+ CALL IGAMX2D( DESCA( CTXT_ ), 'a', ' ', 1, 1, ITMP( 2 ), 1, 1,
+ $ 1, -1, -1, 0 )
+*
+*
+ IF( ITMP( 1 ).NE.ITMP( 2 ) ) THEN
+ IF( IAM.EQ.0 )
+ $ WRITE( NOUT, FMT = * )
+ $ 'Different processes return different INFO'
+ RESULT = 1
+ ELSE IF( MOD( INFO, 2 ).EQ.1 .OR. INFO.GT.7 .OR. INFO.LT.0 )
+ $ THEN
+ IF( IAM.EQ.0 )
+ $ WRITE( NOUT, FMT = 9999 )INFO
+ RESULT = 1
+ ELSE IF( MOD( INFO / 2, 2 ).EQ.1 .AND. LWORK1.GE.MAXSIZE ) THEN
+ IF( IAM.EQ.0 )
+ $ WRITE( NOUT, FMT = 9996 )INFO
+ RESULT = 1
+ ELSE IF( MOD( INFO / 4, 2 ).EQ.1 .AND. LWORK1.GE.VECSIZE ) THEN
+ IF( IAM.EQ.0 )
+ $ WRITE( NOUT, FMT = 9996 )INFO
+ RESULT = 1
+ END IF
+*
+ IF( LSAME( JOBZ, 'V' ) .AND. ( ICLUSTR( 1+IPREPAD ).NE.
+ $ 0 ) .AND. ( MOD( INFO / 2, 2 ).NE.1 ) ) THEN
+ IF( IAM.EQ.0 )
+ $ WRITE( NOUT, FMT = 9995 )
+ RESULT = 1
+ END IF
+*
+* Check M
+*
+ IF( ( M.LT.0 ) .OR. ( M.GT.N ) ) THEN
+ IF( IAM.EQ.0 )
+ $ WRITE( NOUT, FMT = 9994 )
+ WRITE( NOUT,*) 'M = ', M, '\n', 'N = ', N
+ RESULT = 1
+ ELSE IF( LSAME( RANGE, 'A' ) .AND. ( M.NE.N ) ) THEN
+ IF( IAM.EQ.0 )
+ $ WRITE( NOUT, FMT = 9993 )
+ RESULT = 1
+ ELSE IF( LSAME( RANGE, 'I' ) .AND. ( M.NE.IU-IL+1 ) ) THEN
+ IF( IAM.EQ.0 ) THEN
+ WRITE( NOUT, FMT = 9992 )
+ WRITE( NOUT,*) 'IL = ', IL, ' IU = ', IU, ' M = ', M
+ END IF
+ RESULT = 1
+ ELSE IF( LSAME( JOBZ, 'V' ) .AND.
+ $ ( .NOT.( LSAME( RANGE, 'V' ) ) ) .AND. ( M.NE.NZ ) )
+ $ THEN
+ IF( IAM.EQ.0 )
+ $ WRITE( NOUT, FMT = 9991 )
+ RESULT = 1
+ END IF
+*
+* Check NZ
+*
+ IF( LSAME( JOBZ, 'V' ) ) THEN
+ IF( LSAME( RANGE, 'V' ) ) THEN
+ IF( NZ.GT.M ) THEN
+ IF( IAM.EQ.0 )
+ $ WRITE( NOUT, FMT = 9990 )
+ RESULT = 1
+ END IF
+ IF( NZ.LT.M .AND. MOD( INFO / 4, 2 ).NE.1 ) THEN
+ IF( IAM.EQ.0 )
+ $ WRITE( NOUT, FMT = 9989 )
+ RESULT = 1
+ END IF
+ ELSE
+ IF( NZ.NE.M ) THEN
+ IF( IAM.EQ.0 )
+ $ WRITE( NOUT, FMT = 9988 )
+ RESULT = 1
+ END IF
+ END IF
+ END IF
+ IF( RESULT.EQ.0 ) THEN
+*
+* Make sure that all processes return the same # of eigenvalues
+*
+ ITMP( 1 ) = M
+ ITMP( 2 ) = M
+*
+ CALL IGAMN2D( DESCA( CTXT_ ), 'a', ' ', 1, 1, ITMP, 1, 1, 1,
+ $ -1, -1, 0 )
+ CALL IGAMX2D( DESCA( CTXT_ ), 'a', ' ', 1, 1, ITMP( 2 ), 1,
+ $ 1, 1, -1, -1, 0 )
+*
+ IF( ITMP( 1 ).NE.ITMP( 2 ) ) THEN
+ IF( IAM.EQ.0 )
+ $ WRITE( NOUT, FMT = 9987 )
+ RESULT = 1
+ ELSE
+*
+* Ensure that different processes return the same eigenvalues
+*
+ DO 70 I = 1, M
+ WORK( I ) = WNEW( I+IPREPAD )
+ WORK( I+M ) = WNEW( I+IPREPAD )
+ 70 CONTINUE
+*
+ CALL DGAMN2D( DESCA( CTXT_ ), 'a', ' ', M, 1, WORK, M, 1,
+ $ 1, -1, -1, 0 )
+ CALL DGAMX2D( DESCA( CTXT_ ), 'a', ' ', M, 1,
+ $ WORK( 1+M ), M, 1, 1, -1, -1, 0 )
+*
+ DO 80 I = 1, M
+ IF( RESULT.EQ.0 .AND. ( ABS( WORK( I )-WORK( M+
+ $ I ) ).GT.FIVE*EPS*ABS( WORK( I ) ) ) ) THEN
+ IF( IAM.EQ.0 )
+ $ WRITE( NOUT, FMT = 9986 )
+ RESULT = 1
+ END IF
+ 80 CONTINUE
+ END IF
+ END IF
+*
+* Make sure that all processes return the same # of clusters
+*
+ IF( LSAME( JOBZ, 'V' ) ) THEN
+ NCLUSTERS = 0
+ DO 90 I = 0, NPROW*NPCOL - 1
+ IF( ICLUSTR( 1+IPREPAD+2*I ).EQ.0 )
+ $ GO TO 100
+ NCLUSTERS = NCLUSTERS + 1
+ 90 CONTINUE
+ 100 CONTINUE
+ ITMP( 1 ) = NCLUSTERS
+ ITMP( 2 ) = NCLUSTERS
+*
+ CALL IGAMN2D( DESCA( CTXT_ ), 'a', ' ', 1, 1, ITMP, 1, 1, 1,
+ $ -1, -1, 0 )
+ CALL IGAMX2D( DESCA( CTXT_ ), 'a', ' ', 1, 1, ITMP( 2 ), 1,
+ $ 1, 1, -1, -1, 0 )
+*
+ IF( ITMP( 1 ).NE.ITMP( 2 ) ) THEN
+ IF( IAM.EQ.0 )
+ $ WRITE( NOUT, FMT = 9985 )
+ RESULT = 1
+ ELSE
+*
+* Make sure that different processes return the same clusters
+*
+ DO 110 I = 1, NCLUSTERS
+ IWORK( INDIWRK+I ) = ICLUSTR( I+IPREPAD )
+ IWORK( INDIWRK+I+NCLUSTERS ) = ICLUSTR( I+IPREPAD )
+ 110 CONTINUE
+ CALL IGAMN2D( DESCA( CTXT_ ), 'a', ' ', NCLUSTERS*2+1, 1,
+ $ IWORK( INDIWRK+1 ), NCLUSTERS*2+1, 1, 1,
+ $ -1, -1, 0 )
+ CALL IGAMX2D( DESCA( CTXT_ ), 'a', ' ', NCLUSTERS*2+1, 1,
+ $ IWORK( INDIWRK+1+NCLUSTERS ),
+ $ NCLUSTERS*2+1, 1, 1, -1, -1, 0 )
+*
+ DO 120 I = 1, NCLUSTERS
+ IF( RESULT.EQ.0 .AND. IWORK( INDIWRK+I ).NE.
+ $ IWORK( INDIWRK+NCLUSTERS+I ) ) THEN
+ IF( IAM.EQ.0 )
+ $ WRITE( NOUT, FMT = 9984 )
+ RESULT = 1
+ END IF
+ 120 CONTINUE
+*
+ IF( ICLUSTR( 1+IPREPAD+NCLUSTERS*2 ).NE.0 ) THEN
+ IF( IAM.EQ.0 )
+ $ WRITE( NOUT, FMT = 9983 )
+ RESULT = 1
+ END IF
+ END IF
+ END IF
+*
+ CALL IGAMX2D( DESCA( CTXT_ ), 'a', ' ', 1, 1, RESULT, 1, 1, 1,
+ $ -1, -1, 0 )
+ IF( RESULT.NE.0 )
+ $ GO TO 150
+*
+* Compute eps * norm(A)
+*
+ IF( N.EQ.0 ) THEN
+ EPSNORMA = EPS
+ ELSE
+ EPSNORMA = PDLANSY( 'I', UPLO, N, COPYA, IA, JA, DESCA,
+ $ WORK )*EPS
+ END IF
+*
+ IF( LSAME( JOBZ, 'V' ) ) THEN
+*
+* Perform the |A Z - Z W| test
+*
+ CALL PDFILLPAD( DESCA( CTXT_ ), SIZECHK, 1, WORK, SIZECHK,
+ $ IPREPAD, IPOSTPAD, 4.3D0 )
+*
+ CALL PDSEPCHK( N, NZ, COPYA, IA, JA, DESCA,
+ $ MAX( ABSTOL+EPSNORMA, SAFMIN ), THRESH,
+ $ Z( 1+IPREPAD ), IA, JA, DESCZ,
+ $ A( 1+IPREPAD ), IA, JA, DESCA,
+ $ WNEW( 1+IPREPAD ), WORK( 1+IPREPAD ),
+ $ SIZECHK, TSTNRM, RES )
+*
+ CALL PDCHEKPAD( DESCA( CTXT_ ), 'PDSEPCHK-WORK', SIZECHK, 1,
+ $ WORK, SIZECHK, IPREPAD, IPOSTPAD, 4.3D0 )
+*
+ IF( RES.NE.0 )
+ $ RESULT = 1
+*
+* Perform the |QTQ - I| test
+*
+ CALL PDFILLPAD( DESCA( CTXT_ ), SIZEQTQ, 1, WORK, SIZEQTQ,
+ $ IPREPAD, IPOSTPAD, 4.3D0 )
+*
+*
+ CALL PDSEPQTQ( N, NZ, THRESH, Z( 1+IPREPAD ), IA, JA, DESCZ,
+ $ A( 1+IPREPAD ), IA, JA, DESCA,
+ $ IWORK( 1+IPREPAD+1 ), ICLUSTR( 1+IPREPAD ),
+ $ GAP( 1+IPREPAD ), WORK( IPREPAD+1 ), SIZEQTQ,
+ $ QTQNRM, INFO, RES )
+*
+ CALL PDCHEKPAD( DESCA( CTXT_ ), 'PDSEPQTQ-WORK', SIZEQTQ, 1,
+ $ WORK, SIZEQTQ, IPREPAD, IPOSTPAD, 4.3D0 )
+*
+ IF( RES.NE.0 )
+ $ RESULT = 1
+*
+ IF( INFO.NE.0 ) THEN
+ IF( IAM.EQ.0 )
+ $ WRITE( NOUT, FMT = 9998 )INFO
+ RESULT = 1
+ END IF
+ END IF
+*
+* Check to make sure that the right eigenvalues have been obtained
+*
+ IF( WKNOWN ) THEN
+* Set up MYIL if necessary
+ MYIL = IL
+*
+ IF( LSAME( RANGE, 'V' ) ) THEN
+ MYIL = 1
+ MINIL = 1
+ MAXIL = N - M + 1
+ ELSE
+ IF( LSAME( RANGE, 'A' ) ) THEN
+ MYIL = 1
+ END IF
+ MINIL = MYIL
+ MAXIL = MYIL
+ END IF
+*
+* Find the largest difference between the computed
+* and expected eigenvalues
+*
+ MINERROR = NORMWIN
+*
+ DO 140 MYIL = MINIL, MAXIL
+ MAXERROR = 0
+*
+* Make sure that we aren't skipping any important eigenvalues
+*
+ MISSSMALLEST = .TRUE.
+ IF( .NOT.LSAME( RANGE, 'V' ) .OR. ( MYIL.EQ.1 ) )
+ $ MISSSMALLEST = .FALSE.
+ IF( MISSSMALLEST .AND. ( WIN( MYIL-1 ).LT.VL+NORMWIN*
+ $ FIVE*THRESH*EPS ) )MISSSMALLEST = .FALSE.
+ MISSLARGEST = .TRUE.
+ IF( .NOT.LSAME( RANGE, 'V' ) .OR. ( MYIL.EQ.MAXIL ) )
+ $ MISSLARGEST = .FALSE.
+ IF( MISSLARGEST .AND. ( WIN( MYIL+M ).GT.VU-NORMWIN*FIVE*
+ $ THRESH*EPS ) )MISSLARGEST = .FALSE.
+ IF( .NOT.MISSSMALLEST ) THEN
+ IF( .NOT.MISSLARGEST ) THEN
+*
+* Make sure that the eigenvalues that we report are OK
+*
+ DO 130 I = 1, M
+* WRITE(*,*) 'WIN WNEW = ', WIN( I+MYIL-1 ),
+* $ WNEW( I+IPREPAD )
+ ERROR = ABS( WIN( I+MYIL-1 )-WNEW( I+IPREPAD ) )
+ MAXERROR = MAX( MAXERROR, ERROR )
+ 130 CONTINUE
+*
+ MINERROR = MIN( MAXERROR, MINERROR )
+ END IF
+ END IF
+ 140 CONTINUE
+*
+* If JOBZ = 'V' and RANGE='A', we might be comparing
+* against our estimate of what the eigenvalues ought to
+* be, rather than comparing against what was computed
+* last time around, so we have to be more generous.
+*
+ IF( LSAME( JOBZ, 'V' ) .AND. LSAME( RANGE, 'A' ) ) THEN
+ IF( MINERROR.GT.NORMWIN*FIVE*FIVE*THRESH*EPS ) THEN
+ IF( IAM.EQ.0 )
+ $ WRITE( NOUT, FMT = 9997 )MINERROR, NORMWIN
+ RESULT = 1
+ END IF
+ ELSE
+ IF( MINERROR.GT.NORMWIN*FIVE*THRESH*EPS ) THEN
+ IF( IAM.EQ.0 )
+ $ WRITE( NOUT, FMT = 9997 )MINERROR, NORMWIN
+ RESULT = 1
+ END IF
+ END IF
+ END IF
+*
+* Make sure that the IL, IU, VL and VU were not altered
+*
+ IF( IL.NE.OLDIL .OR. IU.NE.OLDIU .OR. VL.NE.OLDVL .OR. VU.NE.
+ $ OLDVU ) THEN
+ IF( IAM.EQ.0 )
+ $ WRITE( NOUT, FMT = 9982 )
+ RESULT = 1
+ END IF
+*
+ IF( LSAME( JOBZ, 'N' ) .AND. ( NZ.NE.OLDNZ ) ) THEN
+ IF( IAM.EQ.0 )
+ $ WRITE( NOUT, FMT = 9981 )
+ RESULT = 1
+ END IF
+*
+ END IF
+*
+* All processes should report the same result
+*
+ CALL IGAMX2D( DESCA( CTXT_ ), 'a', ' ', 1, 1, RESULT, 1, 1, 1, -1,
+ $ -1, 0 )
+*
+ 150 CONTINUE
+*
+ RETURN
+*
+ 9999 FORMAT( 'PDSYEVR returned INFO=', I7 )
+ 9998 FORMAT( 'PDSEPQTQ returned INFO=', I7 )
+ 9997 FORMAT( 'PDSEPRSUBTST minerror =', D11.2, ' normwin=', D11.2 )
+ 9996 FORMAT( 'PDSYEVR returned INFO=', I7,
+ $ ' despite adequate workspace' )
+ 9995 FORMAT( 'ICLUSTR(1).NE.0 but mod(INFO/2,2).NE.1' )
+ 9994 FORMAT( 'M not in the range 0 to N' )
+ 9993 FORMAT( 'M not equal to N' )
+ 9992 FORMAT( 'M not equal to IU-IL+1' )
+ 9991 FORMAT( 'M not equal to NZ' )
+ 9990 FORMAT( 'NZ > M' )
+ 9989 FORMAT( 'NZ < M' )
+ 9988 FORMAT( 'NZ not equal to M' )
+ 9987 FORMAT( 'Different processes return different values for M' )
+ 9986 FORMAT( 'Different processes return different eigenvalues' )
+ 9985 FORMAT( 'Different processes return ',
+ $ 'different numbers of clusters' )
+ 9984 FORMAT( 'Different processes return different clusters' )
+ 9983 FORMAT( 'ICLUSTR not zero terminated' )
+ 9982 FORMAT( 'IL, IU, VL or VU altered by PDSYEVR' )
+ 9981 FORMAT( 'NZ altered by PDSYEVR with JOBZ=N' )
+*
+* End of PDSEPRSUBTST
+*
+ END
diff --git a/TESTING/EIG/pdseprtst.f b/TESTING/EIG/pdseprtst.f
new file mode 100644
index 0000000..a8700d6
--- /dev/null
+++ b/TESTING/EIG/pdseprtst.f
@@ -0,0 +1,801 @@
+ SUBROUTINE PDSEPRTST(DESCA, UPLO, N, MATTYPE, SUBTESTS, THRESH,
+ $ ORDER, ABSTOL, ISEED, A, COPYA, Z, LDA, WIN,
+ $ WNEW, IFAIL, ICLUSTR, GAP, IPREPAD, IPOSTPAD,
+ $ WORK, LWORK,
+ $ IWORK, LIWORK, HETERO, NOUT, INFO )
+*
+* -- ScaLAPACK routine (@(MODE)version *TBA*) --
+* University of California, Berkeley and
+* University of Tennessee, Knoxville.
+* October 21, 2006
+*
+ IMPLICIT NONE
+*
+* .. Scalar Arguments ..
+ CHARACTER HETERO, SUBTESTS, UPLO
+ INTEGER INFO, IPOSTPAD, IPREPAD, LDA, LIWORK, LWORK,
+ $ MATTYPE, N, NOUT, ORDER
+ DOUBLE PRECISION ABSTOL, THRESH
+* ..
+* .. Array Arguments ..
+ INTEGER DESCA( * ), ICLUSTR( * ), IFAIL( * ),
+ $ ISEED( 4 ), IWORK( * )
+ DOUBLE PRECISION A( LDA, * ), COPYA( LDA, * ), GAP( * ),
+ $ WIN( * ), WNEW( * ), WORK( * ), Z( LDA, * )
+* ..
+*
+* Purpose
+* =======
+*
+* PDSEPRTST builds a random matrix and runs PDSYEVR to
+* compute the eigenvalues and eigenvectors. Then it performs two tests
+* to determine if the result is good enough. The two tests are:
+* |AQ -QL| / (abstol + ulp * norm(A) )
+* and
+* |QT * Q - I| / ulp * norm(A)
+*
+* The random matrix built depends upon the following parameters:
+* N, NB, ISEED, ORDER
+*
+* Arguments
+* =========
+*
+* NP = the number of rows local to a given process.
+* NQ = the number of columns local to a given process.
+*
+* DESCA (global and local input) INTEGER array of dimension DLEN_
+* The array descriptor for the distributed matrices
+*
+* UPLO (global input) CHARACTER*1
+* Specifies whether the upper or lower triangular part of the
+* matrix A is stored:
+* = 'U': Upper triangular
+* = 'L': Lower triangular
+*
+* N (global input) INTEGER
+* Size of the matrix to be tested. (global size)
+*
+* MATTYPE (global input) INTEGER
+* Matrix type
+* Currently, the list of possible types is:
+*
+* (1) The zero matrix.
+* (2) The identity matrix.
+*
+* (3) A diagonal matrix with evenly spaced entries
+* 1, ..., ULP and random signs.
+* (ULP = (first number larger than 1) - 1 )
+* (4) A diagonal matrix with geometrically spaced entries
+* 1, ..., ULP and random signs.
+* (5) A diagonal matrix with "clustered" entries 1, ULP, ..., ULP
+* and random signs.
+*
+* (6) Same as (4), but multiplied by SQRT( overflow threshold )
+* (7) Same as (4), but multiplied by SQRT( underflow threshold )
+*
+* (8) A matrix of the form U' D U, where U is orthogonal and
+* D has evenly spaced entries 1, ..., ULP with random signs
+* on the diagonal.
+*
+* (9) A matrix of the form U' D U, where U is orthogonal and
+* D has geometrically spaced entries 1, ..., ULP with random
+* signs on the diagonal.
+*
+* (10) A matrix of the form U' D U, where U is orthogonal and
+* D has "clustered" entries 1, ULP,..., ULP with random
+* signs on the diagonal.
+*
+* (11) Same as (8), but multiplied by SQRT( overflow threshold )
+* (12) Same as (8), but multiplied by SQRT( underflow threshold )
+*
+* (13) A matrix with random entries chosen from (-1,1).
+* (14) Same as (13), but multiplied by SQRT( overflow threshold )
+* (15) Same as (13), but multiplied by SQRT( underflow threshold )
+* (16) Same as (8), but diagonal elements are all positive.
+* (17) Same as (9), but diagonal elements are all positive.
+* (18) Same as (10), but diagonal elements are all positive.
+* (19) Same as (16), but multiplied by SQRT( overflow threshold )
+* (20) Same as (16), but multiplied by SQRT( underflow threshold )
+* (21) A tridiagonal matrix that is a direct sum of smaller diagonally
+* dominant submatrices. Each unreduced submatrix has geometrically
+* spaced diagonal entries 1, ..., ULP.
+* (22) A matrix of the form U' D U, where U is orthogonal and
+* D has ceil(lgN) "clusters" at 0,1,2,...,ceil(lgN)-1. The
+* size of the cluster at the value I is 2^I.
+*
+* SUBTESTS (global input) CHARACTER*1
+* 'Y' - Perform subset tests
+* 'N' - Do not perform subset tests
+*
+* THRESH (global input) DOUBLE PRECISION
+* A test will count as "failed" if the "error", computed as
+* described below, exceeds THRESH. Note that the error
+* is scaled to be O(1), so THRESH should be a reasonably
+* small multiple of 1, e.g., 10 or 100. In particular,
+* it should not depend on the precision (single vs. double)
+* or the size of the matrix. It must be at least zero.
+*
+* ORDER (global input) INTEGER
+* Number of reflectors used in test matrix creation.
+* If ORDER is large, it will
+* take more time to create the test matrices but they will
+* be closer to random.
+* ORDER .lt. N not implemented
+*
+* ABSTOL (global input) DOUBLE PRECISION
+* For the purposes of this test, ABSTOL=0.0 is fine.
+* THis test does not test for high relative accuracy.
+*
+* ISEED (global input/output) INTEGER array, dimension (4)
+* On entry, the seed of the random number generator; the array
+* elements must be between 0 and 4095, and ISEED(4) must be
+* odd.
+* On exit, the seed is updated.
+*
+* A (local workspace) DOUBLE PRECISION array, dim (N*N)
+* global dimension (N, N), local dimension (LDA, NQ)
+* The test matrix, which is then overwritten.
+* A is distributed in a block cyclic manner over both rows
+* and columns. The actual location of a particular element
+* in A is controlled by the values of NPROW, NPCOL, and NB.
+*
+* COPYA (local workspace) DOUBLE PRECISION array, dim (N, N)
+* COPYA is used to hold an identical copy of the array A
+* identical in both form and content to A
+*
+* Z (local workspace) DOUBLE PRECISION array, dim (N*N)
+* Z is distributed in the same manner as A
+* Z is used as workspace by the test routines
+* PDSEPCHK and PDSEPQTQ
+*
+* W (local workspace) DOUBLE PRECISION array, dimension (N)
+* On normal exit, the first M entries
+* contain the selected eigenvalues in ascending order.
+*
+* IFAIL (global workspace) INTEGER array, dimension (N)
+* Not used, only for backward compatibility
+*
+* WORK (local workspace) DOUBLE PRECISION array, dimension (LWORK)
+*
+* LWORK (local input) INTEGER
+* The length of the array WORK. LWORK >= SIZETST as
+* returned by PDLASIZESEPR
+*
+* IWORK (local workspace) INTEGER array, dimension (LIWORK)
+*
+* LIWORK (local input) INTEGER
+* The length of the array IWORK. LIWORK >= ISIZETST as
+* returned by PDLASIZESEPR
+*
+* HETERO (input) INTEGER
+*
+* NOUT (local input) INTEGER
+* The unit number for output file. Only used on node 0.
+* NOUT = 6, output to screen,
+* NOUT = 0, output to stderr.
+* NOUT = 13, output to file, divide thresh by 10.0
+* NOUT = 14, output to file, divide thresh by 20.0
+* (This hack allows us to test more stringently internally
+* so that when errors on found on other computers they will
+* be serious enough to warrant our attention.)
+*
+* INFO (global output) INTEGER
+* -3 This process is not involved
+* 0 Test succeeded (passed |AQ -QL| and |QT*Q - I| tests)
+* 1 At least one test failed
+* 2 Residual test were not performed, thresh <= 0.0
+* 3 Test was skipped because of inadequate memory space
+*
+* .. Parameters ..
+ INTEGER CTXT_, MB_, NB_, RSRC_, CSRC_, LLD_
+ PARAMETER ( CTXT_ = 2, MB_ = 5, NB_ = 6,
+ $ RSRC_ = 7, CSRC_ = 8, LLD_ = 9 )
+ DOUBLE PRECISION HALF, ONE, TEN, ZERO
+ PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0,
+ $ TEN = 10.0D0, HALF = 0.5D0 )
+ DOUBLE PRECISION PADVAL
+ PARAMETER ( PADVAL = 19.25D0 )
+ INTEGER MAXTYP
+ PARAMETER ( MAXTYP = 22 )
+* ..
+*
+* .. Local Scalars ..
+ LOGICAL WKNOWN
+ CHARACTER JOBZ, RANGE
+ CHARACTER*14 PASSED
+ INTEGER CONTEXT, I, IAM, IHETERO, IINFO, IL, IMODE, IN,
+ $ INDD, INDWORK, ISIZESUBTST, ISIZEEVR,
+ $ ISIZETST, ITYPE, IU, J, LLWORK, LEVRSIZE,
+ $ MAXSIZE, MYCOL, MYROW, NB, NGEN, NLOC,
+ $ NNODES, NP, NPCOL, NPROW, NQ, RES, SIZECHK,
+ $ SIZEMQRLEFT, SIZEMQRRIGHT, SIZEQRF, SIZEQTQ,
+ $ SIZESUBTST, SIZEEVR, SIZETMS,
+ $ SIZETST, VALSIZE, VECSIZE
+ DOUBLE PRECISION ANINV, ANORM, COND, MAXQTQNRM, MAXTSTNRM, OVFL,
+ $ QTQNRM, RTOVFL, RTUNFL, TEMP1, TSTNRM, ULP,
+ $ ULPINV, UNFL, VL, VU
+* ..
+* .. Local Arrays ..
+ INTEGER ISEEDIN( 4 ), KMAGN( MAXTYP ), KMODE( MAXTYP ),
+ $ KTYPE( MAXTYP )
+ DOUBLE PRECISION CTIME( 10 ), WTIME( 10 )
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ INTEGER NUMROC
+ DOUBLE PRECISION DLARAN, PDLAMCH
+ EXTERNAL DLARAN, LSAME, NUMROC, PDLAMCH
+* ..
+* .. External Subroutines ..
+ EXTERNAL BLACS_GRIDINFO, BLACS_PINFO, DLABAD, DLASRT,
+ $ DLATMS, IGAMX2D, IGEBR2D, IGEBS2D, PDCHEKPAD,
+ $ PDELSET, PDFILLPAD, PDLASET, PDLASIZESEPR,
+ $ PDLASIZESYEVR, PDLATMS, PDMATGEN, PDSEPRSUBTST,
+ $ SLCOMBINE
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, DBLE, INT, MAX, MIN, SQRT
+* ..
+* .. Data statements ..
+ DATA KTYPE / 1, 2, 4, 4, 4, 4, 4, 5, 5, 5, 5, 5, 8,
+ $ 8, 8, 9, 9, 9, 9, 9, 10, 11 /
+ DATA KMAGN / 1, 1, 1, 1, 1, 2, 3, 1, 1, 1, 2, 3, 1,
+ $ 2, 3, 1, 1, 1, 2, 3, 1, 1 /
+ DATA KMODE / 0, 0, 4, 3, 1, 4, 4, 4, 3, 1, 4, 4, 0,
+ $ 0, 0, 4, 3, 1, 4, 4, 3, 0 /
+* ..
+* .. Executable Statements ..
+*
+ INFO = 0
+ PASSED = 'PASSED EVR'
+ CONTEXT = DESCA( CTXT_ )
+ NB = DESCA( NB_ )
+*
+ CALL BLACS_PINFO( IAM, NNODES )
+ CALL BLACS_GRIDINFO( CONTEXT, NPROW, NPCOL, MYROW, MYCOL )
+*
+* Distribute HETERO across processes
+*
+ IF( IAM.EQ.0 ) THEN
+ IF( LSAME( HETERO, 'Y' ) ) THEN
+ IHETERO = 2
+ ELSE
+ IHETERO = 1
+ END IF
+ CALL IGEBS2D( CONTEXT, 'All', ' ', 1, 1, IHETERO, 1 )
+ ELSE
+ CALL IGEBR2D( CONTEXT, 'All', ' ', 1, 1, IHETERO, 1, 0, 0 )
+ END IF
+ IF( IHETERO.EQ.2 ) THEN
+ HETERO = 'Y'
+ ELSE
+ HETERO = 'N'
+ END IF
+*
+* Make sure that there is enough memory
+*
+ CALL PDLASIZESEPR( DESCA, IPREPAD, IPOSTPAD, SIZEMQRLEFT,
+ $ SIZEMQRRIGHT, SIZEQRF, SIZETMS, SIZEQTQ,
+ $ SIZECHK, SIZEEVR, ISIZEEVR,
+ $ SIZESUBTST,
+ $ ISIZESUBTST, SIZETST, ISIZETST )
+ IF( LWORK.LT.SIZETST ) THEN
+ INFO = 3
+ END IF
+*
+ CALL IGAMX2D( CONTEXT, 'a', ' ', 1, 1, INFO, 1, 1, 1, -1, -1, 0 )
+*
+ IF( INFO.EQ.0 ) THEN
+*
+ INDD = 1
+ INDWORK = INDD + N
+ LLWORK = LWORK - INDWORK + 1
+*
+ ULP = PDLAMCH( CONTEXT, 'P' )
+ ULPINV = ONE / ULP
+ UNFL = PDLAMCH( CONTEXT, 'Safe min' )
+ OVFL = ONE / UNFL
+ CALL DLABAD( UNFL, OVFL )
+ RTUNFL = SQRT( UNFL )
+ RTOVFL = SQRT( OVFL )
+ ANINV = ONE / DBLE( MAX( 1, N ) )
+*
+* This ensures that everyone starts out with the same seed.
+*
+ IF( MYROW.EQ.0 .AND. MYCOL.EQ.0 ) THEN
+ CALL IGEBS2D( CONTEXT, 'a', ' ', 4, 1, ISEED, 4 )
+ ELSE
+ CALL IGEBR2D( CONTEXT, 'a', ' ', 4, 1, ISEED, 4, 0, 0 )
+ END IF
+ ISEEDIN( 1 ) = ISEED( 1 )
+ ISEEDIN( 2 ) = ISEED( 2 )
+ ISEEDIN( 3 ) = ISEED( 3 )
+ ISEEDIN( 4 ) = ISEED( 4 )
+*
+* Compute the matrix A
+*
+* Control parameters:
+*
+* KMAGN KMODE KTYPE
+* =1 O(1) clustered 1 zero
+* =2 large clustered 2 identity
+* =3 small exponential (none)
+* =4 arithmetic diagonal, (w/ eigenvalues)
+* =5 random log symmetric, w/ eigenvalues
+* =6 random (none)
+* =7 random diagonal
+* =8 random symmetric
+* =9 positive definite
+* =10 block diagonal with tridiagonal blocks
+* =11 Geometrically sized clusters.
+*
+ ITYPE = KTYPE( MATTYPE )
+ IMODE = KMODE( MATTYPE )
+*
+* Compute norm
+*
+ GO TO ( 10, 20, 30 )KMAGN( MATTYPE )
+*
+ 10 CONTINUE
+ ANORM = ONE
+ GO TO 40
+*
+ 20 CONTINUE
+ ANORM = ( RTOVFL*ULP )*ANINV
+ GO TO 40
+*
+ 30 CONTINUE
+ ANORM = RTUNFL*N*ULPINV
+ GO TO 40
+*
+ 40 CONTINUE
+ IF( MATTYPE.LE.15 ) THEN
+ COND = ULPINV
+ ELSE
+ COND = ULPINV*ANINV / TEN
+ END IF
+*
+* Special Matrices
+*
+ IF( ITYPE.EQ.1 ) THEN
+*
+* Zero Matrix
+*
+ DO 50 I = 1, N
+ WORK( INDD+I-1 ) = ZERO
+ 50 CONTINUE
+ CALL PDLASET( 'All', N, N, ZERO, ZERO, COPYA, 1, 1, DESCA )
+ WKNOWN = .TRUE.
+*
+ ELSE IF( ITYPE.EQ.2 ) THEN
+*
+* Identity Matrix
+*
+ DO 60 I = 1, N
+ WORK( INDD+I-1 ) = ONE
+ 60 CONTINUE
+ CALL PDLASET( 'All', N, N, ZERO, ONE, COPYA, 1, 1, DESCA )
+ WKNOWN = .TRUE.
+*
+ ELSE IF( ITYPE.EQ.4 ) THEN
+*
+* Diagonal Matrix, [Eigen]values Specified
+*
+ CALL PDFILLPAD( DESCA( CTXT_ ), SIZETMS, 1, WORK( INDWORK ),
+ $ SIZETMS, IPREPAD, IPOSTPAD, PADVAL+1.0D0 )
+*
+ CALL PDLATMS( N, N, 'S', ISEED, 'S', WORK( INDD ), IMODE,
+ $ COND, ANORM, 0, 0, 'N', COPYA, 1, 1, DESCA,
+ $ ORDER, WORK( INDWORK+IPREPAD ), SIZETMS,
+ $ IINFO )
+ WKNOWN = .TRUE.
+*
+ CALL PDCHEKPAD( DESCA( CTXT_ ), 'PDLATMS1-WORK', SIZETMS, 1,
+ $ WORK( INDWORK ), SIZETMS, IPREPAD, IPOSTPAD,
+ $ PADVAL+1.0D0 )
+*
+ ELSE IF( ITYPE.EQ.5 ) THEN
+*
+* symmetric, eigenvalues specified
+*
+ CALL PDFILLPAD( DESCA( CTXT_ ), SIZETMS, 1, WORK( INDWORK ),
+ $ SIZETMS, IPREPAD, IPOSTPAD, PADVAL+2.0D0 )
+*
+ CALL PDLATMS( N, N, 'S', ISEED, 'S', WORK( INDD ), IMODE,
+ $ COND, ANORM, N, N, 'N', COPYA, 1, 1, DESCA,
+ $ ORDER, WORK( INDWORK+IPREPAD ), SIZETMS,
+ $ IINFO )
+*
+ CALL PDCHEKPAD( DESCA( CTXT_ ), 'PDLATMS2-WORK', SIZETMS, 1,
+ $ WORK( INDWORK ), SIZETMS, IPREPAD, IPOSTPAD,
+ $ PADVAL+2.0D0 )
+*
+ WKNOWN = .TRUE.
+*
+ ELSE IF( ITYPE.EQ.8 ) THEN
+*
+* symmetric, random eigenvalues
+*
+ NP = NUMROC( N, DESCA( MB_ ), MYROW, 0, NPROW )
+ NQ = NUMROC( N, DESCA( NB_ ), MYCOL, 0, NPCOL )
+ CALL PDMATGEN( DESCA( CTXT_ ), 'S', 'N', N, N, DESCA( MB_ ),
+ $ DESCA( NB_ ), COPYA, DESCA( LLD_ ),
+ $ DESCA( RSRC_ ), DESCA( CSRC_ ), ISEED( 1 ),
+ $ 0, NP, 0, NQ, MYROW, MYCOL, NPROW, NPCOL )
+ INFO = 0
+ WKNOWN = .FALSE.
+*
+ ELSE IF( ITYPE.EQ.9 ) THEN
+*
+* Positive definite, eigenvalues specified.
+*
+ CALL PDFILLPAD( DESCA( CTXT_ ), SIZETMS, 1, WORK( INDWORK ),
+ $ SIZETMS, IPREPAD, IPOSTPAD, PADVAL+3.0D0 )
+*
+ CALL PDLATMS( N, N, 'S', ISEED, 'S', WORK( INDD ), IMODE,
+ $ COND, ANORM, N, N, 'N', COPYA, 1, 1, DESCA,
+ $ ORDER, WORK( INDWORK+IPREPAD ), SIZETMS,
+ $ IINFO )
+*
+ WKNOWN = .TRUE.
+*
+ CALL PDCHEKPAD( DESCA( CTXT_ ), 'PDLATMS3-WORK', SIZETMS, 1,
+ $ WORK( INDWORK ), SIZETMS, IPREPAD, IPOSTPAD,
+ $ PADVAL+3.0D0 )
+*
+ ELSE IF( ITYPE.EQ.10 ) THEN
+*
+* Block diagonal matrix with each block being a positive
+* definite tridiagonal submatrix.
+*
+ CALL PDLASET( 'All', N, N, ZERO, ZERO, COPYA, 1, 1, DESCA )
+ NP = NUMROC( N, DESCA( MB_ ), 0, 0, NPROW )
+ NQ = NUMROC( N, DESCA( NB_ ), 0, 0, NPCOL )
+ NLOC = MIN( NP, NQ )
+ NGEN = 0
+ 70 CONTINUE
+*
+ IF( NGEN.LT.N ) THEN
+ IN = MIN( 1+INT( DLARAN( ISEED )*DBLE( NLOC ) ), N-NGEN )
+*
+ CALL DLATMS( IN, IN, 'S', ISEED, 'P', WORK( INDD ),
+ $ IMODE, COND, ANORM, 1, 1, 'N', A, LDA,
+ $ WORK( INDWORK ), IINFO )
+*
+ DO 80 I = 2, IN
+ TEMP1 = ABS( A( I-1, I ) ) /
+ $ SQRT( ABS( A( I-1, I-1 )*A( I, I ) ) )
+ IF( TEMP1.GT.HALF ) THEN
+ A( I-1, I ) = HALF*SQRT( ABS( A( I-1, I-1 )*A( I,
+ $ I ) ) )
+ A( I, I-1 ) = A( I-1, I )
+ END IF
+ 80 CONTINUE
+ CALL PDELSET( COPYA, NGEN+1, NGEN+1, DESCA, A( 1, 1 ) )
+ DO 90 I = 2, IN
+ CALL PDELSET( COPYA, NGEN+I, NGEN+I, DESCA,
+ $ A( I, I ) )
+ CALL PDELSET( COPYA, NGEN+I-1, NGEN+I, DESCA,
+ $ A( I-1, I ) )
+ CALL PDELSET( COPYA, NGEN+I, NGEN+I-1, DESCA,
+ $ A( I, I-1 ) )
+ 90 CONTINUE
+ NGEN = NGEN + IN
+ GO TO 70
+ END IF
+ WKNOWN = .FALSE.
+*
+ ELSE IF( ITYPE.EQ.11 ) THEN
+*
+* Geometrically sized clusters. Eigenvalues: 0,1,1,2,2,2,2,...
+*
+ NGEN = 0
+ J = 1
+ TEMP1 = ZERO
+ 100 CONTINUE
+ IF( NGEN.LT.N ) THEN
+ IN = MIN( J, N-NGEN )
+ DO 110 I = 0, IN - 1
+ WORK( INDD+NGEN+I ) = TEMP1
+ 110 CONTINUE
+ TEMP1 = TEMP1 + ONE
+ J = 2*J
+ NGEN = NGEN + IN
+ GO TO 100
+ END IF
+*
+ CALL PDFILLPAD( DESCA( CTXT_ ), SIZETMS, 1, WORK( INDWORK ),
+ $ SIZETMS, IPREPAD, IPOSTPAD, PADVAL+4.0D0 )
+*
+ CALL PDLATMS( N, N, 'S', ISEED, 'S', WORK( INDD ), IMODE,
+ $ COND, ANORM, 0, 0, 'N', COPYA, 1, 1, DESCA,
+ $ ORDER, WORK( INDWORK+IPREPAD ), SIZETMS,
+ $ IINFO )
+*
+ CALL PDCHEKPAD( DESCA( CTXT_ ), 'PDLATMS4-WORK', SIZETMS, 1,
+ $ WORK( INDWORK ), SIZETMS, IPREPAD, IPOSTPAD,
+ $ PADVAL+4.0D0 )
+*
+ ELSE
+ IINFO = 1
+ END IF
+*
+ IF( WKNOWN )
+ $ CALL DLASRT( 'I', N, WORK( INDD ), IINFO )
+*
+ CALL PDLASIZESYEVR( WKNOWN, 'A', N, DESCA, VL, VU, IL, IU,
+ $ ISEED, WORK( INDD ), MAXSIZE, VECSIZE,
+ $ VALSIZE )
+ LEVRSIZE = MIN( MAXSIZE, LLWORK )
+*
+ CALL PDSEPRSUBTST( WKNOWN, 'v', 'a', UPLO, N, VL, VU, IL, IU,
+ $ THRESH, ABSTOL, A, COPYA, Z, 1, 1, DESCA,
+ $ WORK( INDD ), WIN, IFAIL, ICLUSTR, GAP,
+ $ IPREPAD, IPOSTPAD, WORK( INDWORK ), LLWORK,
+ $ LEVRSIZE, IWORK, ISIZEEVR, RES, TSTNRM,
+ $ QTQNRM, NOUT )
+*
+ MAXTSTNRM = TSTNRM
+ MAXQTQNRM = QTQNRM
+*
+ IF( THRESH.LE.ZERO ) THEN
+ PASSED = 'SKIPPED '
+ INFO = 2
+ ELSE IF( RES.NE.0 ) THEN
+ PASSED = 'FAILED '
+ INFO = 1
+ END IF
+ END IF
+*
+ IF( THRESH.GT.ZERO .AND. LSAME( SUBTESTS, 'Y' ) ) THEN
+*
+* Subtest 1: JOBZ = 'N', RANGE = 'A', minimum memory
+*
+ IF( INFO.EQ.0 ) THEN
+*
+ JOBZ = 'N'
+ RANGE = 'A'
+ CALL PDLASIZESYEVR( .TRUE., RANGE, N, DESCA, VL, VU, IL, IU,
+ $ ISEED, WIN( 1+IPREPAD ), MAXSIZE,
+ $ VECSIZE, VALSIZE )
+*
+ LEVRSIZE = VALSIZE
+*
+ CALL PDSEPRSUBTST( .TRUE., JOBZ, RANGE, UPLO, N, VL, VU, IL,
+ $ IU, THRESH, ABSTOL, A, COPYA, Z, 1, 1,
+ $ DESCA, WIN( 1+IPREPAD ), WNEW, IFAIL,
+ $ ICLUSTR, GAP, IPREPAD, IPOSTPAD,
+ $ WORK( INDWORK ), LLWORK, LEVRSIZE,
+ $ IWORK, ISIZEEVR, RES, TSTNRM, QTQNRM,
+ $ NOUT )
+*
+ IF( RES.NE.0 ) THEN
+ MAXTSTNRM = MAX( TSTNRM, MAXTSTNRM )
+ MAXQTQNRM = MAX( QTQNRM, MAXQTQNRM )
+ PASSED = 'FAILED stest 1'
+ INFO = 1
+ END IF
+ END IF
+*
+* Subtest 2: JOBZ = 'N', RANGE = 'I', minimum memory
+*
+ IF( INFO.EQ.0 ) THEN
+*
+ IL = -1
+ IU = -1
+ JOBZ = 'N'
+ RANGE = 'I'
+*
+* Use PDLASIZESYEVR to choose IL and IU.
+*
+ CALL PDLASIZESYEVR( .TRUE., RANGE, N, DESCA, VL, VU, IL, IU,
+ $ ISEED, WIN( 1+IPREPAD ), MAXSIZE,
+ $ VECSIZE, VALSIZE )
+*
+ LEVRSIZE = VALSIZE
+*
+ CALL PDSEPRSUBTST( .TRUE., JOBZ, RANGE, UPLO, N, VL, VU, IL,
+ $ IU, THRESH, ABSTOL, A, COPYA, Z, 1, 1,
+ $ DESCA, WIN( 1+IPREPAD ), WNEW, IFAIL,
+ $ ICLUSTR, GAP, IPREPAD, IPOSTPAD,
+ $ WORK( INDWORK ), LLWORK, LEVRSIZE,
+ $ IWORK, ISIZEEVR, RES, TSTNRM, QTQNRM,
+ $ NOUT )
+*
+ IF( RES.NE.0 ) THEN
+ MAXTSTNRM = MAX( TSTNRM, MAXTSTNRM )
+ MAXQTQNRM = MAX( QTQNRM, MAXQTQNRM )
+ PASSED = 'FAILED stest 2'
+ INFO = 1
+ END IF
+ END IF
+*
+* Subtest 3: JOBZ = 'V', RANGE = 'I', minimum memory
+*
+ IF( INFO.EQ.0 ) THEN
+ IL = -1
+ IU = -1
+ JOBZ = 'V'
+ RANGE = 'I'
+*
+* We use PDLASIZESYEVR to choose IL and IU for us.
+*
+ CALL PDLASIZESYEVR( .TRUE., RANGE, N, DESCA, VL, VU, IL, IU,
+ $ ISEED, WIN( 1+IPREPAD ), MAXSIZE,
+ $ VECSIZE, VALSIZE )
+*
+ LEVRSIZE = VECSIZE
+*
+ CALL PDSEPRSUBTST( .TRUE., JOBZ, RANGE, UPLO, N, VL, VU, IL,
+ $ IU, THRESH, ABSTOL, A, COPYA, Z, 1, 1,
+ $ DESCA, WIN( 1+IPREPAD ), WNEW, IFAIL,
+ $ ICLUSTR, GAP, IPREPAD, IPOSTPAD,
+ $ WORK( INDWORK ), LLWORK, LEVRSIZE,
+ $ IWORK, ISIZEEVR, RES, TSTNRM, QTQNRM,
+ $ NOUT )
+*
+ IF( RES.NE.0 ) THEN
+ MAXTSTNRM = MAX( TSTNRM, MAXTSTNRM )
+ MAXQTQNRM = MAX( QTQNRM, MAXQTQNRM )
+ PASSED = 'FAILED stest 3'
+ INFO = 1
+ END IF
+ END IF
+*
+* Subtest 4: JOBZ = 'N', RANGE = 'V', minimum memory
+*
+ IF( INFO.EQ.0 ) THEN
+ VL = ONE
+ VU = -ONE
+ JOBZ = 'N'
+ RANGE = 'V'
+*
+* We use PDLASIZESYEVR to choose IL and IU for us.
+*
+ CALL PDLASIZESYEVR( .TRUE., RANGE, N, DESCA, VL, VU, IL, IU,
+ $ ISEED, WIN( 1+IPREPAD ), MAXSIZE,
+ $ VECSIZE, VALSIZE )
+*
+ LEVRSIZE = VALSIZE
+*
+ CALL PDSEPRSUBTST( .TRUE., JOBZ, RANGE, UPLO, N, VL, VU, IL,
+ $ IU, THRESH, ABSTOL, A, COPYA, Z, 1, 1,
+ $ DESCA, WIN( 1+IPREPAD ), WNEW, IFAIL,
+ $ ICLUSTR, GAP, IPREPAD, IPOSTPAD,
+ $ WORK( INDWORK ), LLWORK, LEVRSIZE,
+ $ IWORK, ISIZEEVR, RES, TSTNRM, QTQNRM,
+ $ NOUT )
+*
+ IF( RES.NE.0 ) THEN
+ MAXTSTNRM = MAX( TSTNRM, MAXTSTNRM )
+ MAXQTQNRM = MAX( QTQNRM, MAXQTQNRM )
+ PASSED = 'FAILED stest 4'
+ INFO = 1
+ END IF
+ END IF
+*
+* Subtest 5: JOBZ = 'V', RANGE = 'V', minimum memory
+*
+ IF( INFO.EQ.0 ) THEN
+ VL = ONE
+ VU = -ONE
+ JOBZ = 'V'
+ RANGE = 'V'
+*
+* We use PDLASIZESYEVR to choose VL and VU for us.
+*
+ CALL PDLASIZESYEVR( .TRUE., RANGE, N, DESCA, VL, VU, IL, IU,
+ $ ISEED, WIN( 1+IPREPAD ), MAXSIZE,
+ $ VECSIZE, VALSIZE )
+*
+ LEVRSIZE = VECSIZE
+*
+ CALL PDSEPRSUBTST( .TRUE., JOBZ, RANGE, UPLO, N, VL, VU, IL,
+ $ IU, THRESH, ABSTOL, A, COPYA, Z, 1, 1,
+ $ DESCA, WIN( 1+IPREPAD ), WNEW, IFAIL,
+ $ ICLUSTR, GAP, IPREPAD, IPOSTPAD,
+ $ WORK( INDWORK ), LLWORK, LEVRSIZE,
+ $ IWORK, ISIZEEVR, RES, TSTNRM, QTQNRM,
+ $ NOUT )
+*
+ IF( RES.NE.0 ) THEN
+ MAXTSTNRM = MAX( TSTNRM, MAXTSTNRM )
+ MAXQTQNRM = MAX( QTQNRM, MAXQTQNRM )
+ PASSED = 'FAILED stest 5'
+ INFO = 1
+ END IF
+ END IF
+ END IF
+*
+ CALL IGAMX2D( CONTEXT, 'All', ' ', 1, 1, INFO, 1, -1, -1, -1, -1,
+ $ -1 )
+ IF( INFO.EQ.1 ) THEN
+ IF( IAM.EQ.0 .AND. .FALSE. ) THEN
+ WRITE( NOUT, FMT = 9994 )'C '
+ WRITE( NOUT, FMT = 9993 )ISEEDIN( 1 )
+ WRITE( NOUT, FMT = 9992 )ISEEDIN( 2 )
+ WRITE( NOUT, FMT = 9991 )ISEEDIN( 3 )
+ WRITE( NOUT, FMT = 9990 )ISEEDIN( 4 )
+ IF( LSAME( UPLO, 'L' ) ) THEN
+ WRITE( NOUT, FMT = 9994 )' UPLO= ''L'' '
+ ELSE
+ WRITE( NOUT, FMT = 9994 )' UPLO= ''U'' '
+ END IF
+ IF( LSAME( SUBTESTS, 'Y' ) ) THEN
+ WRITE( NOUT, FMT = 9994 )' SUBTESTS= ''Y'' '
+ ELSE
+ WRITE( NOUT, FMT = 9994 )' SUBTESTS= ''N'' '
+ END IF
+ WRITE( NOUT, FMT = 9989 )N
+ WRITE( NOUT, FMT = 9988 )NPROW
+ WRITE( NOUT, FMT = 9987 )NPCOL
+ WRITE( NOUT, FMT = 9986 )NB
+ WRITE( NOUT, FMT = 9985 )MATTYPE
+ WRITE( NOUT, FMT = 9982 )ABSTOL
+ WRITE( NOUT, FMT = 9981 )THRESH
+ WRITE( NOUT, FMT = 9994 )'C '
+ END IF
+ END IF
+*
+ CALL SLCOMBINE( CONTEXT, 'All', '>', 'W', 6, 1, WTIME )
+ CALL SLCOMBINE( CONTEXT, 'All', '>', 'C', 6, 1, CTIME )
+ IF( IAM.EQ.0 ) THEN
+ IF( INFO.EQ.0 .OR. INFO.EQ.1 ) THEN
+ IF( WTIME( 1 ).GE.0.0 ) THEN
+ WRITE( NOUT, FMT = 9999 )N, NB, NPROW, NPCOL, MATTYPE,
+ $ SUBTESTS, WTIME( 1 ), CTIME( 1 ), MAXTSTNRM,
+ $ MAXQTQNRM, PASSED
+ ELSE
+ WRITE( NOUT, FMT = 9998 )N, NB, NPROW, NPCOL, MATTYPE,
+ $ SUBTESTS, CTIME( 1 ), MAXTSTNRM, MAXQTQNRM, PASSED
+ END IF
+ ELSE IF( INFO.EQ.2 ) THEN
+ IF( WTIME( 1 ).GE.0.0 ) THEN
+ WRITE( NOUT, FMT = 9997 )N, NB, NPROW, NPCOL, MATTYPE,
+ $ SUBTESTS, WTIME( 1 ), CTIME( 1 )
+ ELSE
+ WRITE( NOUT, FMT = 9996 )N, NB, NPROW, NPCOL, MATTYPE,
+ $ SUBTESTS, CTIME( 1 )
+ END IF
+ ELSE IF( INFO.EQ.3 ) THEN
+ WRITE( NOUT, FMT = 9995 )N, NB, NPROW, NPCOL, MATTYPE,
+ $ SUBTESTS
+ END IF
+C WRITE(*,*)'************************************************'
+ END IF
+*
+
+ RETURN
+ 9999 FORMAT( 1X, I5, 1X, I3, 1X, I3, 1X, I3, 1X, I3, 3X, A1, 1X,
+ $ F8.2, 1X, F8.2, 1X, G9.2, 1X, G9.2, 1X, A14 )
+ 9998 FORMAT( 1X, I5, 1X, I3, 1X, I3, 1X, I3, 1X, I3, 3X, A1, 1X, 8X,
+ $ 1X, F8.2, 1X, G9.2, 1X, G9.2, A14 )
+ 9997 FORMAT( 1X, I5, 1X, I3, 1X, I3, 1X, I3, 1X, I3, 3X, A1, 1X, F8.2,
+ $ 1X, F8.2, 21X, 'Bypassed' )
+ 9996 FORMAT( 1X, I5, 1X, I3, 1X, I3, 1X, I3, 1X, I3, 3X, A1, 1X, 8X,
+ $ 1X, F8.2, 21X, 'Bypassed' )
+ 9995 FORMAT( 1X, I5, 1X, I3, 1X, I3, 1X, I3, 1X, I3, 3X, A1, 32X,
+ $ 'Bad MEMORY parameters' )
+ 9994 FORMAT( A )
+ 9993 FORMAT( ' ISEED( 1 ) =', I8 )
+ 9992 FORMAT( ' ISEED( 2 ) =', I8 )
+ 9991 FORMAT( ' ISEED( 3 ) =', I8 )
+ 9990 FORMAT( ' ISEED( 4 ) =', I8 )
+ 9989 FORMAT( ' N=', I8 )
+ 9988 FORMAT( ' NPROW=', I8 )
+ 9987 FORMAT( ' NPCOL=', I8 )
+ 9986 FORMAT( ' NB=', I8 )
+ 9985 FORMAT( ' MATTYPE=', I8 )
+C 9984 FORMAT( ' IBTYPE=', I8 )
+C 9983 FORMAT( ' SUBTESTS=', A1 )
+ 9982 FORMAT( ' ABSTOL=', D16.6 )
+ 9981 FORMAT( ' THRESH=', D16.6 )
+C 9980 FORMAT( ' Increase TOTMEM in PDSEPRDRIVER' )
+*
+* End of PDSEPRTST
+*
+ END
+
+
+
+
diff --git a/TESTING/EIG/pdseptst.f b/TESTING/EIG/pdseptst.f
index fd6cb94..1746d66 100644
--- a/TESTING/EIG/pdseptst.f
+++ b/TESTING/EIG/pdseptst.f
@@ -533,6 +533,10 @@
$ WORK( INDWORK ), SIZETMS, IPREPAD, IPOSTPAD,
$ PADVAL+4.0D+0 )
*
+*
+* WKNOWN ... NOT SET, GUESS A DEFAULT
+*
+ WKNOWN = .TRUE.
ELSE
IINFO = 1
END IF
diff --git a/TESTING/EIG/pdsvdtst.f b/TESTING/EIG/pdsvdtst.f
index b1fbb9b..e1b8345 100644
--- a/TESTING/EIG/pdsvdtst.f
+++ b/TESTING/EIG/pdsvdtst.f
@@ -643,7 +643,7 @@
CALL BLACS_GRIDEXIT( CONTEXT )
110 CONTINUE
*
- 9999 FORMAT( A6, 2E10.4, 2I6, 2I4, I5, I6, 3F6.2, 4X, A1 )
+ 9999 FORMAT( A6, 2E10.3, 2I6, 2I4, I5, I6, 3F6.2, 4X, A1 )
120 CONTINUE
*
* End of PDSVDTST
diff --git a/TESTING/EIG/psgseptst.f b/TESTING/EIG/psgseptst.f
index a2bcb38..69e34df 100644
--- a/TESTING/EIG/psgseptst.f
+++ b/TESTING/EIG/psgseptst.f
@@ -531,6 +531,10 @@
$ WORK( INDWORK ), SIZETMS, IPREPAD, IPOSTPAD,
$ PADVAL+4.0E+0 )
*
+*
+* WKNOWN ... NOT SET, GUESS A DEFAULT
+*
+ WKNOWN = .TRUE.
ELSE
IINFO = 1
END IF
diff --git a/TESTING/EIG/pshseqrdriver.f b/TESTING/EIG/pshseqrdriver.f
new file mode 100644
index 0000000..b09e267
--- /dev/null
+++ b/TESTING/EIG/pshseqrdriver.f
@@ -0,0 +1,565 @@
+***********************************************************************
+* Test program for ScaLAPACK-style routine PSHSEQR *
+***********************************************************************
+*
+* Contributor: Robert Granat and Meiyue Shao
+* This version is of Feb 2011.
+*
+ PROGRAM PSHSEQRDRIVER
+*
+* Declarations
+*
+ IMPLICIT NONE
+* ...Parameters...
+ LOGICAL BALANCE, COMPHESS, COMPRESI,
+ $ COMPORTH
+ LOGICAL DEBUG, PRN, TIMESTEPS, BARR,
+ $ UNI_LAPACK
+ INTEGER SLV_MIN, SLV_MAX
+ PARAMETER ( DEBUG = .FALSE.,
+ $ PRN = .FALSE.,
+ $ TIMESTEPS = .TRUE.,
+ $ COMPHESS = .TRUE.,
+ $ COMPRESI = .TRUE.,
+ $ COMPORTH = .TRUE.,
+ $ BALANCE = .TRUE.,
+ $ BARR = .FALSE.,
+* Solver: 1-PSLAQR1, 2-PSHSEQR.
+ $ SLV_MIN = 2, SLV_MAX = 2,
+ $ UNI_LAPACK = .TRUE. )
+ INTEGER N, NB, ARSRC, ACSRC
+ PARAMETER (
+* Problem size.
+ $ N = 500, NB = 50,
+* What processor should hold the first element in A?
+ $ ARSRC = 0, ACSRC = 0 )
+ INTEGER BLOCK_CYCLIC_2D, CSRC_, CTXT_, DLEN_, DT_,
+ $ LLD_, MB_, M_, NB_, N_, RSRC_
+ PARAMETER ( BLOCK_CYCLIC_2D = 1, DLEN_ = 9, DT_ = 1,
+ $ CTXT_ = 2, M_ = 3, N_ = 4, MB_ = 5, NB_ = 6,
+ $ RSRC_ = 7, CSRC_ = 8, LLD_ = 9 )
+ INTEGER DPALLOC, INTALLC
+ INTEGER DPSIZ, INTSZ, NOUT, IZERO
+ PARAMETER ( DPSIZ = 8, DPALLOC = 8 000 000,
+ $ INTSZ = 4, INTALLC = 8 000 000,
+ $ NOUT = 6, IZERO = 0)
+ REAL ZERO, ONE, TWO
+ PARAMETER ( ZERO = 0.0, ONE = 1.0, TWO = 2.0 )
+*
+* ...Local Scalars...
+ INTEGER ICTXT, IAM, NPROW, NPCOL, MYROW, MYCOL,
+ $ SYS_NPROCS, NPROCS, AROWS, ACOLS, TEMP_ICTXT
+ INTEGER THREADS
+ INTEGER INFO, KTOP, KBOT, ILO, IHI, I
+ INTEGER IPA, IPACPY, IPQ, WR1, WI1, WR2, WI2, IPW1,
+ $ IPW2, IPIW
+ INTEGER TOTIT, SWEEPS, TOTNS, HESS
+ REAL EPS, THRESH
+ DOUBLE PRECISION STAMP, TOTTIME, T_BA, T_GEN, T_HS, T_SCH, T_QR,
+ $ T_RES, ITPEREIG, SWPSPEIG, NSPEIG, SPEEDUP,
+ $ EFFICIENCY
+ REAL RNORM, ANORM, R1, ORTH, O1, O2, DPDUM, ELEM1,
+ $ ELEM2, ELEM3, EDIFF
+ INTEGER SOLVER
+ CHARACTER*6 PASSED
+*
+* ...Local Arrays...
+ INTEGER DESCA( DLEN_ ), DESCQ( DLEN_ ), DESCVEC( DLEN_ )
+ REAL SCALE( N )
+ REAL, ALLOCATABLE :: MEM(:)
+ INTEGER, ALLOCATABLE :: IMEM(:)
+*
+* ...Intrinsic Functions...
+ INTRINSIC INT, FLOAT, SQRT, MAX, MIN
+*
+* ...External Functions...
+ INTEGER NUMROC
+ REAL PSLAMCH, PSLANGE
+ DOUBLE PRECISION MPI_WTIME
+ EXTERNAL BLACS_PINFO, BLACS_GET, BLACS_GRIDINIT,
+ $ BLACS_GRIDINFO, BLACS_GRIDEXIT, BLACS_EXIT
+ EXTERNAL NUMROC, PSLAMCH, PSLASET, PSGEHRD, PSLANGE
+ EXTERNAL SGEBAL, SGEHRD
+ EXTERNAL MPI_WTIME
+ EXTERNAL PSGEBAL
+ EXTERNAL PSMATGEN2
+*
+* ...Executable statements...
+*
+ CALL BLACS_PINFO( IAM, SYS_NPROCS )
+ NPROW = INT( SQRT( FLOAT(SYS_NPROCS) ) )
+ NPCOL = SYS_NPROCS / NPROW
+ CALL BLACS_GET( 0, 0, ICTXT )
+ CALL BLACS_GRIDINIT( ICTXT, '2D', NPROW, NPCOL )
+ CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL )
+c print*, iam, ictxt, myrow, mycol
+c IF ( ( MYROW.GE.NPROW ) .OR. ( MYCOL.GE.NPCOL ) ) GO TO 777
+ IF ( ICTXT.LT.0 ) GO TO 777
+*
+* Read out the number of underlying threads and set stack size in
+* kilobytes.
+*
+ THRESH = 30.0
+ TOTTIME = MPI_WTIME()
+ T_GEN = 0.0D+00
+ T_RES = 0.0D+00
+ T_SCH = 0.0D+00
+*
+* Allocate and Init memory with zeros.
+*
+ INFO = 0
+ ALLOCATE ( MEM( DPALLOC ), STAT = INFO )
+ IF( INFO.NE.0 ) THEN
+ WRITE(*,*) '% Could not allocate MEM. INFO = ', INFO
+ GO TO 777
+ END IF
+ ALLOCATE ( IMEM( INTALLC ), STAT = INFO )
+ IF( INFO.NE.0 ) THEN
+ WRITE(*,*) '% Could not allocate IMEM. INFO = ', INFO
+ GO TO 777
+ END IF
+ MEM( 1:DPALLOC ) = ZERO
+ IMEM( 1:INTALLC ) = IZERO
+*
+* Get machine epsilon.
+*
+ EPS = PSLAMCH( ICTXT, 'Epsilon' )
+*
+* Print welcoming message.
+*
+ IF( IAM.EQ.0 ) THEN
+ WRITE(*,*)
+ WRITE(*,*) 'ScaLAPACK Test for PSHSEQR'
+ WRITE(*,*)
+ WRITE(*,*) 'epsilon = ', EPS
+ WRITE(*,*) 'threshold = ', THRESH
+ WRITE(*,*)
+ WRITE(*,*) 'Residual and Orthogonality Residual computed by:'
+ WRITE(*,*)
+ WRITE(*,*) 'Residual = ',
+ $ ' || T - Q^T*A*Q ||_F / ( ||A||_F * eps * sqrt(N) )'
+ WRITE(*,*)
+ WRITE(*,*) 'Orthogonality = ',
+ $ ' MAX( || I - Q^T*Q ||_F, || I - Q*Q^T ||_F ) / ',
+ $ ' (eps * N)'
+ WRITE(*,*)
+ WRITE(*,*)
+ $ 'Test passes if both residuals are less then threshold'
+ WRITE( NOUT, * )
+ WRITE( NOUT, FMT = 9995 )
+ WRITE( NOUT, FMT = 9994 )
+ END IF
+*
+* Loop over problem parameters.
+*
+ DO KTOP = 1, 1
+ DO KBOT = N, N
+ DO SOLVER = SLV_MAX, SLV_MIN, -1
+*
+* Set INFO to zero for this run.
+*
+ INFO = 0
+ NPROCS = NPROW*NPCOL
+ TEMP_ICTXT = ICTXT
+*
+* Count the number of rows and columns of current problem
+* for the current block sizes and grid properties.
+*
+ STAMP = MPI_WTIME()
+ AROWS = NUMROC( N, NB, MYROW, 0, NPROW )
+ ACOLS = NUMROC( N, NB, MYCOL, 0, NPCOL )
+*
+* Set up matrix descriptors.
+*
+ IF( DEBUG ) WRITE(*,*) '% #', IAM, ': Set up descriptors...'
+ IF( BARR ) CALL BLACS_BARRIER(ICTXT, 'A')
+ CALL DESCINIT( DESCA, N, N, NB, NB, MIN(ARSRC,NPROW-1),
+ $ MIN(NPCOL-1,ACSRC), TEMP_ICTXT, MAX(1, AROWS), INFO )
+ IF ( INFO.NE.0 ) THEN
+ WRITE(*,*) "% DESCINIT DESCA failed, INFO =", INFO
+ GO TO 999
+ END IF
+ CALL DESCINIT( DESCQ, N, N, NB, NB, MIN(ARSRC,NPROW-1),
+ $ MIN(NPCOL-1,ACSRC), TEMP_ICTXT, MAX(1, AROWS), INFO )
+ IF ( INFO.NE.0 ) THEN
+ WRITE(*,*) "% DESCINIT DESCQ failed, INFO =", INFO
+ GO TO 999
+ END IF
+ CALL DESCINIT( DESCVEC, N, 1, N, 1, MIN(ARSRC,NPROW-1),
+ $ MIN(NPCOL-1,ACSRC), TEMP_ICTXT, N, INFO )
+ IF ( INFO.NE.0 ) THEN
+ WRITE(*,*) "% DESCINIT DESCVEC failed, INFO =", INFO
+ GO TO 999
+ END IF
+*
+* Assign pointer for ScaLAPACK arrays - first set DP memory.
+*
+ IF( DEBUG ) WRITE(*,*) '% #', IAM, ': Assign pointers...'
+ IPA = 1
+ IPACPY = IPA + DESCA( LLD_ ) * ACOLS
+ IPQ = IPACPY + DESCA( LLD_ ) * ACOLS
+ WR1 = IPQ + DESCQ( LLD_ ) * ACOLS
+ WI1 = WR1 + N
+ WR2 = WI1 + N
+ WI2 = WR2 + N
+ IPW1 = WI2 + N
+ IPW2 = IPW1 + DESCA( LLD_ ) * ACOLS
+ IF( DEBUG ) WRITE(*,*) '% (IPW2,DPALLOC):', IPW2, DPALLOC
+* PRINT*, '%', IPA, IPACPY, IPQ, WR1, WI1, WR2, WI2, IPW1, IPW2
+ IF( IPW2+DESCA(LLD_)*ACOLS .GT. DPALLOC+1 ) THEN
+ WRITE(*,*) '% Not enough DP memory!'
+ GO TO 999
+ END IF
+*
+* Then set integer memory pointers.
+*
+ IPIW = 1
+*
+* Generate testproblem.
+*
+ IF( BARR ) CALL BLACS_BARRIER(ICTXT, 'A')
+ CALL PSLASET( 'All over', N, N, ZERO, ONE, MEM(IPQ), 1, 1,
+ $ DESCQ )
+ CALL PSMATGEN2( TEMP_ICTXT, 'Random', 'NoDiagDominant',
+ $ N, N, NB, NB, MEM(IPA), DESCA( LLD_ ), 0, 0, 7, 0,
+ $ AROWS, 0, ACOLS, MYROW, MYCOL, NPROW, NPCOL )
+ IF( .NOT. COMPHESS ) THEN
+ CALL PSLASET( 'Lower triangular', N-2, N-2, ZERO, ZERO,
+ $ MEM(IPA), 3, 1, DESCA )
+ CALL PSLASET( 'All over', N, N, ZERO, ONE, MEM(IPQ),
+ $ 1, 1, DESCQ )
+ IF( KTOP.GT.1 )
+ $ CALL PSLASET( 'Lower triangular', KTOP-1, KTOP-1,
+ $ ZERO, ZERO, MEM(IPA), 2, 1, DESCQ )
+ IF( KBOT.LT.N )
+ $ CALL PSLASET( 'Lower triangular', N-KBOT, N-KBOT,
+ $ ZERO, ZERO, MEM(IPA), KBOT+1, KBOT, DESCQ )
+ END IF
+*
+* Do balancing if general matrix.
+*
+ IF( BARR ) CALL BLACS_BARRIER(ICTXT, 'A')
+ T_BA = MPI_WTIME()
+ IF( COMPHESS .AND. BALANCE ) THEN
+ IF( NPROCS.EQ.1 .AND. SOLVER.NE.2 .AND. UNI_LAPACK ) THEN
+ IF( DEBUG ) WRITE(*,*) '% #', IAM, ': == dgebal =='
+ CALL SGEBAL( 'Both', N, MEM(IPA), DESCA(LLD_), ILO,
+ $ IHI, SCALE, INFO )
+ IF ( INFO.NE.0 ) THEN
+ WRITE(*,*) "% SGEBAL failed, INFO =", INFO
+ GO TO 999
+ END IF
+ ELSE
+ IF( DEBUG ) WRITE(*,*) '% #', IAM, ': == pdgebal =='
+ CALL PSGEBAL( 'Both', N, MEM(IPA), DESCA, ILO, IHI,
+ $ SCALE, INFO )
+ IF ( INFO.NE.0 ) THEN
+ WRITE(*,*) "% PSGEBAL failed, INFO =", INFO
+ GO TO 999
+ END IF
+ END IF
+ ELSEIF( COMPHESS ) THEN
+ ILO = 1
+ IHI = N
+ ELSE
+ ILO = KTOP
+ IHI = KBOT
+ END IF
+ T_BA = MPI_WTIME() - T_BA
+c IF( TIMESTEPS.AND.IAM.EQ.0 ) WRITE(*,*)
+c $ ' %%% Balancing took in seconds:',T_BA
+ IF( DEBUG ) WRITE(*,*) '% #', IAM, ': ILO,IHI=',ILO,IHI
+*
+* Make a copy of A.
+*
+ IF( BARR ) CALL BLACS_BARRIER(ICTXT, 'A')
+ IF( DEBUG ) WRITE(*,*) '% #', IAM, ': Copy matrix A'
+ CALL PSLACPY( 'All', N, N, MEM(IPA), 1, 1, DESCA, MEM(IPACPY),
+ $ 1, 1, DESCA )
+*
+* Print matrices to screen in debugging mode.
+*
+ IF( PRN )
+ $ CALL PSLAPRNT( N, N, MEM(IPACPY), 1, 1, DESCA, 0, 0,
+ $ 'A', NOUT, MEM(IPW1) )
+ T_GEN = T_GEN + MPI_WTIME() - STAMP - T_BA
+c IF( TIMESTEPS.AND.IAM.EQ.0 ) WRITE(*,*)
+c $ ' %%% Generation took in seconds:',T_GEN
+*
+* Only compute the Hessenberg form if necessary.
+*
+ T_HS = MPI_WTIME()
+ IF( .NOT. COMPHESS ) GO TO 30
+*
+* Reduce A to Hessenberg form.
+*
+ IF( BARR ) CALL BLACS_BARRIER(ICTXT, 'A')
+ IF( DEBUG ) WRITE(*,*) '% #', IAM,
+ $ ': Reduce to Hessenberg form...N=',N, ILO,IHI
+* PRINT*, '% PSGEHRD: IPW2,MEM(IPW2)', IPW2, MEM(IPW2)
+ IF( NPROCS.EQ.1 .AND. SOLVER.NE.2 .AND. UNI_LAPACK ) THEN
+ IF( DEBUG ) WRITE(*,*) '% #', IAM, ': == dgehrd =='
+ CALL SGEHRD( N, ILO, IHI, MEM(IPA), DESCA(LLD_),
+ $ MEM(IPW1), MEM(IPW2), -1, INFO )
+ IF (DPALLOC-IPW2.LT.MEM(IPW2)) THEN
+ WRITE(*,*) "% Not enough memory for SGEHRD"
+ GO TO 999
+ END IF
+ CALL SGEHRD( N, ILO, IHI, MEM(IPA), DESCA(LLD_),
+ $ MEM(IPW1), MEM(IPW2), DPALLOC-IPW2, INFO )
+ IF ( INFO.NE.0 ) THEN
+ WRITE(*,*) "% SGEHRD failed, INFO =", INFO
+ GO TO 999
+ END IF
+ ELSE
+ IF( DEBUG ) WRITE(*,*) '% #', IAM, ': == pdgehrd =='
+ CALL PSGEHRD( N, ILO, IHI, MEM(IPA), 1, 1, DESCA, MEM(IPW1),
+ $ MEM(IPW2), -1, INFO )
+ IF (DPALLOC-IPW2.LT.MEM(IPW2)) THEN
+ WRITE(*,*) "% Not enough memory for PSGEHRD"
+ GO TO 999
+ END IF
+ CALL PSGEHRD( N, ILO, IHI, MEM(IPA), 1, 1, DESCA, MEM(IPW1),
+ $ MEM(IPW2), DPALLOC-IPW2, INFO )
+ IF ( INFO.NE.0 ) THEN
+ WRITE(*,*) "% PSGEHRD failed, INFO =", INFO
+ GO TO 999
+ END IF
+ END IF
+*
+* Form Q explicitly.
+*
+ IF( BARR ) CALL BLACS_BARRIER(ICTXT, 'A')
+ IF( DEBUG ) WRITE(*,*) '% #', IAM, ':Form Q explicitly'
+* PRINT*, '% PSORMHR: IPW2,MEM(IPW2)', IPW2, MEM(IPW2)
+ IF( DEBUG ) WRITE(*,*) '% #', IAM, ': == pdormhr =='
+ CALL PSORMHR( 'L', 'N', N, N, ILO, IHI, MEM(IPA), 1, 1,
+ $ DESCA, MEM(IPW1), MEM(IPQ), 1, 1, DESCQ, MEM(IPW2),
+ $ -1, INFO )
+ IF (DPALLOC-IPW2.LT.MEM(IPW2)) THEN
+ WRITE(*,*) "% Not enough memory for PSORMHR"
+ GO TO 999
+ END IF
+ CALL PSORMHR( 'L', 'N', N, N, ILO, IHI, MEM(IPA), 1, 1,
+ $ DESCA, MEM(IPW1), MEM(IPQ), 1, 1, DESCQ, MEM(IPW2),
+ $ DPALLOC-IPW2, INFO )
+ IF ( INFO.NE.0 ) THEN
+ WRITE(*,*) "% PSORMHR failed, INFO =", INFO
+ GO TO 999
+ END IF
+*
+* Extract the upper Hessenberg part of A.
+*
+ CALL PSLASET( 'Lower triangular', N-2, N-2, ZERO, ZERO,
+ $ MEM(IPA), 3, 1, DESCA )
+*
+* Print reduced matrix A in debugging mode.
+*
+ IF( PRN ) THEN
+ CALL PSLAPRNT( N, N, MEM(IPA), 1, 1, DESCA, 0, 0, 'H', NOUT,
+ $ MEM(IPW1) )
+ CALL PSLAPRNT( N, N, MEM(IPQ), 1, 1, DESCQ, 0, 0, 'Q', NOUT,
+ $ MEM(IPW1) )
+ END IF
+*
+ 30 CONTINUE
+ T_HS = MPI_WTIME() - T_HS
+c IF( TIMESTEPS.AND.IAM.EQ.0 ) WRITE(*,*)
+c $ ' %%% Hessenberg took in seconds:',T_HS
+*
+* Compute the real Schur form of the Hessenberg matrix A.
+*
+ IF( BARR ) CALL BLACS_BARRIER(ICTXT, 'A')
+ T_QR = MPI_WTIME()
+ IF( SOLVER.EQ.1 ) THEN
+ IF( DEBUG ) WRITE(*,*) '% #', IAM, ': == pdlaqr1 =='
+* PRINT*, '% PSLAQR1: IPW1,MEM(IPW1)', IPW1, MEM(IPW1)
+ CALL PSLAQR1( .TRUE., .TRUE., N, ILO, IHI, MEM(IPA), DESCA,
+ $ MEM(WR1), MEM(WI1), ILO, IHI, MEM(IPQ), DESCQ,
+ $ MEM(IPW1), -1, IMEM, -1, INFO )
+ IF (DPALLOC-IPW1.LT.MEM(IPW1)) THEN
+ WRITE(*,*) "% Not enough DP memory for PSLAQR1"
+ GO TO 999
+ END IF
+ IF (INTALLC.LT.IMEM(1)) THEN
+ WRITE(*,*) "% Not enough INT memory for PSLAQR1"
+ GO TO 999
+ END IF
+ CALL PSLAQR1( .TRUE., .TRUE., N, ILO, IHI, MEM(IPA), DESCA,
+ $ MEM(WR1), MEM(WI1), ILO, IHI, MEM(IPQ), DESCQ,
+ $ MEM(IPW1), DPALLOC-IPW1+1, IMEM, INTALLC, INFO )
+ IF (INFO.NE.0) THEN
+ WRITE(*,*) "% PSLAQR1: INFO =", INFO
+ END IF
+ ELSEIF( SOLVER.EQ.2 ) THEN
+ IF( DEBUG ) WRITE(*,*) '% #', IAM, ': == pdhseqr =='
+* PRINT*, '% PSHSEQR: IPW1,MEM(IPW1)', IPW1, MEM(IPW1)
+ IF( BARR ) CALL BLACS_BARRIER(ICTXT, 'A')
+ CALL PSHSEQR( 'Schur', 'Vectors', N, ILO, IHI, MEM(IPA),
+ $ DESCA, MEM(WR2), MEM(WI2), MEM(IPQ), DESCQ, MEM(IPW1),
+ $ -1, IMEM, -1, INFO )
+ IF( BARR ) CALL BLACS_BARRIER(ICTXT, 'A')
+ IF (DPALLOC-IPW1.LT.MEM(IPW1)) THEN
+ WRITE(*,*) "% Not enough DP memory for PSHSEQR"
+ GO TO 999
+ END IF
+ IF (INTALLC.LT.IMEM(1)) THEN
+ WRITE(*,*) "% Not enough INT memory for PSHSEQR"
+ GO TO 999
+ END IF
+ IF( BARR ) CALL BLACS_BARRIER(ICTXT, 'A')
+ CALL PSHSEQR( 'Schur', 'Vectors', N, ILO, IHI, MEM(IPA),
+ $ DESCA, MEM(WR2), MEM(WI2), MEM(IPQ), DESCQ, MEM(IPW1),
+ $ DPALLOC-IPW1+1, IMEM, INTALLC, INFO )
+ IF (INFO.NE.0) THEN
+ WRITE(*,*) "% PSHSEQR: INFO =", INFO
+ END IF
+ ELSE
+ WRITE(*,*) '% ERROR: Illegal SOLVER number!'
+ GO TO 999
+ END IF
+ T_QR = MPI_WTIME() - T_QR
+c IF( TIMESTEPS.AND.IAM.EQ.0 ) WRITE(*,*)
+c $ ' %%% QR-algorithm took in seconds:',T_QR
+ T_SCH = T_SCH + T_QR + T_HS + T_BA
+* TOTIT = IMEM(1)
+* SWEEPS = IMEM(2)
+* TOTNS = IMEM(3)
+ ITPEREIG = FLOAT(TOTIT) / FLOAT(N)
+ SWPSPEIG = FLOAT(SWEEPS) / FLOAT(N)
+ NSPEIG = FLOAT(TOTNS) / FLOAT(N)
+*
+* Print reduced matrix A in debugging mode.
+*
+ IF( PRN ) THEN
+ CALL PSLAPRNT( N, N, MEM(IPA), 1, 1, DESCA, 0, 0, 'T',
+ $ NOUT, MEM(IPW1) )
+ CALL PSLAPRNT( N, N, MEM(IPQ), 1, 1, DESCQ, 0, 0, 'Z',
+ $ NOUT, MEM(IPW1) )
+ END IF
+*
+* Check that returned Schur form is really a quasi-triangular
+* matrix.
+*
+ HESS = 0
+ DO I = 1, N-1
+ IF( I.GT.1 ) THEN
+ CALL PSELGET( 'All', '1-Tree', ELEM1, MEM(IPA), I, I-1,
+ $ DESCA )
+ ELSE
+ ELEM1 = ZERO
+ END IF
+ CALL PSELGET( 'All', '1-Tree', ELEM2, MEM(IPA), I+1, I,
+ $ DESCA )
+ IF( I.LT.N-1 ) THEN
+ CALL PSELGET( 'All', '1-Tree', ELEM3, MEM(IPA), I+2, I+1,
+ $ DESCA )
+ ELSE
+ ELEM3 = ZERO
+ END IF
+ IF( ELEM2.NE.ZERO .AND. ABS(ELEM1)+ABS(ELEM2)+ABS(ELEM3).GT.
+ $ ABS(ELEM2) ) HESS = HESS + 1
+ END DO
+*
+* Compute residual norms and other results:
+*
+* 1) RNORM = || T - Q'*A*Q ||_F / ||A||_F
+* 2) ORTH = MAX( || I - Q'*Q ||_F, || I - Q*Q' ||_F ) /
+* (epsilon*N)
+*
+ STAMP = MPI_WTIME()
+ IF( COMPRESI ) THEN
+ IF( DEBUG ) WRITE(*,*) '% #', IAM, ': Compute residuals 1'
+ IF( DEBUG ) WRITE(*,*) '% #', IAM, ': pdgemm 3'
+ CALL PSGEMM( 'N', 'N', N, N, N, ONE, MEM(IPACPY), 1, 1,
+ $ DESCA, MEM(IPQ), 1, 1, DESCQ, ZERO, MEM(IPW1), 1, 1,
+ $ DESCA )
+ IF( DEBUG ) WRITE(*,*) '% #', IAM, ': pdgemm 4'
+ IF( DEBUG ) WRITE(*,*) '% #', IAM, ': N=',N
+ IF( DEBUG ) WRITE(*,*) '% #', IAM, ': DESCA=',DESCA(1:DLEN_)
+ IF( DEBUG ) WRITE(*,*) '% #', IAM, ': DESCQ=',DESCQ(1:DLEN_)
+ CALL PSGEMM( 'T', 'N', N, N, N, -ONE, MEM(IPQ), 1, 1,
+ $ DESCQ, MEM(IPW1), 1, 1, DESCA, ONE, MEM(IPA), 1, 1,
+ $ DESCA )
+ R1 = PSLANGE( 'Frobenius', N, N, MEM(IPA), 1, 1, DESCA,
+ $ DPDUM )
+ ANORM = PSLANGE( 'Frobenius', N, N, MEM(IPACPY), 1, 1,
+ $ DESCA, DPDUM )
+ IF( ANORM.GT.ZERO )THEN
+ RNORM = R1 / (ANORM*EPS*SQRT(FLOAT(N)))
+ ELSE
+ RNORM = R1
+ END IF
+ ELSE
+ RNORM = 0.0D0
+ END IF
+*
+ IF( COMPORTH ) THEN
+ IF( DEBUG ) WRITE(*,*) '% #', IAM, ': Compute residuals 2'
+ CALL PSLASET( 'All', N, N, ZERO, ONE, MEM(IPW1), 1, 1,
+ $ DESCQ )
+ CALL PSLACPY( 'All', N, N, MEM(IPQ), 1, 1, DESCQ, MEM(IPW2),
+ $ 1, 1, DESCQ )
+ CALL PSGEMM( 'T', 'N', N, N, N, -ONE, MEM(IPQ), 1, 1, DESCQ,
+ $ MEM(IPW2), 1, 1, DESCQ, ONE, MEM(IPW1), 1, 1, DESCQ )
+ O1 = PSLANGE( 'Frobenius', N, N, MEM(IPW1), 1, 1, DESCQ,
+ $ DPDUM )
+ CALL PSLASET( 'All', N, N, ZERO, ONE, MEM(IPW1), 1, 1,
+ $ DESCQ )
+ CALL PSGEMM( 'N', 'T', N, N, N, -ONE, MEM(IPQ), 1, 1, DESCQ,
+ $ MEM(IPW2), 1, 1, DESCQ, ONE, MEM(IPW1), 1, 1, DESCQ )
+ O2 = PSLANGE( 'Frobenius', N, N, MEM(IPW1), 1, 1, DESCQ,
+ $ DPDUM )
+ ORTH = MAX(O1,O2) / (EPS*FLOAT(N))
+ ELSE
+ ORTH = 0.0D0
+ END IF
+*
+ T_RES = T_RES + MPI_WTIME() - STAMP
+c IF( TIMESTEPS.AND.IAM.EQ.0 ) WRITE(*,*)
+c $ ' %%% Residuals took in seconds:',T_RES
+ TOTTIME = MPI_WTIME() - TOTTIME
+c IF( IAM.EQ.0 ) WRITE(*,*)
+c $ ' %%% Total execution time in seconds:', TOTTIME
+*
+*
+* Print results to screen.
+*
+ IF( (ORTH.GT.THRESH).OR.(RNORM.GT.THRESH) ) THEN
+ PASSED = 'FAILED'
+ ELSE
+ PASSED = 'PASSED'
+ END IF
+ IF( DEBUG ) WRITE(*,*) '% #', IAM, ': Print results...'
+ IF( IAM.EQ.0 ) THEN
+ WRITE( NOUT, FMT = 9993 ) N, NB, NPROW, NPCOL, T_QR, PASSED
+ END IF
+ CALL BLACS_BARRIER( ICTXT, 'All' )
+ END DO
+ END DO
+ END DO
+ 999 CONTINUE
+*
+* Deallocate MEM and IMEM.
+*
+ DEALLOCATE( MEM, IMEM )
+*
+ CALL BLACS_GRIDEXIT( ICTXT )
+*
+ 777 CONTINUE
+*
+ CALL BLACS_EXIT( 0 )
+*
+* Format specifications.
+*
+ 6666 FORMAT(A2,A3,A6,A4,A5,A6,A3,A3,A3,A9,A9,A9,A8,A8,A9,A9,A9,A9,A9,
+ $ A9,A9,A9,A9,A9,A9,A5,A5,A8,A5,A5)
+ 7777 FORMAT(A2,I3,I6,I4,I5,I6,I3,I3,I3,F9.2,F9.2,F9.2,F8.2,F8.2,F9.2,
+ $ F9.2,F9.2,F9.2,F9.2,F9.2,F9.2,F9.2,E9.2,E9.2,E9.2,I5,I5,
+ $ F8.4,I5,I5,A2)
+ 9995 FORMAT( ' N NB P Q QR Time CHECK' )
+ 9994 FORMAT( '----- --- ---- ---- -------- ------' )
+ 9993 FORMAT( I5, 1X, I3, 1X, I4, 1X, I4, 1X, F8.2, 1X, A6 )
+
+*
+ END
diff --git a/TESTING/EIG/pslasizesepr.f b/TESTING/EIG/pslasizesepr.f
new file mode 100644
index 0000000..bf8fc9b
--- /dev/null
+++ b/TESTING/EIG/pslasizesepr.f
@@ -0,0 +1,143 @@
+ SUBROUTINE PSLASIZESEPR( DESCA, IPREPAD, IPOSTPAD, SIZEMQRLEFT,
+ $ SIZEMQRRIGHT, SIZEQRF, SIZETMS, SIZEQTQ,
+ $ SIZECHK, SIZESYEVR, ISIZESYEVR,
+ $ SIZESUBTST, ISIZESUBTST, SIZETST,
+ $ ISIZETST )
+*
+* -- ScaLAPACK routine (@(MODE)version *TBA*) --
+* University of California, Berkeley and
+* University of Tennessee, Knoxville.
+* October 21, 2006
+*
+ IMPLICIT NONE
+*
+* .. Scalar Arguments ..
+ INTEGER IPOSTPAD, IPREPAD, ISIZESUBTST, ISIZESYEVR,
+ $ ISIZETST, SIZECHK, SIZEMQRLEFT, SIZEMQRRIGHT,
+ $ SIZEQRF, SIZEQTQ, SIZESUBTST, SIZESYEVR,
+ $ SIZETMS, SIZETST
+* ..
+* .. Array Arguments ..
+ INTEGER DESCA( * )
+*
+* Purpose
+* =======
+*
+* PSLASIZESEPR computes the amount of memory needed by
+* various SEPR test routines, as well as PSSYEVR itself.
+*
+* Arguments
+* =========
+*
+* DESCA (global input) INTEGER array dimension ( DLEN_ )
+* Array descriptor for dense matrix.
+*
+* SIZEMQRLEFT LWORK for the 1st PSORMQR call in PSLAGSY
+*
+* SIZEMQRRIGHT LWORK for the 2nd PSORMQR call in PSLAGSY
+*
+* SIZEQRF LWORK for PSGEQRF in PSLAGSY
+*
+* SIZETMS LWORK for PSLATMS
+*
+* SIZEQTQ LWORK for PSSEPQTQ
+*
+* SIZECHK LWORK for PSSEPCHK
+*
+* SIZESYEVR LWORK for PSSYEVR
+*
+* ISIZESYEVR LIWORK for PSSYEVR
+*
+* SIZESUBTST LWORK for PSSEPRSUBTST
+*
+* ISIZESUBTST LIWORK for PSSEPRSUBTST
+*
+* SIZETST LWORK for PSSEPRTST
+*
+* ISIZETST LIWORK for PSSEPRTST
+*
+*
+* .. Parameters ..
+ INTEGER CTXT_, M_,
+ $ MB_, NB_, RSRC_, CSRC_, LLD_
+ PARAMETER (
+ $ CTXT_ = 2, M_ = 3, MB_ = 5, NB_ = 6,
+ $ RSRC_ = 7, CSRC_ = 8, LLD_ = 9 )
+* ..
+* .. Local Scalars ..
+ INTEGER CSRC_A, IACOL, IAROW, ICOFFA, IROFFA, LCM,
+ $ LCMQ, LDA, MQ0, MYCOL, MYROW, N, NB, NEIG, NN,
+ $ NNP, NP, NP0, NPCOL, NPROW, NQ, RSRC_A
+* ..
+* .. External Functions ..
+ INTEGER ICEIL, ILCM, INDXG2P, NUMROC
+ EXTERNAL ICEIL, ILCM, INDXG2P, NUMROC
+*
+* .. External Subroutines ..
+ EXTERNAL BLACS_GRIDINFO
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX
+* ..
+* .. Executable Statements ..
+*
+ N = DESCA( M_ )
+ NB = DESCA( MB_ )
+ RSRC_A = DESCA( RSRC_ )
+ CSRC_A = DESCA( CSRC_ )
+*
+ LDA = DESCA( LLD_ )
+ CALL BLACS_GRIDINFO( DESCA( CTXT_ ), NPROW, NPCOL, MYROW, MYCOL )
+*
+ LCM = ILCM( NPROW, NPCOL )
+ LCMQ = LCM / NPCOL
+ IROFFA = 0
+ ICOFFA = 0
+ IAROW = INDXG2P( 1, NB, MYROW, RSRC_A, NPROW )
+ IACOL = INDXG2P( 1, NB, MYCOL, CSRC_A, NPCOL )
+ NP = NUMROC( N+IROFFA, NB, MYROW, IAROW, NPROW )
+ NQ = NUMROC( N+ICOFFA, NB, MYCOL, IACOL, NPCOL )
+ SIZEMQRLEFT = MAX( ( NB*( NB-1 ) ) / 2, ( NP+NQ )*NB ) + NB*NB
+ SIZEMQRRIGHT = MAX( ( NB*( NB-1 ) ) / 2,
+ $ ( NQ+MAX( NP+NUMROC( NUMROC( N+ICOFFA, NB, 0, 0,
+ $ NPCOL ), NB, 0, 0, LCMQ ), NP ) )*NB ) + NB*NB
+ SIZEQRF = NB*NP + NB*NQ + NB*NB
+ SIZETMS = ( LDA+1 )*MAX( 1, NQ ) +
+ $ MAX( SIZEMQRLEFT, SIZEMQRRIGHT, SIZEQRF )
+*
+ NP0 = NUMROC( N, DESCA( MB_ ), 0, 0, NPROW )
+ MQ0 = NUMROC( N, DESCA( NB_ ), 0, 0, NPCOL )
+ SIZEQTQ = 2 + MAX( DESCA( MB_ ), 2 )*( 2*NP0+MQ0 )
+ SIZECHK = NUMROC( N, DESCA( NB_ ), MYCOL, 0, NPCOL )
+*
+ NEIG = N
+ NN = MAX( N, NB, 2 ) + 1
+ NP0 = NUMROC( NN, NB, 0, 0, NPROW )
+ MQ0 = NUMROC( MAX( NEIG, NB, 2 ), NB, 0, 0, NPCOL )
+ NNP = MAX( N, NPROW*NPCOL+1, 4 )
+*
+*
+ SIZESYEVR = 1 + 5*N + MAX( 18*NN, NP0*MQ0+2*NB*NB ) +
+ $ (2 + ICEIL( NEIG, NPROW*NPCOL ))*NN
+ SIZESYEVR = MAX(3, SIZESYEVR)
+*
+ ISIZESYEVR = 12*NNP + 2*N
+*
+ SIZESUBTST = MAX( SIZETMS, SIZEQTQ, SIZECHK, SIZESYEVR ) +
+ $ IPREPAD + IPOSTPAD
+ ISIZESUBTST = ISIZESYEVR + IPREPAD + IPOSTPAD
+*
+* Allow room for A, COPYA and Z and DIAG, WIN, WNEW, GAP, WORK
+*
+ SIZETST = 3*( LDA*NP+IPREPAD+IPOSTPAD ) +
+ $ 4*( N+IPREPAD+IPOSTPAD ) + SIZESUBTST
+*
+* Allow room for IFAIL, ICLUSTR, and IWORK
+* (only needed for PSSYEVX)
+*
+ ISIZETST = N + 2*NPROW*NPCOL + 2*( IPREPAD+IPOSTPAD ) +
+ $ ISIZESUBTST
+*
+*
+ RETURN
+ END
diff --git a/TESTING/EIG/pslasizesyevr.f b/TESTING/EIG/pslasizesyevr.f
new file mode 100644
index 0000000..d873942
--- /dev/null
+++ b/TESTING/EIG/pslasizesyevr.f
@@ -0,0 +1,188 @@
+ SUBROUTINE PSLASIZESYEVR( WKNOWN, RANGE, N, DESCA, VL, VU, IL, IU,
+ $ ISEED, WIN, MAXSIZE, VECSIZE, VALSIZE )
+*
+* -- ScaLAPACK routine (@(MODE)version *TBA*) --
+* University of California, Berkeley and
+* University of Tennessee, Knoxville.
+* October 21, 2006
+*
+ IMPLICIT NONE
+*
+* .. Scalar Arguments ..
+ LOGICAL WKNOWN
+ CHARACTER RANGE
+ INTEGER IL, IU, MAXSIZE, N, VALSIZE, VECSIZE
+ REAL VL, VU
+
+* ..
+* .. Array Arguments ..
+ INTEGER DESCA( * ), ISEED( 4 )
+ REAL WIN( * )
+* ..
+*
+* Purpose
+* =======
+*
+* PSLASIZESYEVR computes the amount of memory needed by PSSYEVR
+* to ensure:
+* 1) Orthogonal Eigenvectors
+* 2) Eigenpairs with small residual norms
+*
+* Arguments
+* =========
+*
+* WKNOWN (global input) INTEGER
+* .FALSE.: WIN does not contain the eigenvalues
+* .TRUE.: WIN does contain the eigenvalues
+*
+* RANGE (global input) CHARACTER*1
+* = 'A': all eigenvalues will be found.
+* = 'V': all eigenvalues in the interval [VL,VU]
+* will be found.
+* = 'I': the IL-th through IU-th eigenvalues will be found.
+*
+* N (global input) INTEGER
+* Size of the matrix to be tested. (global size)
+*
+* DESCA (global input) INTEGER array dimension ( DLEN_ )
+*
+* VL (global input/output ) REAL
+* If RANGE='V', the lower bound of the interval to be searched
+* for eigenvalues. Not referenced if RANGE = 'A' or 'I'.
+* If VL > VU, RANGE='V' and WKNOWN = .TRUE., VL is set
+* to a random value near an entry in WIN
+*
+* VU (global input/output ) REAL
+* If RANGE='V', the upper bound of the interval to be searched
+* for eigenvalues. Not referenced if RANGE = 'A' or 'I'.
+* If VL > VU, RANGE='V' and WKNOWN = .TRUE., VU is set
+* to a random value near an entry in WIN
+*
+* IL (global input/output ) INTEGER
+* If RANGE='I', the index (from smallest to largest) of the
+* smallest eigenvalue to be returned. IL >= 1.
+* Not referenced if RANGE = 'A' or 'V'.
+* If IL < 0, RANGE='I' and WKNOWN = .TRUE., IL is set
+* to a random value from 1 to N
+*
+* IU (global input/output ) INTEGER
+* If RANGE='I', the index (from smallest to largest) of the
+* largest eigenvalue to be returned. min(IL,N) <= IU <= N.
+* Not referenced if RANGE = 'A' or 'V'.
+* If IU < 0, RANGE='I' and WKNOWN = .TRUE., IU is set
+* to a random value from IL to N
+*
+* ISEED (global input/output) INTEGER array, dimension (4)
+* On entry, the seed of the random number generator; the array
+* elements must be between 0 and 4095, and ISEED(4) must be
+* odd.
+* On exit, the seed is updated.
+* ISEED is not touched unless IL, IU, VL or VU are modified.
+*
+* WIN (global input) REAL array, dimension (N)
+* If WKNOWN=1, WIN contains the eigenvalues of the matrix.
+*
+* MAXSIZE (global output) INTEGER
+* Workspace required to guarantee that PSSYEVR will return
+* orthogonal eigenvectors. IF WKNOWN=0, MAXSIZE is set to a
+* a value which guarantees orthogonality no matter what the
+* spectrum is. If WKNOWN=1, MAXSIZE is set to a value which
+* guarantees orthogonality on a matrix with eigenvalues given
+* by WIN.
+*
+* VECSIZE (global output) INTEGER
+* Workspace required to guarantee that PSSYEVR
+* will compute eigenvectors.
+*
+* VALSIZE (global output) INTEGER
+* Workspace required to guarantee that PSSYEVR
+* will compute eigenvalues.
+*
+*
+* .. Parameters ..
+ INTEGER CTXT_, MB_
+ PARAMETER ( CTXT_ = 2, MB_ = 5 )
+ REAL TWENTY
+ PARAMETER ( TWENTY = 20.0E0 )
+* ..
+* .. Local Scalars ..
+*
+ INTEGER ILMIN, IUMAX,
+ $ MQ0, MYCOL, MYIL, MYIU, MYROW, NB, NEIG, NN,
+ $ NP0, NPCOL, NPROW
+ REAL ANORM, EPS, SAFMIN
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ INTEGER ICEIL, NUMROC
+ REAL SLARAN, PSLAMCH
+ EXTERNAL LSAME, ICEIL, NUMROC, SLARAN, PSLAMCH
+* ..
+* .. External Subroutines ..
+ EXTERNAL BLACS_GRIDINFO
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, REAL, INT, MAX
+
+* ..
+* .. Executable Statements ..
+*
+ CALL BLACS_GRIDINFO( DESCA( CTXT_ ), NPROW, NPCOL, MYROW, MYCOL )
+ EPS = PSLAMCH( DESCA( CTXT_ ), 'Precision' )
+ SAFMIN = PSLAMCH( DESCA( CTXT_ ), 'Safe Minimum' )
+ NB = DESCA( MB_ )
+ NN = MAX( N, NB, 2 )
+ NP0 = NUMROC( NN, NB, 0, 0, NPROW )
+
+ VALSIZE = 3 + 5*N + MAX( 12*NN, NB*( NP0+1 ) )
+
+ IF( WKNOWN ) THEN
+ ANORM = SAFMIN / EPS
+ IF( N.GE.1 )
+ $ ANORM = MAX( ABS( WIN( 1 ) ), ABS( WIN( N ) ), ANORM )
+ IF( LSAME( RANGE, 'I' ) ) THEN
+ IF( IL.LT.0 )
+ $ IL = INT( SLARAN( ISEED )*REAL( N ) ) + 1
+ IF( IU.LT.0 )
+ $ IU = INT( SLARAN( ISEED )*REAL( N-IL ) ) + IL
+ IF( N.EQ.0 )
+ $ IU = 0
+ ELSE IF( LSAME( RANGE, 'V' ) ) THEN
+ IF( VL.GT.VU ) THEN
+ MYIL = INT( SLARAN( ISEED )*REAL( N ) ) + 1
+ MYIU = INT( SLARAN( ISEED )*REAL( N-MYIL ) ) + MYIL
+ VL = WIN( MYIL ) - TWENTY*EPS*ABS( WIN( MYIL ) )
+ VU = WIN( MYIU ) + TWENTY*EPS*ABS( WIN( MYIU ) )
+ VU = MAX( VU, VL+EPS*TWENTY*ABS( VL )+SAFMIN )
+ END IF
+ END IF
+*
+ END IF
+ IF( LSAME( RANGE, 'V' ) ) THEN
+* We do not know how many eigenvalues will be computed
+ ILMIN = 1
+ IUMAX = N
+ ELSE IF( LSAME( RANGE, 'I' ) ) THEN
+ ILMIN = IL
+ IUMAX = IU
+ ELSE IF( LSAME( RANGE, 'A' ) ) THEN
+ ILMIN = 1
+ IUMAX = N
+ END IF
+*
+ NEIG = IUMAX - ILMIN + 1
+*
+ MQ0 = NUMROC( MAX( NEIG, NB, 2 ), NB, 0, 0, NPCOL )
+*
+ VECSIZE = 3 + 5*N + MAX( 18*NN, NP0*MQ0+2*NB*NB ) +
+ $ (2 + ICEIL( NEIG, NPROW*NPCOL ))*NN
+
+ VALSIZE = MAX(3, VALSIZE)
+ VECSIZE = MAX(3, VECSIZE)
+ MAXSIZE = VECSIZE
+*
+ RETURN
+*
+* End of PSLASIZESYEVR
+*
+ END
diff --git a/TESTING/EIG/psmatgen2.f b/TESTING/EIG/psmatgen2.f
new file mode 100644
index 0000000..dfdd564
--- /dev/null
+++ b/TESTING/EIG/psmatgen2.f
@@ -0,0 +1,702 @@
+ SUBROUTINE PSMATGEN2( ICTXT, AFORM, DIAG, M, N, MB, NB, A, LDA,
+ $ IAROW, IACOL, ISEED, IROFF, IRNUM, ICOFF,
+ $ ICNUM, MYROW, MYCOL, NPROW, NPCOL )
+*
+*
+* Modified version by K. L. Dackland (U added)
+* Modified version by Peter Poromaa, Heavy DIAG
+* Modified version by Robert Granat, R(andom) added
+*
+* .. Scalar Arguments ..
+ CHARACTER*1 AFORM, DIAG
+ INTEGER IACOL, IAROW, ICNUM, ICOFF, ICTXT, IRNUM,
+ $ IROFF, ISEED, LDA, M, MB, MYCOL, MYROW, N,
+ $ NB, NPCOL, NPROW
+* ..
+* .. Array Arguments ..
+ REAL A( LDA, * )
+* ..
+*
+* Purpose
+* =======
+*
+* PSMATGEN2 : Parallel Real Double precision MATrix GENerator.
+* Generate (or regenerate) a distributed matrix A (or sub-matrix of A).
+*
+* Arguments
+* =========
+*
+* ICTXT (global input) INTEGER
+* The BLACS context handle, indicating the global context of
+* the operation. The context itself is global.
+*
+* AFORM (global input) CHARACTER*1
+* if AFORM = 'U' : A returned is an Upper triangular matrix.
+* if AFORM = 'S' : A is returned is a symmetric matrix.
+* if AFORM = 'H' : A is returned is a Hermitian matrix.
+* if AFORM = 'T' : A is overwritten with the transpose of
+* what would normally be generated.
+* if AFORM = 'C' : A is overwritten with the conjugate trans-
+* pose of what would normally be generated.
+* if AFORM = 'R' A random matrix is generated.
+*
+* DIAG (global input) CHARACTER*1
+* if DIAG = 'D' : A is diagonally dominant.
+*
+* M (global input) INTEGER
+* The number of rows in the generated distributed matrix.
+*
+* N (global input) INTEGER
+* The number of columns in the generated distributed
+* matrix.
+*
+* MB (global input) INTEGER
+* The row blocking factor of the distributed matrix A.
+*
+* NB (global input) INTEGER
+* The column blocking factor of the distributed matrix A.
+*
+* A (local output) REAL, pointer into the local
+* memory to an array of dimension ( LDA, * ) containing the
+* local pieces of the distributed matrix.
+*
+* LDA (local input) INTEGER
+* The leading dimension of the array containing the local
+* pieces of the distributed matrix A.
+*
+* IAROW (global input) INTEGER
+* The row processor coordinate which holds the first block
+* of the distributed matrix A.
+*
+* IACOL (global input) INTEGER
+* The column processor coordinate which holds the first
+* block of the distributed matrix A.
+*
+* ISEED (global input) INTEGER
+* The seed number to generate the distributed matrix A.
+*
+* IROFF (local input) INTEGER
+* The number of local rows of A that have already been
+* generated. It should be a multiple of MB.
+*
+* IRNUM (local input) INTEGER
+* The number of local rows to be generated.
+*
+* ICOFF (local input) INTEGER
+* The number of local columns of A that have already been
+* generated. It should be a multiple of NB.
+*
+* ICNUM (local input) INTEGER
+* The number of local columns to be generated.
+*
+* MYROW (local input) INTEGER
+* The row process coordinate of the calling process.
+*
+* MYCOL (local input) INTEGER
+* The column process coordinate of the calling process.
+*
+* NPROW (global input) INTEGER
+* The number of process rows in the grid.
+*
+* NPCOL (global input) INTEGER
+* The number of process columns in the grid.
+*
+* Notes
+* =====
+*
+* The code is originally developed by David Walker, ORNL,
+* and modified by Jaeyoung Choi, ORNL.
+*
+* Reference: G. Fox et al.
+* Section 12.3 of "Solving problems on concurrent processors Vol. I"
+*
+* =====================================================================
+*
+* .. Parameters ..
+ INTEGER MULT0, MULT1, IADD0, IADD1
+ PARAMETER ( MULT0=20077, MULT1=16838, IADD0=12345,
+ $ IADD1=0 )
+ REAL ONE, TWO, ZERO
+ PARAMETER ( ONE = 1.0, TWO = 2.0, ZERO = 0.0)
+* ..
+* .. Local Scalars ..
+ LOGICAL SYMM, HERM, TRAN, UPPR, RANDOM
+ INTEGER I, IC, IK, INFO, IOFFC, IOFFR, IR, J, JK,
+ $ JUMP1, JUMP2, JUMP3, JUMP4, JUMP5, JUMP6,
+ $ JUMP7, MAXMN, MEND, MOFF, MP, MRCOL, MRROW,
+ $ NEND, NOFF, NPMB, NQ, NQNB
+* ..
+* .. Local Arrays ..
+ INTEGER IADD(2), IA1(2), IA2(2), IA3(2), IA4(2),
+ $ IA5(2), IB1(2), IB2(2), IB3(2), IC1(2), IC2(2),
+ $ IC3(2), IC4(2), IC5(2), IRAN1(2), IRAN2(2),
+ $ IRAN3(2), IRAN4(2), ITMP1(2), ITMP2(2),
+ $ ITMP3(2), JSEED(2), MULT(2)
+* ..
+* .. External Subroutines ..
+ EXTERNAL JUMPIT, PXERBLA, SETRAN, XJUMPM
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX, MOD
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ INTEGER ICEIL, NUMROC
+ REAL PSRAND
+ EXTERNAL ICEIL, NUMROC, LSAME, PSRAND
+* ..
+* .. Executable Statements ..
+*
+* Test the input arguments
+*
+ MP = NUMROC( M, MB, MYROW, IAROW, NPROW )
+ NQ = NUMROC( N, NB, MYCOL, IACOL, NPCOL )
+ SYMM = LSAME( AFORM, 'S' )
+ UPPR = LSAME( AFORM, 'U' )
+ HERM = LSAME( AFORM, 'H' )
+ TRAN = LSAME( AFORM, 'T' )
+ RANDOM = LSAME( AFORM, 'R' )
+*
+ INFO = 0
+ IF( .NOT.( UPPR.OR.SYMM.OR.HERM.OR.TRAN.OR.RANDOM ) .AND.
+ $ .NOT.LSAME( AFORM, 'C' ) .AND.
+ $ .NOT.LSAME( AFORM, 'N' ) ) THEN
+ INFO = 2
+ ELSE IF( .NOT.LSAME( DIAG, 'D' ) .AND.
+ $ .NOT.LSAME( DIAG, 'N' ) ) THEN
+ INFO = 3
+ ELSE IF( UPPR.OR.SYMM.OR.HERM ) THEN
+ IF( M.NE.N ) THEN
+ INFO = 5
+ ELSE IF( MB.NE.NB ) THEN
+ INFO = 7
+ END IF
+ ELSE IF( M.LT.0 ) THEN
+ INFO = 4
+ ELSE IF( N.LT.0 ) THEN
+ INFO = 5
+ ELSE IF( MB.LT.1 ) THEN
+ INFO = 6
+ ELSE IF( NB.LT.1 ) THEN
+ INFO = 7
+ ELSE IF( LDA.LT.0 ) THEN
+ INFO = 9
+ ELSE IF( ( IAROW.LT.0 ).OR.( IAROW.GE.NPROW ) ) THEN
+ INFO = 10
+ ELSE IF( ( IACOL.LT.0 ).OR.( IACOL.GE.NPCOL ) ) THEN
+ INFO = 11
+ ELSE IF( MOD(IROFF,MB).GT.0 ) THEN
+ INFO = 13
+ ELSE IF( IRNUM.GT.(MP-IROFF) ) THEN
+ INFO = 14
+ ELSE IF( MOD(ICOFF,NB).GT.0 ) THEN
+ INFO = 15
+ ELSE IF( ICNUM.GT.(NQ-ICOFF) ) THEN
+ INFO = 16
+ ELSE IF( ( MYROW.LT.0 ).OR.( MYROW.GE.NPROW ) ) THEN
+ INFO = 17
+ ELSE IF( ( MYCOL.LT.0 ).OR.( MYCOL.GE.NPCOL ) ) THEN
+ INFO = 18
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL PXERBLA( ICTXT, 'PSMATGEN2', INFO )
+ RETURN
+ END IF
+ MRROW = MOD( NPROW+MYROW-IAROW, NPROW )
+ MRCOL = MOD( NPCOL+MYCOL-IACOL, NPCOL )
+ NPMB = NPROW * MB
+ NQNB = NPCOL * NB
+ MOFF = IROFF / MB
+ NOFF = ICOFF / NB
+ MEND = ICEIL(IRNUM, MB) + MOFF
+ NEND = ICEIL(ICNUM, NB) + NOFF
+*
+ MULT(1) = MULT0
+ MULT(2) = MULT1
+ IADD(1) = IADD0
+ IADD(2) = IADD1
+ JSEED(1) = ISEED
+ JSEED(2) = 0
+*
+* Symmetric or Hermitian matrix will be generated.
+*
+ IF( SYMM.OR.HERM ) THEN
+*
+* First, generate the lower triangular part (with diagonal block)
+*
+ JUMP1 = 1
+ JUMP2 = NPMB
+ JUMP3 = M
+ JUMP4 = NQNB
+ JUMP5 = NB
+ JUMP6 = MRCOL
+ JUMP7 = MB*MRROW
+*
+ CALL XJUMPM( JUMP1, MULT, IADD, JSEED, IRAN1, IA1, IC1 )
+ CALL XJUMPM( JUMP2, MULT, IADD, IRAN1, ITMP1, IA2, IC2 )
+ CALL XJUMPM( JUMP3, MULT, IADD, IRAN1, ITMP1, IA3, IC3 )
+ CALL XJUMPM( JUMP4, IA3, IC3, IRAN1, ITMP1, IA4, IC4 )
+ CALL XJUMPM( JUMP5, IA3, IC3, IRAN1, ITMP1, IA5, IC5 )
+ CALL XJUMPM( JUMP6, IA5, IC5, IRAN1, ITMP3, ITMP1, ITMP2 )
+ CALL XJUMPM( JUMP7, MULT, IADD, ITMP3, IRAN1, ITMP1, ITMP2 )
+ CALL XJUMPM( NOFF, IA4, IC4, IRAN1, ITMP1, ITMP2, ITMP3 )
+ CALL XJUMPM( MOFF, IA2, IC2, ITMP1, IRAN1, ITMP2, ITMP3 )
+ CALL SETRAN( IRAN1, IA1, IC1 )
+*
+ DO 10 I = 1, 2
+ IB1(I) = IRAN1(I)
+ IB2(I) = IRAN1(I)
+ IB3(I) = IRAN1(I)
+ 10 CONTINUE
+*
+ JK = 1
+ DO 80 IC = NOFF+1, NEND
+ IOFFC = ((IC-1)*NPCOL+MRCOL) * NB
+ DO 70 I = 1, NB
+ IF( JK .GT. ICNUM ) GO TO 90
+*
+ IK = 1
+ DO 50 IR = MOFF+1, MEND
+ IOFFR = ((IR-1)*NPROW+MRROW) * MB
+*
+ IF( IOFFR .GT. IOFFC ) THEN
+ DO 20 J = 1, MB
+ IF( IK .GT. IRNUM ) GO TO 60
+ A(IK,JK) = ONE - TWO*PSRAND(0)
+ IK = IK + 1
+ 20 CONTINUE
+*
+ ELSE IF( IOFFC .EQ. IOFFR ) THEN
+ IK = IK + I - 1
+ IF( IK .GT. IRNUM ) GO TO 60
+ DO 30 J = 1, I-1
+ A(IK,JK) = ONE - TWO*PSRAND(0)
+ 30 CONTINUE
+ A(IK,JK) = ONE - TWO*PSRAND(0)
+ DO 40 J = 1, MB-I
+ IF( IK+J .GT. IRNUM ) GO TO 60
+ A(IK+J,JK) = ONE - TWO*PSRAND(0)
+ A(IK,JK+J) = A(IK+J,JK)
+ 40 CONTINUE
+ IK = IK + MB - I + 1
+ ELSE
+ IK = IK + MB
+ END IF
+*
+ CALL JUMPIT( IA2, IC2, IB1, IRAN2 )
+ IB1(1) = IRAN2(1)
+ IB1(2) = IRAN2(2)
+ 50 CONTINUE
+*
+ 60 CONTINUE
+ JK = JK + 1
+ CALL JUMPIT( IA3, IC3, IB2, IRAN3 )
+ IB1(1) = IRAN3(1)
+ IB1(2) = IRAN3(2)
+ IB2(1) = IRAN3(1)
+ IB2(2) = IRAN3(2)
+ 70 CONTINUE
+*
+ CALL JUMPIT( IA4, IC4, IB3, IRAN4 )
+ IB1(1) = IRAN4(1)
+ IB1(2) = IRAN4(2)
+ IB2(1) = IRAN4(1)
+ IB2(2) = IRAN4(2)
+ IB3(1) = IRAN4(1)
+ IB3(2) = IRAN4(2)
+ 80 CONTINUE
+*
+* Next, generate the upper triangular part.
+*
+ 90 CONTINUE
+ MULT(1) = MULT0
+ MULT(2) = MULT1
+ IADD(1) = IADD0
+ IADD(2) = IADD1
+ JSEED(1) = ISEED
+ JSEED(2) = 0
+*
+ JUMP1 = 1
+ JUMP2 = NQNB
+ JUMP3 = N
+ JUMP4 = NPMB
+ JUMP5 = MB
+ JUMP6 = MRROW
+ JUMP7 = NB*MRCOL
+*
+ CALL XJUMPM( JUMP1, MULT, IADD, JSEED, IRAN1, IA1, IC1 )
+ CALL XJUMPM( JUMP2, MULT, IADD, IRAN1, ITMP1, IA2, IC2 )
+ CALL XJUMPM( JUMP3, MULT, IADD, IRAN1, ITMP1, IA3, IC3 )
+ CALL XJUMPM( JUMP4, IA3, IC3, IRAN1, ITMP1, IA4, IC4 )
+ CALL XJUMPM( JUMP5, IA3, IC3, IRAN1, ITMP1, IA5, IC5 )
+ CALL XJUMPM( JUMP6, IA5, IC5, IRAN1, ITMP3, ITMP1, ITMP2 )
+ CALL XJUMPM( JUMP7, MULT, IADD, ITMP3, IRAN1, ITMP1, ITMP2 )
+ CALL XJUMPM( MOFF, IA4, IC4, IRAN1, ITMP1, ITMP2, ITMP3 )
+ CALL XJUMPM( NOFF, IA2, IC2, ITMP1, IRAN1, ITMP2, ITMP3 )
+ CALL SETRAN( IRAN1, IA1, IC1 )
+*
+ DO 100 I = 1, 2
+ IB1(I) = IRAN1(I)
+ IB2(I) = IRAN1(I)
+ IB3(I) = IRAN1(I)
+ 100 CONTINUE
+*
+ IK = 1
+ DO 150 IR = MOFF+1, MEND
+ IOFFR = ((IR-1)*NPROW+MRROW) * MB
+ DO 140 J = 1, MB
+ IF( IK .GT. IRNUM ) GO TO 160
+ JK = 1
+ DO 120 IC = NOFF+1, NEND
+ IOFFC = ((IC-1)*NPCOL+MRCOL) * NB
+ IF( IOFFC .GT. IOFFR ) THEN
+ DO 110 I = 1, NB
+ IF( JK .GT. ICNUM ) GO TO 130
+ A(IK,JK) = ONE - TWO*PSRAND(0)
+ JK = JK + 1
+ 110 CONTINUE
+ ELSE
+ JK = JK + NB
+ END IF
+ CALL JUMPIT( IA2, IC2, IB1, IRAN2 )
+ IB1(1) = IRAN2(1)
+ IB1(2) = IRAN2(2)
+ 120 CONTINUE
+*
+ 130 CONTINUE
+ IK = IK + 1
+ CALL JUMPIT( IA3, IC3, IB2, IRAN3 )
+ IB1(1) = IRAN3(1)
+ IB1(2) = IRAN3(2)
+ IB2(1) = IRAN3(1)
+ IB2(2) = IRAN3(2)
+ 140 CONTINUE
+*
+ CALL JUMPIT( IA4, IC4, IB3, IRAN4 )
+ IB1(1) = IRAN4(1)
+ IB1(2) = IRAN4(2)
+ IB2(1) = IRAN4(1)
+ IB2(2) = IRAN4(2)
+ IB3(1) = IRAN4(1)
+ IB3(2) = IRAN4(2)
+ 150 CONTINUE
+ 160 CONTINUE
+*
+* Generate an upper triangular matrix.
+*
+ ELSE IF ( UPPR ) THEN
+ JUMP1 = 1
+ JUMP2 = NPMB
+ JUMP3 = M
+ JUMP4 = NQNB
+ JUMP5 = NB
+ JUMP6 = MRCOL
+ JUMP7 = MB*MRROW
+*
+ CALL XJUMPM( JUMP1, MULT, IADD, JSEED, IRAN1, IA1, IC1 )
+ CALL XJUMPM( JUMP2, MULT, IADD, IRAN1, ITMP1, IA2, IC2 )
+ CALL XJUMPM( JUMP3, MULT, IADD, IRAN1, ITMP1, IA3, IC3 )
+ CALL XJUMPM( JUMP4, IA3, IC3, IRAN1, ITMP1, IA4, IC4 )
+ CALL XJUMPM( JUMP5, IA3, IC3, IRAN1, ITMP1, IA5, IC5 )
+ CALL XJUMPM( JUMP6, IA5, IC5, IRAN1, ITMP3, ITMP1, ITMP2 )
+ CALL XJUMPM( JUMP7, MULT, IADD, ITMP3, IRAN1, ITMP1, ITMP2 )
+ CALL XJUMPM( NOFF, IA4, IC4, IRAN1, ITMP1, ITMP2, ITMP3 )
+ CALL XJUMPM( MOFF, IA2, IC2, ITMP1, IRAN1, ITMP2, ITMP3 )
+ CALL SETRAN( IRAN1, IA1, IC1 )
+*
+ DO 1000 I = 1, 2
+ IB1(I) = IRAN1(I)
+ IB2(I) = IRAN1(I)
+ IB3(I) = IRAN1(I)
+ 1000 CONTINUE
+*
+ JK = 1
+ DO 8000 IC = NOFF+1, NEND
+ IOFFC = ((IC-1)*NPCOL+MRCOL) * NB
+ DO 7000 I = 1, NB
+ IF( JK .GT. ICNUM ) GO TO 8000
+*
+ IK = 1
+ DO 5000 IR = MOFF+1, MEND
+ IOFFR = ((IR-1)*NPROW+MRROW) * MB
+*
+ IF( IOFFC .EQ. IOFFR ) THEN
+ IK = IK + I - 1
+ IF( IK .GT. IRNUM ) GO TO 6000
+ DO 3000 J = 1, I-1
+ A(IK,JK) = ONE - TWO*PSRAND(0)
+ 3000 CONTINUE
+ A(IK,JK) = ONE - TWO*PSRAND(0)
+ DO 4000 J = 1, MB-I
+ IF( IK+J .GT. IRNUM ) GO TO 6000
+ A(IK,JK+J) = ONE - TWO*PSRAND(0)
+ 4000 CONTINUE
+ IK = IK + MB - I + 1
+ ELSE
+ IK = IK + MB
+ END IF
+*
+ CALL JUMPIT( IA2, IC2, IB1, IRAN2 )
+ IB1(1) = IRAN2(1)
+ IB1(2) = IRAN2(2)
+ 5000 CONTINUE
+*
+ 6000 CONTINUE
+ JK = JK + 1
+ CALL JUMPIT( IA3, IC3, IB2, IRAN3 )
+ IB1(1) = IRAN3(1)
+ IB1(2) = IRAN3(2)
+ IB2(1) = IRAN3(1)
+ IB2(2) = IRAN3(2)
+ 7000 CONTINUE
+*
+ CALL JUMPIT( IA4, IC4, IB3, IRAN4 )
+ IB1(1) = IRAN4(1)
+ IB1(2) = IRAN4(2)
+ IB2(1) = IRAN4(1)
+ IB2(2) = IRAN4(2)
+ IB3(1) = IRAN4(1)
+ IB3(2) = IRAN4(2)
+ 8000 CONTINUE
+ MULT(1) = MULT0
+ MULT(2) = MULT1
+ IADD(1) = IADD0
+ IADD(2) = IADD1
+ JSEED(1) = ISEED
+ JSEED(2) = 0
+*
+ JUMP1 = 1
+ JUMP2 = NQNB
+ JUMP3 = N
+ JUMP4 = NPMB
+ JUMP5 = MB
+ JUMP6 = MRROW
+ JUMP7 = NB*MRCOL
+*
+ CALL XJUMPM( JUMP1, MULT, IADD, JSEED, IRAN1, IA1, IC1 )
+ CALL XJUMPM( JUMP2, MULT, IADD, IRAN1, ITMP1, IA2, IC2 )
+ CALL XJUMPM( JUMP3, MULT, IADD, IRAN1, ITMP1, IA3, IC3 )
+ CALL XJUMPM( JUMP4, IA3, IC3, IRAN1, ITMP1, IA4, IC4 )
+ CALL XJUMPM( JUMP5, IA3, IC3, IRAN1, ITMP1, IA5, IC5 )
+ CALL XJUMPM( JUMP6, IA5, IC5, IRAN1, ITMP3, ITMP1, ITMP2 )
+ CALL XJUMPM( JUMP7, MULT, IADD, ITMP3, IRAN1, ITMP1, ITMP2 )
+ CALL XJUMPM( MOFF, IA4, IC4, IRAN1, ITMP1, ITMP2, ITMP3 )
+ CALL XJUMPM( NOFF, IA2, IC2, ITMP1, IRAN1, ITMP2, ITMP3 )
+ CALL SETRAN( IRAN1, IA1, IC1 )
+*
+ DO 1110 I = 1, 2
+ IB1(I) = IRAN1(I)
+ IB2(I) = IRAN1(I)
+ IB3(I) = IRAN1(I)
+ 1110 CONTINUE
+*
+ IK = 1
+ DO 1500 IR = MOFF+1, MEND
+ IOFFR = ((IR-1)*NPROW+MRROW) * MB
+ DO 1400 J = 1, MB
+ IF( IK .GT. IRNUM ) GO TO 1600
+ JK = 1
+ DO 1200 IC = NOFF+1, NEND
+ IOFFC = ((IC-1)*NPCOL+MRCOL) * NB
+ IF( IOFFC .GT. IOFFR ) THEN
+ DO 1100 I = 1, NB
+ IF( JK .GT. ICNUM ) GO TO 1300
+ A(IK,JK) = ONE - TWO*PSRAND(0)
+ JK = JK + 1
+ 1100 CONTINUE
+ ELSE
+ JK = JK + NB
+ END IF
+ CALL JUMPIT( IA2, IC2, IB1, IRAN2 )
+ IB1(1) = IRAN2(1)
+ IB1(2) = IRAN2(2)
+ 1200 CONTINUE
+*
+ 1300 CONTINUE
+ IK = IK + 1
+ CALL JUMPIT( IA3, IC3, IB2, IRAN3 )
+ IB1(1) = IRAN3(1)
+ IB1(2) = IRAN3(2)
+ IB2(1) = IRAN3(1)
+ IB2(2) = IRAN3(2)
+ 1400 CONTINUE
+*
+ CALL JUMPIT( IA4, IC4, IB3, IRAN4 )
+ IB1(1) = IRAN4(1)
+ IB1(2) = IRAN4(2)
+ IB2(1) = IRAN4(1)
+ IB2(2) = IRAN4(2)
+ IB3(1) = IRAN4(1)
+ IB3(2) = IRAN4(2)
+ 1500 CONTINUE
+ 1600 CONTINUE
+*
+* (Conjugate) Transposed matrix A will be generated.
+*
+ ELSE IF( TRAN .OR. LSAME( AFORM, 'C' ) ) THEN
+*
+ JUMP1 = 1
+ JUMP2 = NQNB
+ JUMP3 = N
+ JUMP4 = NPMB
+ JUMP5 = MB
+ JUMP6 = MRROW
+ JUMP7 = NB*MRCOL
+*
+ CALL XJUMPM( JUMP1, MULT, IADD, JSEED, IRAN1, IA1, IC1 )
+ CALL XJUMPM( JUMP2, MULT, IADD, IRAN1, ITMP1, IA2, IC2 )
+ CALL XJUMPM( JUMP3, MULT, IADD, IRAN1, ITMP1, IA3, IC3 )
+ CALL XJUMPM( JUMP4, IA3, IC3, IRAN1, ITMP1, IA4, IC4 )
+ CALL XJUMPM( JUMP5, IA3, IC3, IRAN1, ITMP1, IA5, IC5 )
+ CALL XJUMPM( JUMP6, IA5, IC5, IRAN1, ITMP3, ITMP1, ITMP2 )
+ CALL XJUMPM( JUMP7, MULT, IADD, ITMP3, IRAN1, ITMP1, ITMP2 )
+ CALL XJUMPM( MOFF, IA4, IC4, IRAN1, ITMP1, ITMP2, ITMP3 )
+ CALL XJUMPM( NOFF, IA2, IC2, ITMP1, IRAN1, ITMP2, ITMP3 )
+ CALL SETRAN( IRAN1, IA1, IC1 )
+*
+ DO 170 I = 1, 2
+ IB1(I) = IRAN1(I)
+ IB2(I) = IRAN1(I)
+ IB3(I) = IRAN1(I)
+ 170 CONTINUE
+*
+ IK = 1
+ DO 220 IR = MOFF+1, MEND
+ IOFFR = ((IR-1)*NPROW+MRROW) * MB
+ DO 210 J = 1, MB
+ IF( IK .GT. IRNUM ) GO TO 230
+ JK = 1
+ DO 190 IC = NOFF+1, NEND
+ IOFFC = ((IC-1)*NPCOL+MRCOL) * NB
+ DO 180 I = 1, NB
+ IF( JK .GT. ICNUM ) GO TO 200
+ A(IK,JK) = ONE - TWO*PSRAND(0)
+ JK = JK + 1
+ 180 CONTINUE
+ CALL JUMPIT( IA2, IC2, IB1, IRAN2 )
+ IB1(1) = IRAN2(1)
+ IB1(2) = IRAN2(2)
+ 190 CONTINUE
+*
+ 200 CONTINUE
+ IK = IK + 1
+ CALL JUMPIT( IA3, IC3, IB2, IRAN3 )
+ IB1(1) = IRAN3(1)
+ IB1(2) = IRAN3(2)
+ IB2(1) = IRAN3(1)
+ IB2(2) = IRAN3(2)
+ 210 CONTINUE
+*
+ CALL JUMPIT( IA4, IC4, IB3, IRAN4 )
+ IB1(1) = IRAN4(1)
+ IB1(2) = IRAN4(2)
+ IB2(1) = IRAN4(1)
+ IB2(2) = IRAN4(2)
+ IB3(1) = IRAN4(1)
+ IB3(2) = IRAN4(2)
+ 220 CONTINUE
+ 230 CONTINUE
+*
+* A random matrix is generated.
+*
+ ELSEIF( RANDOM ) THEN
+*
+ JUMP1 = 1
+ JUMP2 = NPMB
+ JUMP3 = M
+ JUMP4 = NQNB
+ JUMP5 = NB
+ JUMP6 = MRCOL
+ JUMP7 = MB*MRROW
+*
+ CALL XJUMPM( JUMP1, MULT, IADD, JSEED, IRAN1, IA1, IC1 )
+ CALL XJUMPM( JUMP2, MULT, IADD, IRAN1, ITMP1, IA2, IC2 )
+ CALL XJUMPM( JUMP3, MULT, IADD, IRAN1, ITMP1, IA3, IC3 )
+ CALL XJUMPM( JUMP4, IA3, IC3, IRAN1, ITMP1, IA4, IC4 )
+ CALL XJUMPM( JUMP5, IA3, IC3, IRAN1, ITMP1, IA5, IC5 )
+ CALL XJUMPM( JUMP6, IA5, IC5, IRAN1, ITMP3, ITMP1, ITMP2 )
+ CALL XJUMPM( JUMP7, MULT, IADD, ITMP3, IRAN1, ITMP1, ITMP2 )
+ CALL XJUMPM( NOFF, IA4, IC4, IRAN1, ITMP1, ITMP2, ITMP3 )
+ CALL XJUMPM( MOFF, IA2, IC2, ITMP1, IRAN1, ITMP2, ITMP3 )
+ CALL SETRAN( IRAN1, IA1, IC1 )
+*
+ DO 240 I = 1, 2
+ IB1(I) = IRAN1(I)
+ IB2(I) = IRAN1(I)
+ IB3(I) = IRAN1(I)
+ 240 CONTINUE
+*
+ JK = 1
+ DO 290 IC = NOFF+1, NEND
+ IOFFC = ((IC-1)*NPCOL+MRCOL) * NB
+ DO 280 I = 1, NB
+ IF( JK .GT. ICNUM ) GO TO 300
+ IK = 1
+ DO 260 IR = MOFF+1, MEND
+ IOFFR = ((IR-1)*NPROW+MRROW) * MB
+ DO 250 J = 1, MB
+ IF( IK .GT. IRNUM ) GO TO 270
+ A(IK,JK) = ONE - TWO*PSRAND(0)
+ IK = IK + 1
+ 250 CONTINUE
+ CALL JUMPIT( IA2, IC2, IB1, IRAN2 )
+ IB1(1) = IRAN2(1)
+ IB1(2) = IRAN2(2)
+ 260 CONTINUE
+*
+ 270 CONTINUE
+ JK = JK + 1
+ CALL JUMPIT( IA3, IC3, IB2, IRAN3 )
+ IB1(1) = IRAN3(1)
+ IB1(2) = IRAN3(2)
+ IB2(1) = IRAN3(1)
+ IB2(2) = IRAN3(2)
+ 280 CONTINUE
+*
+ CALL JUMPIT( IA4, IC4, IB3, IRAN4 )
+ IB1(1) = IRAN4(1)
+ IB1(2) = IRAN4(2)
+ IB2(1) = IRAN4(1)
+ IB2(2) = IRAN4(2)
+ IB3(1) = IRAN4(1)
+ IB3(2) = IRAN4(2)
+ 290 CONTINUE
+ 300 CONTINUE
+ END IF
+*
+* Diagonally dominant matrix will be generated.
+*
+ IF( LSAME( DIAG, 'D' ) ) THEN
+ IF( MB.NE.NB ) THEN
+ WRITE(*,*) 'Diagonally dominant matrices with rowNB not'//
+ $ ' equal colNB is not supported!'
+ RETURN
+ END IF
+*
+ MAXMN = MAX(M, N)
+ JK = 1
+ DO 340 IC = NOFF+1, NEND
+ IOFFC = ((IC-1)*NPCOL+MRCOL) * NB
+ IK = 1
+ DO 320 IR = MOFF+1, MEND
+ IOFFR = ((IR-1)*NPROW+MRROW) * MB
+ IF( IOFFC.EQ.IOFFR ) THEN
+ DO 310 J = 0, MB-1
+ IF( IK .GT. IRNUM ) GO TO 330
+ A(IK,JK+J) = ABS(A(IK,JK+J)) + MAXMN
+ IK = IK + 1
+ 310 CONTINUE
+ ELSE
+ IK = IK + MB
+ END IF
+ 320 CONTINUE
+ 330 CONTINUE
+ JK = JK + NB
+ 340 CONTINUE
+ END IF
+*
+ RETURN
+*
+* End of PSMATGEN2
+*
+ END
diff --git a/TESTING/EIG/pssepchk.f b/TESTING/EIG/pssepchk.f
index 08870a9..3ed5b0d 100644
--- a/TESTING/EIG/pssepchk.f
+++ b/TESTING/EIG/pssepchk.f
@@ -4,10 +4,9 @@
$ Q, IQ, JQ, DESCQ, C, IC, JC, DESCC, W, WORK,
$ LWORK, TSTNRM, RESULT )
*
-* -- ScaLAPACK routine (version 1.7) --
-* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
-* and University of California, Berkeley.
-* November 15, 1997
+* -- ScaLAPACK routine (version 2.0.2) --
+* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver
+* May 1 2012
*
* .. Scalar Arguments ..
INTEGER IA, IC, IQ, JA, JC, JQ, LWORK, MS, NV, RESULT
@@ -215,7 +214,7 @@
CALL BLACS_GRIDINFO( DESCA( CTXT_ ), NPROW, NPCOL, MYROW, MYCOL )
*
INFO = 0
- CALL CHK1MAT( MS, 1, MS, 2, IA, JA, DESCA, 6, INFO )
+ CALL CHK1MAT( MS, 1, MS, 1, IA, JA, DESCA, 6, INFO )
CALL CHK1MAT( MS, 1, NV, 2, IQ, JQ, DESCQ, 12, INFO )
CALL CHK1MAT( MS, 1, NV, 2, IC, JC, DESCC, 16, INFO )
*
diff --git a/TESTING/EIG/pssepinfo.f b/TESTING/EIG/pssepinfo.f
index e46f2d5..f4cf230 100644
--- a/TESTING/EIG/pssepinfo.f
+++ b/TESTING/EIG/pssepinfo.f
@@ -169,6 +169,9 @@
WRITE( NOUT, FMT = 9997 )TESTSUMMRY
END IF
*
+* assign a default
+ INFO = 0
+*
IF( IAM.EQ.0 ) THEN
READ( NIN, FMT = * )NMATSIZES
CALL IGEBS2D( CONTEXT, 'All', ' ', 1, 1, NMATSIZES, 1 )
diff --git a/TESTING/EIG/psseprdriver.f b/TESTING/EIG/psseprdriver.f
new file mode 100644
index 0000000..f597f73
--- /dev/null
+++ b/TESTING/EIG/psseprdriver.f
@@ -0,0 +1,260 @@
+ PROGRAM PSSEPRDRIVER
+*
+* Parallel REAL symmetric eigenproblem test driver for PSSYEVR
+*
+ IMPLICIT NONE
+*
+* The user should modify TOTMEM to indicate the maximum amount of
+* memory in bytes her system has. Remember to leave room in memory
+* for operating system, the BLACS buffer, etc. REALSZ
+* indicates the length in bytes on the given platform for a number,
+* real for SINGLE/DOUBLE PRECISION, and complex for COMPLEX/COMPLEX*16.
+* For example, on a standard system, the length of a
+* REAL is 4, and an integer takes up 4 bytes. Some playing around
+* to discover what the maximum value you can set MEMSIZ to may be
+* required.
+* All arrays used by factorization and solve are allocated out of
+* big array called MEM.
+*
+* TESTS PERFORMED
+* ===============
+*
+* This routine performs tests for combinations of: matrix size, process
+* configuration (nprow and npcol), block size (nb),
+* matrix type, range of eigenvalue (all, by value, by index),
+* and upper vs. lower storage.
+*
+* It returns an error message when heterogeneity is detected.
+*
+* The input file allows multiple requests where each one is
+* of the following sets:
+* matrix sizes: n
+* process configuration triples: nprow, npcol, nb
+* matrix types:
+* eigenvalue requests: all, by value, by position
+* storage (upper vs. lower): uplo
+*
+* TERMS:
+* Request - means a set of tests, which is the cross product of
+* a set of specifications from the input file.
+* Test - one element in the cross product, i.e. a specific input
+* size and type, process configuration, etc.
+*
+* .. Parameters ..
+*
+ INTEGER TOTMEM, REALSZ, NIN
+ PARAMETER ( TOTMEM = 100000000, REALSZ = 4, NIN = 11 )
+ INTEGER MEMSIZ
+ PARAMETER ( MEMSIZ = TOTMEM / REALSZ )
+* ..
+* .. Local Scalars ..
+ CHARACTER HETERO
+ CHARACTER*80 SUMMRY, USRINFO
+ INTEGER CONTEXT, IAM, INFO, ISIEEE, MAXNODES, NNOCHECK,
+ $ NOUT, NPASSED, NPROCS, NSKIPPED, NTESTS
+* ..
+* .. Local Arrays ..
+*
+ INTEGER ISEED( 4 )
+ REAL MEM( MEMSIZ )
+* ..
+* .. External Functions ..
+ REAL SLAMCH
+ EXTERNAL SLAMCH
+* ..
+* .. External Subroutines ..
+*
+ EXTERNAL BLACS_EXIT, BLACS_GET, BLACS_GRIDEXIT,
+ $ BLACS_GRIDINIT, BLACS_PINFO, BLACS_SETUP,
+ $ IGAMN2D, PSLACHKIEEE, PSLASNBT, PSSEPRREQ
+* ..
+* .. Executable Statements ..
+*
+* Get starting information
+*
+ CALL BLACS_PINFO( IAM, NPROCS )
+*
+*
+ IF( IAM.EQ.0 ) THEN
+*
+* Open file and skip data file header
+*
+ OPEN( UNIT = NIN, FILE = 'SEPR.dat', STATUS = 'OLD' )
+ READ( NIN, FMT = * )SUMMRY
+ SUMMRY = ' '
+*
+* Read in user-supplied info about machine type, compiler, etc.
+*
+ READ( NIN, FMT = 9999 )USRINFO
+*
+* Read name and unit number for summary output file
+*
+ READ( NIN, FMT = * )SUMMRY
+ READ( NIN, FMT = * )NOUT
+ IF( NOUT.NE.0 .AND. NOUT.NE.6 )
+ $ OPEN( NOUT, FILE = SUMMRY, STATUS = 'UNKNOWN' )
+ READ( NIN, FMT = * )MAXNODES
+ READ( NIN, FMT = * )HETERO
+ END IF
+*
+ IF( NPROCS.LT.1 ) THEN
+ CALL BLACS_SETUP( IAM, MAXNODES )
+ NPROCS = MAXNODES
+ END IF
+*
+ CALL BLACS_GET( -1, 0, CONTEXT )
+ CALL BLACS_GRIDINIT( CONTEXT, 'R', 1, NPROCS )
+*
+ CALL PSLASNBT( ISIEEE )
+*
+ CALL IGAMN2D( CONTEXT, 'a', ' ', 1, 1, ISIEEE, 1, 1, 1, -1, -1,
+ $ 0 )
+*
+ IF( ( ISIEEE.NE.0 ) ) THEN
+ IF( IAM.EQ.0 ) THEN
+ WRITE( NOUT, FMT = 9997 )
+ WRITE( NOUT, FMT = 9996 )
+ WRITE( NOUT, FMT = 9995 )
+ END IF
+*
+ CALL PSLACHKIEEE( ISIEEE, SLAMCH( 'O' ), SLAMCH( 'U' ) )
+*
+ CALL IGAMN2D( CONTEXT, 'a', ' ', 1, 1, ISIEEE, 1, 1, 1, -1, -1,
+ $ 0 )
+*
+ IF( ISIEEE.EQ.0 ) THEN
+ GO TO 20
+ END IF
+*
+ IF( IAM.EQ.0 ) THEN
+ WRITE( NOUT, FMT = 9986 )
+ END IF
+*
+ END IF
+*
+ IF( IAM.EQ.0 ) THEN
+ WRITE( NOUT, FMT = 9999 )
+ $ 'Test ScaLAPACK symmetric eigendecomposition routine.'
+ WRITE( NOUT, FMT = 9999 )USRINFO
+ WRITE( NOUT, FMT = 9999 )' '
+ WRITE( NOUT, FMT = 9999 )'Running tests of the parallel ' //
+ $ 'symmetric eigenvalue routine: PSSYEVR.'
+ WRITE( NOUT, FMT = 9999 )'The following scaled residual ' //
+ $ 'checks will be computed:'
+ WRITE( NOUT, FMT = 9999 )' ||AQ - QL|| ' //
+ $ '/ ((abstol + ||A|| * eps) * N)'
+ WRITE( NOUT, FMT = 9999 )' ||Q^T*Q - I|| ' // '/ (N * eps)'
+ WRITE( NOUT, FMT = 9999 )
+ WRITE( NOUT, FMT = 9999 )'An explanation of the ' //
+ $ 'input/output parameters follows:'
+ WRITE( NOUT, FMT = 9999 )'RESULT : passed; or ' //
+ $ 'an indication of which eigen request test failed'
+ WRITE( NOUT, FMT = 9999 )
+ $ 'N : The number of rows and columns ' //
+ $ 'of the matrix A.'
+ WRITE( NOUT, FMT = 9999 )
+ $ 'P : The number of process rows.'
+ WRITE( NOUT, FMT = 9999 )
+ $ 'Q : The number of process columns.'
+ WRITE( NOUT, FMT = 9999 )
+ $ 'NB : The size of the square blocks' //
+ $ ' the matrix A is split into.'
+ WRITE( NOUT, FMT = 9999 )
+ $ 'THRESH : If a residual value is less ' //
+ $ 'than THRESH, RESULT = PASSED.'
+ WRITE( NOUT, FMT = 9999 )
+ $ 'TYP : matrix type (see PSSEPRTST).'
+ WRITE( NOUT, FMT = 9999 )'SUB : Subtests (Y/N).'
+ WRITE( NOUT, FMT = 9999 )'WALL : Wallclock time.'
+ WRITE( NOUT, FMT = 9999 )'CPU : CPU time.'
+ WRITE( NOUT, FMT = 9999 )'CHK : ||AQ - QL|| ' //
+ $ '/ ((abstol + ||A|| * eps) * N)'
+ WRITE( NOUT, FMT = 9999 )'QTQ : ||Q^T*Q - I||/ (N * eps)'
+ WRITE( NOUT, FMT = 9999 )
+ $ ' : when the adjusted QTQ norm exceeds THRESH',
+ $ ' it is printed,'
+ WRITE( NOUT, FMT = 9999 )
+ $ ' otherwise the true QTQ norm is printed.'
+ WRITE( NOUT, FMT = 9999 )
+ $ ' : If more than one test is done, CHK and QTQ '
+ WRITE( NOUT, FMT = 9999 )
+ $ ' are the max over all eigentests performed.'
+ WRITE( NOUT, FMT = 9999 )
+ $ 'TEST : EVR - testing PSSYEVR'
+ WRITE( NOUT, FMT = 9999 )' '
+ END IF
+*
+ NTESTS = 0
+ NPASSED = 0
+ NSKIPPED = 0
+ NNOCHECK = 0
+*
+ IF( IAM.EQ.0 ) THEN
+ WRITE( NOUT, FMT = 9979 )
+ WRITE( NOUT, FMT = 9978 )
+ END IF
+*
+ 10 CONTINUE
+*
+ ISEED( 1 ) = 139
+ ISEED( 2 ) = 1139
+ ISEED( 3 ) = 2139
+ ISEED( 4 ) = 3139
+*
+ CALL PSSEPRREQ( HETERO, NIN, MEM, MEMSIZ, NOUT, ISEED, NTESTS,
+ $ NSKIPPED, NNOCHECK, NPASSED, INFO )
+ IF( INFO.EQ.0 )
+ $ GO TO 10
+*
+ IF( IAM.EQ.0 ) THEN
+ WRITE( NOUT, FMT = 9985 )NTESTS
+ WRITE( NOUT, FMT = 9984 )NPASSED
+ WRITE( NOUT, FMT = 9983 )NNOCHECK
+ WRITE( NOUT, FMT = 9982 )NSKIPPED
+ WRITE( NOUT, FMT = 9981 )NTESTS - NPASSED - NSKIPPED -
+ $ NNOCHECK
+ WRITE( NOUT, FMT = * )
+ WRITE( NOUT, FMT = * )
+ WRITE( NOUT, FMT = 9980 )
+ END IF
+*
+* Uncomment this line on SUN systems to avoid the useless print out
+*
+c CALL IEEE_FLAGS( 'clear', 'exception', 'underflow', ' ')
+*
+ 20 CONTINUE
+ IF( IAM.EQ.0 ) THEN
+ CLOSE ( NIN )
+ IF( NOUT.NE.6 .AND. NOUT.NE.0 )
+ $ CLOSE ( NOUT )
+ END IF
+*
+ CALL BLACS_GRIDEXIT( CONTEXT )
+*
+ CALL BLACS_EXIT( 0 )
+ STOP
+*
+ 9999 FORMAT( A )
+ 9997 FORMAT( 'Check if overflow is handled in ieee default manner.' )
+ 9996 FORMAT( 'If this is the last output you see, you should assume')
+ 9995 FORMAT( 'that overflow caused a floating point exception.' )
+*
+ 9986 FORMAT( 'Test ok. The system appears to handle ieee overflow.' )
+*
+ 9985 FORMAT( 'Finished ', I6, ' tests, with the following results:' )
+ 9984 FORMAT( I5, ' tests completed and passed residual checks.' )
+ 9983 FORMAT( I5, ' tests completed without checking.' )
+ 9982 FORMAT( I5, ' tests skipped for lack of memory.' )
+ 9981 FORMAT( I5, ' tests completed and failed.' )
+ 9980 FORMAT( 'END OF TESTS.' )
+ 9979 FORMAT( ' N NB P Q TYP SUB WALL CPU ',
+ $ ' CHK QTQ CHECK TEST' )
+ 9978 FORMAT( ' ----- --- --- --- --- --- -------- --------',
+ $ ' --------- --------- ----- ----' )
+*
+* End of PSSEPRDRIVER
+*
+ END
+
+
+
diff --git a/TESTING/EIG/psseprreq.f b/TESTING/EIG/psseprreq.f
new file mode 100644
index 0000000..3118c69
--- /dev/null
+++ b/TESTING/EIG/psseprreq.f
@@ -0,0 +1,220 @@
+ SUBROUTINE PSSEPRREQ( HETERO, NIN, MEM, MEMSIZE, NOUT, ISEED,
+ $ NTESTS, NSKIPPED, NNOCHECK, NPASSED, INFO )
+*
+* -- ScaLAPACK routine (@(MODE)version *TBA*) --
+* University of California, Berkeley and
+* University of Tennessee, Knoxville.
+* October 21, 2006
+*
+ IMPLICIT NONE
+*
+* .. Scalar Arguments ..
+ CHARACTER HETERO
+ INTEGER INFO, MEMSIZE, NIN, NNOCHECK, NOUT, NPASSED,
+ $ NSKIPPED, NTESTS
+* ..
+* .. Array Arguments ..
+ INTEGER ISEED( 4 )
+ REAL MEM( MEMSIZE )
+*
+* Purpose
+* =======
+*
+* PSSEPRREQ performs one request from the input file 'SEPR.dat'
+* A request is the cross product of the specifications in the
+* input file. It prints one line per test.
+*
+* Arguments
+* =========
+*
+* NIN (local input) INTEGER
+* The unit number for the input file 'SEPR.dat'
+*
+* MEM (local input ) REAL ARRAY, dimension MEMSIZE
+* Array encompassing the available single precision memory
+*
+* MEMSIZE (local input) INTEGER
+* Size of MEM array
+*
+* NOUT (local input) INTEGER
+* The unit number for output file.
+* NOUT = 6, output to screen,
+* NOUT = 0, output to stderr.
+* NOUT = 13, output to file, divide thresh by 10
+* NOUT = 14, output to file, divide thresh by 20
+* Only used on node 0.
+* NOUT = 13, 14 allow the threshold to be tighter for our
+* internal testing which means that when a user reports
+* a threshold error, it is more likely to be significant.
+*
+* ISEED (global input/output) INTEGER array, dimension 4
+* Random number generator seed
+*
+* NTESTS (global input/output) INTEGER
+* NTESTS = NTESTS + tests requested
+*
+* NSKIPPED (global input/output) INTEGER
+* NSKIPPED = NSKIPPED + tests skipped
+*
+* NNOCHECK (global input/output) INTEGER
+* NNOCHECK = NNOCHECK + tests completed but not checked
+*
+* NPASSED (global input/output) INTEGER
+* NPASSED = NPASSED + tests which passed all checks
+*
+* INFO (global output) INTEGER
+* 0 = test request ran
+* -1 = end of file
+* -2 = incorrect .dat file
+*
+* .. Parameters ..
+*
+ INTEGER DLEN_
+ PARAMETER ( DLEN_ = 9 )
+ INTEGER REALSZ, INTGSZ
+ PARAMETER ( REALSZ = 4, INTGSZ = 4 )
+ INTEGER MAXSETSIZE
+ PARAMETER ( MAXSETSIZE = 50 )
+* ..
+* .. Local Scalars ..
+ CHARACTER SUBTESTS
+ INTEGER CONTEXT, IAM, IMIDPAD, INITCON, IPOSTPAD,
+ $ IPREPAD, ISIZESUBTST, ISIZEEVR, ISIZETST,
+ $ LDA, LLWORK, MATSIZE, MATTYPE, MYCOL, MYROW, N,
+ $ NB, NMATSIZES, NMATTYPES, NNODES, NP, NPCOL,
+ $ NPCONFIGS, NPROW, NQ, NUPLOS, ORDER, PCONFIG,
+ $ PTRA, PTRCOPYA, PTRGAP, PTRICLUS, PTRIFAIL,
+ $ PTRIWRK, PTRW, PTRW2, PTRWORK, PTRZ, RES,
+ $ SIZECHK, SIZEMQRLEFT, SIZEMQRRIGHT, SIZEQRF,
+ $ SIZEQTQ, SIZESUBTST, SIZEEVR,
+ $ SIZETMS, SIZETST, UPLO
+*
+ REAL ABSTOL, THRESH
+* ..
+* .. Local Arrays ..
+ CHARACTER UPLOS( 2 )
+ INTEGER DESCA( DLEN_ ), MATSIZES( MAXSETSIZE ),
+ $ MATTYPES( MAXSETSIZE ), NBS( MAXSETSIZE ),
+ $ NPCOLS( MAXSETSIZE ), NPROWS( MAXSETSIZE )
+* ..
+* .. External Functions ..
+ INTEGER ICEIL, NUMROC
+ EXTERNAL ICEIL, NUMROC
+* ..
+* .. External Subroutines ..
+ EXTERNAL BLACS_ABORT, BLACS_GET, BLACS_GRIDEXIT,
+ $ BLACS_GRIDINFO, BLACS_GRIDINIT, BLACS_PINFO,
+ $ DESCINIT, PSLASIZESEPR, PSSEPINFO, PSSEPRTST
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX
+* ..
+* .. Executable Statements ..
+*
+ CALL BLACS_PINFO( IAM, NNODES )
+ CALL BLACS_GET( -1, 0, INITCON )
+ CALL BLACS_GRIDINIT( INITCON, 'R', 1, NNODES )
+*
+ CALL PSSEPINFO( INITCON, IAM, NIN, NOUT, MAXSETSIZE, NMATSIZES,
+ $ MATSIZES, NUPLOS, UPLOS, NPCONFIGS, NPROWS,
+ $ NPCOLS, NBS, NMATTYPES, MATTYPES, 22, SUBTESTS,
+ $ THRESH, ORDER, ABSTOL, INFO )
+*
+ CALL BLACS_GRIDEXIT( INITCON )
+*
+ IF( INFO.EQ.0 ) THEN
+*
+ DO 40 MATSIZE = 1, NMATSIZES
+*
+ DO 30 PCONFIG = 1, NPCONFIGS
+*
+ DO 20 MATTYPE = 1, NMATTYPES
+*
+ DO 10 UPLO = 1, NUPLOS
+*
+ N = MATSIZES( MATSIZE )
+ ORDER = N
+*
+ NPROW = NPROWS( PCONFIG )
+ NPCOL = NPCOLS( PCONFIG )
+ NB = NBS( PCONFIG )
+*
+ NP = NUMROC( N, NB, 0, 0, NPROW )
+ NQ = NUMROC( N, NB, 0, 0, NPCOL )
+ IPREPAD = MAX( NB, NP )
+ IMIDPAD = NB
+ IPOSTPAD = MAX( NB, NQ )
+*
+ LDA = MAX( NP, 1 ) + IMIDPAD
+*
+ CALL BLACS_GET( -1, 0, CONTEXT )
+ CALL BLACS_GRIDINIT( CONTEXT, 'R', NPROW, NPCOL )
+ CALL BLACS_GRIDINFO( CONTEXT, NPROW, NPCOL, MYROW,
+ $ MYCOL )
+*
+ IF( MYROW.GE.0 ) THEN
+ CALL DESCINIT( DESCA, N, N, NB, NB, 0, 0,
+ $ CONTEXT, LDA, INFO )
+ CALL PSLASIZESEPR( DESCA, IPREPAD, IPOSTPAD,
+ $ SIZEMQRLEFT, SIZEMQRRIGHT,
+ $ SIZEQRF, SIZETMS, SIZEQTQ,
+ $ SIZECHK, SIZEEVR, ISIZEEVR,
+ $ SIZESUBTST, ISIZESUBTST,
+ $ SIZETST, ISIZETST )
+*
+ PTRA = 1
+ PTRZ = PTRA + LDA*NQ + IPREPAD + IPOSTPAD
+ PTRCOPYA = PTRZ + LDA*NQ + IPREPAD + IPOSTPAD
+ PTRW = PTRCOPYA + LDA*NQ + IPREPAD + IPOSTPAD
+ PTRW2 = PTRW + MAX( N, 1 ) + IPREPAD + IPOSTPAD
+ PTRGAP = PTRW2 + MAX( N, 1 ) + IPREPAD +
+ $ IPOSTPAD
+ PTRIFAIL = PTRGAP + NPROW*NPCOL + IPREPAD +
+ $ IPOSTPAD
+ PTRICLUS = PTRIFAIL + ICEIL( N+IPREPAD+IPOSTPAD,
+ $ REALSZ / INTGSZ )
+ PTRIWRK = PTRICLUS + ICEIL( 2*NPROW*NPCOL+
+ $ IPREPAD+IPOSTPAD, REALSZ / INTGSZ )
+ PTRWORK = PTRIWRK + ICEIL( ISIZETST+IPREPAD+
+ $ IPOSTPAD, REALSZ / INTGSZ )
+ LLWORK = MEMSIZE - PTRWORK + 1
+
+ NTESTS = NTESTS + 1
+ IF( LLWORK.LT.SIZETST ) THEN
+ NSKIPPED = NSKIPPED + 1
+ ELSE
+ CALL PSSEPRTST( DESCA, UPLOS( UPLO ), N,
+ $ MATTYPES( MATTYPE ), SUBTESTS,
+ $ THRESH, N, ABSTOL, ISEED,
+ $ MEM( PTRA ), MEM( PTRCOPYA ),
+ $ MEM( PTRZ ), LDA, MEM( PTRW ),
+ $ MEM( PTRW2 ), MEM( PTRIFAIL ),
+ $ MEM( PTRICLUS ),
+ $ MEM( PTRGAP ), IPREPAD,
+ $ IPOSTPAD, MEM( PTRWORK ),
+ $ LLWORK, MEM( PTRIWRK ),
+ $ ISIZETST, HETERO, NOUT, RES )
+*
+ IF( RES.EQ.0 ) THEN
+ NPASSED = NPASSED + 1
+ ELSE IF( RES.EQ.2 ) THEN
+ NNOCHECK = NNOCHECK + 1
+ ELSE IF( RES.EQ.3 ) THEN
+ NSKIPPED = NSKIPPED + 1
+ WRITE( NOUT, FMT = * )' PSSEPRREQ failed'
+ CALL BLACS_ABORT( CONTEXT, -1 )
+ END IF
+ END IF
+ CALL BLACS_GRIDEXIT( CONTEXT )
+ END IF
+ 10 CONTINUE
+ 20 CONTINUE
+ 30 CONTINUE
+ 40 CONTINUE
+ END IF
+*
+ RETURN
+*
+* End of PSSEPRREQ
+*
+ END
diff --git a/TESTING/EIG/psseprsubtst.f b/TESTING/EIG/psseprsubtst.f
new file mode 100644
index 0000000..4451ef3
--- /dev/null
+++ b/TESTING/EIG/psseprsubtst.f
@@ -0,0 +1,802 @@
+ SUBROUTINE PSSEPRSUBTST( WKNOWN, JOBZ, RANGE, UPLO, N, VL, VU, IL,
+ $ IU, THRESH, ABSTOL, A, COPYA, Z, IA, JA,
+ $ DESCA, WIN, WNEW, IFAIL, ICLUSTR, GAP,
+ $ IPREPAD, IPOSTPAD, WORK, LWORK, LWORK1,
+ $ IWORK, LIWORK, RESULT, TSTNRM, QTQNRM,
+ $ NOUT )
+*
+* -- ScaLAPACK routine (@(MODE)version *TBA*) --
+* University of California, Berkeley and
+* University of Tennessee, Knoxville.
+* October 21, 2006
+*
+ IMPLICIT NONE
+*
+* .. Scalar Arguments ..
+ LOGICAL WKNOWN
+ CHARACTER JOBZ, RANGE, UPLO
+ INTEGER IA, IL, IPOSTPAD, IPREPAD, IU, JA, LIWORK,
+ $ LWORK, LWORK1, N, NOUT, RESULT
+ REAL ABSTOL, QTQNRM, THRESH, TSTNRM, VL, VU
+* ..
+* .. Array Arguments ..
+ INTEGER DESCA( * ), ICLUSTR( * ), IFAIL( * ),
+ $ IWORK( * )
+ REAL A( * ), COPYA( * ), GAP( * ), WIN( * ),
+ $ WNEW( * ), WORK( * ), Z( * )
+* ..
+*
+* Purpose
+* =======
+*
+* PSSEPRSUBTST calls PSSYEVR and then tests its output.
+* If JOBZ = 'V' then the following two tests are performed:
+* |AQ -QL| / (abstol + eps * norm(A) ) < N*THRESH
+* |QT * Q - I| / eps < N*THRESH
+* If WKNOWN then
+* we check to make sure that the eigenvalues match expectations
+* i.e. |WIN - WNEW(1+IPREPAD)| / (eps * |WIN|) < THRESH
+* where WIN is the array of eigenvalues computed.
+*
+* Arguments
+* =========
+*
+* NP = the number of rows local to a given process.
+* NQ = the number of columns local to a given process.
+*
+* WKNOWN (global input) INTEGER
+* .FALSE.: WIN does not contain the eigenvalues
+* .TRUE.: WIN does contain the eigenvalues
+*
+* JOBZ (global input) CHARACTER*1
+* Specifies whether or not to compute the eigenvectors:
+* = 'N': Compute eigenvalues only.
+* = 'V': Compute eigenvalues and eigenvectors.
+* Must be 'V' on first call.
+*
+* RANGE (global input) CHARACTER*1
+* = 'A': all eigenvalues will be found.
+* = 'V': all eigenvalues in the interval [VL,VU]
+* will be found.
+* = 'I': the IL-th through IU-th eigenvalues will be found.
+* Must be 'A' on first call.
+*
+* UPLO (global input) CHARACTER*1
+* Specifies whether the upper or lower triangular part of the
+* matrix A is stored:
+* = 'U': Upper triangular
+* = 'L': Lower triangular
+*
+* N (global input) INTEGER
+* Size of the matrix to be tested. (global size)
+*
+* VL (global input) REAL
+* If RANGE='V', the lower bound of the interval to be searched
+* for eigenvalues. Not referenced if RANGE = 'A' or 'I'.
+*
+* VU (global input) REAL
+* If RANGE='V', the upper bound of the interval to be searched
+* for eigenvalues. Not referenced if RANGE = 'A' or 'I'.
+*
+* IL (global input) INTEGER
+* If RANGE='I', the index (from smallest to largest) of the
+* smallest eigenvalue to be returned. IL >= 1.
+* Not referenced if RANGE = 'A' or 'V'.
+*
+* IU (global input) INTEGER
+* If RANGE='I', the index (from smallest to largest) of the
+* largest eigenvalue to be returned. min(IL,N) <= IU <= N.
+* Not referenced if RANGE = 'A' or 'V'.
+*
+* THRESH (global input) REAL
+* A test will count as "failed" if the "error", computed as
+* described below, exceeds THRESH. Note that the error
+* is scaled to be O(1), so THRESH should be a reasonably
+* small multiple of 1, e.g., 100 or 250. In particular,
+* it should not depend on the size of the matrix.
+* It must be at least zero.
+*
+* ABSTOL (global input) REAL
+* The absolute tolerance for the residual test.
+*
+* A (local workspace) REAL array
+* global dimension (N, N), local dimension (DESCA(DLEN_), NQ)
+* The test matrix, which is subsequently overwritten.
+* A is distributed in a 2D-block cyclic manner over both rows
+* and columns.
+* A has already been padded front and back, use A(1+IPREPAD)
+*
+* COPYA (local input) REAL array, dimension(N*N)
+* COPYA holds a copy of the original matrix A
+* identical in both form and content to A
+*
+* Z (local workspace) REAL array, dim (N*N)
+* Z is distributed in the same manner as A
+* Z contains the eigenvector matrix
+* Z is used as workspace by the test routines
+* PSSEPCHK and PSSEPQTQ.
+* Z has already been padded front and back, use Z(1+IPREPAD)
+*
+* IA (global input) INTEGER
+* On entry, IA specifies the global row index of the submatrix
+* of the global matrix A, COPYA and Z to operate on.
+*
+* JA (global input) INTEGER
+* On entry, IA specifies the global column index of the submat
+* of the global matrix A, COPYA and Z to operate on.
+*
+* DESCA (global/local input) INTEGER array of dimension 8
+* The array descriptor for the matrix A, COPYA and Z.
+*
+* WIN (global input) REAL array, dimension (N)
+* If .not. WKNOWN, WIN is ignored on input
+* Otherwise, WIN() is taken as the standard by which the
+* eigenvalues are to be compared against.
+*
+* WNEW (global workspace) REAL array, dimension (N)
+* The computed eigenvalues.
+* If JOBZ <> 'V' or RANGE <> 'A' these eigenvalues are
+* compared against those in WIN().
+* WNEW has already been padded front and back,
+* use WNEW(1+IPREPAD)
+*
+* IFAIL (global output) INTEGER array, dimension (N)
+* If JOBZ = 'V', then on normal exit, the first M elements of
+* IFAIL are zero. If INFO > 0 on exit, then IFAIL contains the
+* indices of the eigenvectors that failed to converge.
+* If JOBZ = 'N', then IFAIL is not referenced.
+* IFAIL has already been padded front and back,
+* use IFAIL(1+IPREPAD)
+*
+* ICLUSTR (global workspace) integer array, dimension (2*NPROW*NPCOL)
+*
+* GAP (global workspace) REAL array,
+* dimension (NPROW*NPCOL)
+*
+* WORK (local workspace) REAL array, dimension (LWORK)
+* WORK has already been padded front and back,
+* use WORK(1+IPREPAD)
+*
+* LWORK (local input) INTEGER
+* The actual length of the array WORK after padding.
+*
+* LWORK1 (local input) INTEGER
+* The amount of real workspace to pass to the eigensolver.
+*
+* IWORK (local workspace) INTEGER array, dimension (LIWORK)
+* IWORK has already been padded front and back,
+* use IWORK(1+IPREPAD)
+*
+* LIWORK (local input) INTEGER
+* The length of the array IWORK after padding.
+*
+* RESULT (global output) INTEGER
+* The result of this call.
+* RESULT = -3 => This process did not participate
+* RESULT = 0 => All tests passed
+* RESULT = 1 => ONe or more tests failed
+*
+* TSTNRM (global output) REAL
+* |AQ- QL| / (ABSTOL+EPS*|A|)*N
+*
+* QTQNRM (global output) REAL
+* |QTQ -I| / N*EPS
+*
+* .. Parameters ..
+*
+ INTEGER DLEN_, CTXT_, M_, N_,
+ $ MB_, NB_, RSRC_, CSRC_, LLD_
+ PARAMETER ( DLEN_ = 9,
+ $ CTXT_ = 2, M_ = 3, N_ = 4, MB_ = 5, NB_ = 6,
+ $ RSRC_ = 7, CSRC_ = 8, LLD_ = 9 )
+ REAL PADVAL, FIVE, NEGONE
+ PARAMETER ( PADVAL = 13.5285E0, FIVE = 5.0E0,
+ $ NEGONE = -1.0E0 )
+ INTEGER IPADVAL
+ PARAMETER ( IPADVAL = 927 )
+* ..
+* .. Local Scalars ..
+ LOGICAL MISSLARGEST, MISSSMALLEST
+ INTEGER I, IAM, INDIWRK, INFO, ISIZESUBTST, ISIZEEVR,
+ $ ISIZETST, J, M, MAXEIGS, MAXIL, MAXIU, MAXSIZE,
+ $ MINIL, MQ, MYCOL, MYIL, MYROW, NCLUSTERS, NP,
+ $ NPCOL, NPROW, NQ, NZ, OLDIL, OLDIU, OLDNZ, RES,
+ $ SIZECHK, SIZEMQRLEFT, SIZEMQRRIGHT, SIZEQRF,
+ $ SIZEQTQ, SIZESUBTST, SIZEEVR, SIZETMS,
+ $ SIZETST, VALSIZE, VECSIZE
+ REAL EPS, EPSNORMA, ERROR, MAXERROR, MAXVU,
+ $ MINERROR, MINVL, NORMWIN, OLDVL, OLDVU,
+ $ SAFMIN
+* ..
+* .. Local Arrays ..
+ INTEGER DESCZ( DLEN_ ), ISEED( 4 ), ITMP( 2 )
+* ..
+* .. External Functions ..
+*
+ LOGICAL LSAME
+ INTEGER NUMROC
+ REAL PSLAMCH, PSLANSY
+ EXTERNAL LSAME, NUMROC, PSLAMCH, PSLANSY
+* ..
+* .. External Subroutines ..
+ EXTERNAL BLACS_GRIDINFO, DESCINIT, IGAMN2D, IGAMX2D,
+ $ PICHEKPAD, PIFILLPAD, PSCHEKPAD, PSELSET,
+ $ PSFILLPAD, PSLASIZESEPR, PSLASIZESYEVR,
+ $ PSSEPCHK, PSSEPQTQ, PSSYEVR, SGAMN2D, SGAMX2D,
+ $ SLACPY, SLBOOT, SLTIMER
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX, MIN, MOD
+* ..
+* .. Executable Statements ..
+*
+ CALL PSLASIZESEPR( DESCA, IPREPAD, IPOSTPAD, SIZEMQRLEFT,
+ $ SIZEMQRRIGHT, SIZEQRF, SIZETMS, SIZEQTQ,
+ $ SIZECHK, SIZEEVR, ISIZEEVR, SIZESUBTST,
+ $ ISIZESUBTST, SIZETST, ISIZETST )
+*
+ TSTNRM = NEGONE
+ QTQNRM = NEGONE
+ EPS = PSLAMCH( DESCA( CTXT_ ), 'Eps' )
+ SAFMIN = PSLAMCH( DESCA( CTXT_ ), 'Safe min' )
+*
+ NORMWIN = SAFMIN / EPS
+ IF( N.GE.1 )
+ $ NORMWIN = MAX( ABS( WIN( 1 ) ), ABS( WIN( N ) ), NORMWIN )
+*
+* Make sure that no information from previous calls is used
+*
+ NZ = -13
+ OLDNZ = NZ
+ OLDIL = IL
+ OLDIU = IU
+ OLDVL = VL
+ OLDVU = VU
+*
+ DO 10 I = 1, LWORK1, 1
+ WORK( I+IPREPAD ) = 14.3E0
+ 10 CONTINUE
+*
+ DO 20 I = 1, LIWORK, 1
+ IWORK( I+IPREPAD ) = 14
+ 20 CONTINUE
+*
+ DO 30 I = 1, N
+ WNEW( I+IPREPAD ) = 3.14159E0
+ 30 CONTINUE
+*
+ ICLUSTR( 1+IPREPAD ) = 139
+*
+ IF (LSAME( RANGE, 'V' ) ) THEN
+* WRITE(*,*) 'VL VU = ', VL, ' ', VU
+ END IF
+
+ IF( LSAME( JOBZ, 'N' ) ) THEN
+ MAXEIGS = 0
+ ELSE
+ IF( LSAME( RANGE, 'A' ) ) THEN
+ MAXEIGS = N
+ ELSE IF( LSAME( RANGE, 'I' ) ) THEN
+ MAXEIGS = IU - IL + 1
+ ELSE
+ MINVL = VL - NORMWIN*FIVE*EPS - ABSTOL
+ MAXVU = VU + NORMWIN*FIVE*EPS + ABSTOL
+* WRITE(*,*) 'MINVL = ', MINVL, ' MAXVU = ', MAXVU
+* WRITE(*,*) 'WIN = ', WIN( 1 )
+ MINIL = 1
+ MAXIU = 0
+ DO 40 I = 1, N
+ IF( WIN( I ).LT.MINVL )
+ $ MINIL = MINIL + 1
+ IF( WIN( I ).LE.MAXVU )
+ $ MAXIU = MAXIU + 1
+ 40 CONTINUE
+*
+ MAXEIGS = MAXIU - MINIL + 1
+ END IF
+ END IF
+*
+*
+ CALL DESCINIT( DESCZ, DESCA( M_ ), DESCA( N_ ), DESCA( MB_ ),
+ $ DESCA( NB_ ), DESCA( RSRC_ ), DESCA( CSRC_ ),
+ $ DESCA( CTXT_ ), DESCA( LLD_ ), INFO )
+*
+ CALL BLACS_GRIDINFO( DESCA( CTXT_ ), NPROW, NPCOL, MYROW, MYCOL )
+ INDIWRK = 1 + IPREPAD + NPROW*NPCOL + 1
+*
+ IAM = 1
+ IF( MYROW.EQ.0 .AND. MYCOL.EQ.0 )
+ $ IAM = 0
+*
+* If this process is not involved in this test, bail out now
+*
+ RESULT = -3
+ IF( MYROW.GE.NPROW .OR. MYROW.LT.0 )
+ $ GO TO 150
+ RESULT = 0
+*
+ ISEED( 1 ) = 1
+*
+ CALL PSLASIZESYEVR( WKNOWN, RANGE, N, DESCA, VL, VU, IL, IU,
+ $ ISEED, WIN, MAXSIZE, VECSIZE, VALSIZE )
+*
+ NP = NUMROC( N, DESCA( MB_ ), MYROW, 0, NPROW )
+ NQ = NUMROC( N, DESCA( NB_ ), MYCOL, 0, NPCOL )
+ MQ = NUMROC( MAXEIGS, DESCA( NB_ ), MYCOL, 0, NPCOL )
+*
+ CALL SLACPY( 'A', NP, NQ, COPYA, DESCA( LLD_ ), A( 1+IPREPAD ),
+ $ DESCA( LLD_ ) )
+*
+ CALL PSFILLPAD( DESCA( CTXT_ ), NP, NQ, A, DESCA( LLD_ ), IPREPAD,
+ $ IPOSTPAD, PADVAL )
+*
+ CALL PSFILLPAD( DESCZ( CTXT_ ), NP, MQ, Z, DESCZ( LLD_ ), IPREPAD,
+ $ IPOSTPAD, PADVAL+1.0E0 )
+*
+* WRITE(*,*) ' NP = ', NP, ' MQ = ', MQ, ' LDZ = ', DESCZ( LLD_ ),
+* $ ' IPREPAD = ', IPREPAD, ' IPOSTPAD = ', IPOSTPAD,
+* $ ' MAXEIGS = ', MAXEIGS
+* WRITE(*,*) ' PADZ( 1 ) = ', Z( 1 ), ' PADZ( 2 ) = ', Z( 2 ),
+* $ ' PADZ( 3 ) = ', Z( 3 ), ' PADZ( 4 ) = ', Z( 4 )
+*
+ CALL PSFILLPAD( DESCA( CTXT_ ), N, 1, WNEW, N, IPREPAD, IPOSTPAD,
+ $ PADVAL+2.0E0 )
+*
+ CALL PSFILLPAD( DESCA( CTXT_ ), NPROW*NPCOL, 1, GAP, NPROW*NPCOL,
+ $ IPREPAD, IPOSTPAD, PADVAL+3.0E0 )
+*
+ CALL PSFILLPAD( DESCA( CTXT_ ), LWORK1, 1, WORK, LWORK1, IPREPAD,
+ $ IPOSTPAD, PADVAL+4.0E0 )
+*
+ CALL PIFILLPAD( DESCA( CTXT_ ), LIWORK, 1, IWORK, LIWORK, IPREPAD,
+ $ IPOSTPAD, IPADVAL )
+*
+ CALL PIFILLPAD( DESCA( CTXT_ ), N, 1, IFAIL, N, IPREPAD, IPOSTPAD,
+ $ IPADVAL )
+*
+ CALL PIFILLPAD( DESCA( CTXT_ ), 2*NPROW*NPCOL, 1, ICLUSTR,
+ $ 2*NPROW*NPCOL, IPREPAD, IPOSTPAD, IPADVAL )
+*
+* Make sure that PSSYEVR does not cheat (i.e. use answers
+* already computed.)
+*
+ DO 60 I = 1, N, 1
+ DO 50 J = 1, MAXEIGS, 1
+ CALL PSELSET( Z( 1+IPREPAD ), I, J, DESCA, 13.0E0 )
+ 50 CONTINUE
+ 60 CONTINUE
+*
+* Reset and start the timer
+*
+ CALL SLBOOT
+ CALL SLTIMER( 1 )
+ CALL SLTIMER( 6 )
+
+*********************************
+*
+* Main call to PSSYEVR
+*
+ CALL PSSYEVR( JOBZ, RANGE, UPLO, N, A( 1+IPREPAD ), IA, JA, DESCA,
+ $ VL, VU, IL, IU, M, NZ, WNEW( 1+IPREPAD ),
+ $ Z( 1+IPREPAD ), IA, JA, DESCA,
+ $ WORK( 1+IPREPAD ), LWORK1, IWORK( 1+IPREPAD ),
+ $ LIWORK, INFO )
+*
+*********************************
+*
+* Stop timer
+*
+ CALL SLTIMER( 6 )
+ CALL SLTIMER( 1 )
+*
+* Indicate that there are no unresolved clusters.
+* This is necessary so that the tester
+* (adapted from the one originally made for PSSYEVX)
+* works correctly.
+ ICLUSTR( 1+IPREPAD ) = 0
+*
+ IF( THRESH.LE.0 ) THEN
+ RESULT = 0
+ ELSE
+ CALL PSCHEKPAD( DESCA( CTXT_ ), 'PSSYEVR-A', NP, NQ, A,
+ $ DESCA( LLD_ ), IPREPAD, IPOSTPAD, PADVAL )
+*
+ CALL PSCHEKPAD( DESCZ( CTXT_ ), 'PSSYEVR-Z', NP, MQ, Z,
+ $ DESCZ( LLD_ ), IPREPAD, IPOSTPAD,
+ $ PADVAL+1.0E0 )
+*
+ CALL PSCHEKPAD( DESCA( CTXT_ ), 'PSSYEVR-WNEW', N, 1, WNEW, N,
+ $ IPREPAD, IPOSTPAD, PADVAL+2.0E0 )
+*
+ CALL PSCHEKPAD( DESCA( CTXT_ ), 'PSSYEVR-GAP', NPROW*NPCOL, 1,
+ $ GAP, NPROW*NPCOL, IPREPAD, IPOSTPAD,
+ $ PADVAL+3.0E0 )
+*
+ CALL PSCHEKPAD( DESCA( CTXT_ ), 'PSSYEVR-WORK', LWORK1, 1,
+ $ WORK, LWORK1, IPREPAD, IPOSTPAD,
+ $ PADVAL+4.0E0 )
+*
+ CALL PICHEKPAD( DESCA( CTXT_ ), 'PSSYEVR-IWORK', LIWORK, 1,
+ $ IWORK, LIWORK, IPREPAD, IPOSTPAD, IPADVAL )
+*
+ CALL PICHEKPAD( DESCA( CTXT_ ), 'PSSYEVR-IFAIL', N, 1, IFAIL,
+ $ N, IPREPAD, IPOSTPAD, IPADVAL )
+*
+ CALL PICHEKPAD( DESCA( CTXT_ ), 'PSSYEVR-ICLUSTR',
+ $ 2*NPROW*NPCOL, 1, ICLUSTR, 2*NPROW*NPCOL,
+ $ IPREPAD, IPOSTPAD, IPADVAL )
+*
+* If we now know the spectrum, we can potentially reduce MAXSIZE.
+*
+ IF( LSAME( RANGE, 'A' ) ) THEN
+ CALL PSLASIZESYEVR( .TRUE., RANGE, N, DESCA, VL, VU, IL, IU,
+ $ ISEED, WNEW( 1+IPREPAD ), MAXSIZE,
+ $ VECSIZE, VALSIZE )
+ END IF
+*
+* Check INFO
+* Make sure that all processes return the same value of INFO
+*
+ ITMP( 1 ) = INFO
+ ITMP( 2 ) = INFO
+*
+ CALL IGAMN2D( DESCA( CTXT_ ), 'a', ' ', 1, 1, ITMP, 1, 1, 1,
+ $ -1, -1, 0 )
+ CALL IGAMX2D( DESCA( CTXT_ ), 'a', ' ', 1, 1, ITMP( 2 ), 1, 1,
+ $ 1, -1, -1, 0 )
+*
+*
+ IF( ITMP( 1 ).NE.ITMP( 2 ) ) THEN
+ IF( IAM.EQ.0 )
+ $ WRITE( NOUT, FMT = * )
+ $ 'Different processes return different INFO'
+ RESULT = 1
+ ELSE IF( MOD( INFO, 2 ).EQ.1 .OR. INFO.GT.7 .OR. INFO.LT.0 )
+ $ THEN
+ IF( IAM.EQ.0 )
+ $ WRITE( NOUT, FMT = 9999 )INFO
+ RESULT = 1
+ ELSE IF( MOD( INFO / 2, 2 ).EQ.1 .AND. LWORK1.GE.MAXSIZE ) THEN
+ IF( IAM.EQ.0 )
+ $ WRITE( NOUT, FMT = 9996 )INFO
+ RESULT = 1
+ ELSE IF( MOD( INFO / 4, 2 ).EQ.1 .AND. LWORK1.GE.VECSIZE ) THEN
+ IF( IAM.EQ.0 )
+ $ WRITE( NOUT, FMT = 9996 )INFO
+ RESULT = 1
+ END IF
+*
+ IF( LSAME( JOBZ, 'V' ) .AND. ( ICLUSTR( 1+IPREPAD ).NE.
+ $ 0 ) .AND. ( MOD( INFO / 2, 2 ).NE.1 ) ) THEN
+ IF( IAM.EQ.0 )
+ $ WRITE( NOUT, FMT = 9995 )
+ RESULT = 1
+ END IF
+*
+* Check M
+*
+ IF( ( M.LT.0 ) .OR. ( M.GT.N ) ) THEN
+ IF( IAM.EQ.0 )
+ $ WRITE( NOUT, FMT = 9994 )
+ WRITE( NOUT,*) 'M = ', M, '\n', 'N = ', N
+ RESULT = 1
+ ELSE IF( LSAME( RANGE, 'A' ) .AND. ( M.NE.N ) ) THEN
+ IF( IAM.EQ.0 )
+ $ WRITE( NOUT, FMT = 9993 )
+ RESULT = 1
+ ELSE IF( LSAME( RANGE, 'I' ) .AND. ( M.NE.IU-IL+1 ) ) THEN
+ IF( IAM.EQ.0 ) THEN
+ WRITE( NOUT, FMT = 9992 )
+ WRITE( NOUT,*) 'IL = ', IL, ' IU = ', IU, ' M = ', M
+ END IF
+ RESULT = 1
+ ELSE IF( LSAME( JOBZ, 'V' ) .AND.
+ $ ( .NOT.( LSAME( RANGE, 'V' ) ) ) .AND. ( M.NE.NZ ) )
+ $ THEN
+ IF( IAM.EQ.0 )
+ $ WRITE( NOUT, FMT = 9991 )
+ RESULT = 1
+ END IF
+*
+* Check NZ
+*
+ IF( LSAME( JOBZ, 'V' ) ) THEN
+ IF( LSAME( RANGE, 'V' ) ) THEN
+ IF( NZ.GT.M ) THEN
+ IF( IAM.EQ.0 )
+ $ WRITE( NOUT, FMT = 9990 )
+ RESULT = 1
+ END IF
+ IF( NZ.LT.M .AND. MOD( INFO / 4, 2 ).NE.1 ) THEN
+ IF( IAM.EQ.0 )
+ $ WRITE( NOUT, FMT = 9989 )
+ RESULT = 1
+ END IF
+ ELSE
+ IF( NZ.NE.M ) THEN
+ IF( IAM.EQ.0 )
+ $ WRITE( NOUT, FMT = 9988 )
+ RESULT = 1
+ END IF
+ END IF
+ END IF
+ IF( RESULT.EQ.0 ) THEN
+*
+* Make sure that all processes return the same # of eigenvalues
+*
+ ITMP( 1 ) = M
+ ITMP( 2 ) = M
+*
+ CALL IGAMN2D( DESCA( CTXT_ ), 'a', ' ', 1, 1, ITMP, 1, 1, 1,
+ $ -1, -1, 0 )
+ CALL IGAMX2D( DESCA( CTXT_ ), 'a', ' ', 1, 1, ITMP( 2 ), 1,
+ $ 1, 1, -1, -1, 0 )
+*
+ IF( ITMP( 1 ).NE.ITMP( 2 ) ) THEN
+ IF( IAM.EQ.0 )
+ $ WRITE( NOUT, FMT = 9987 )
+ RESULT = 1
+ ELSE
+*
+* Ensure that different processes return the same eigenvalues
+*
+ DO 70 I = 1, M
+ WORK( I ) = WNEW( I+IPREPAD )
+ WORK( I+M ) = WNEW( I+IPREPAD )
+ 70 CONTINUE
+*
+ CALL SGAMN2D( DESCA( CTXT_ ), 'a', ' ', M, 1, WORK, M, 1,
+ $ 1, -1, -1, 0 )
+ CALL SGAMX2D( DESCA( CTXT_ ), 'a', ' ', M, 1,
+ $ WORK( 1+M ), M, 1, 1, -1, -1, 0 )
+*
+ DO 80 I = 1, M
+ IF( RESULT.EQ.0 .AND. ( ABS( WORK( I )-WORK( M+
+ $ I ) ).GT.FIVE*EPS*ABS( WORK( I ) ) ) ) THEN
+ IF( IAM.EQ.0 )
+ $ WRITE( NOUT, FMT = 9986 )
+ RESULT = 1
+ END IF
+ 80 CONTINUE
+ END IF
+ END IF
+*
+* Make sure that all processes return the same # of clusters
+*
+ IF( LSAME( JOBZ, 'V' ) ) THEN
+ NCLUSTERS = 0
+ DO 90 I = 0, NPROW*NPCOL - 1
+ IF( ICLUSTR( 1+IPREPAD+2*I ).EQ.0 )
+ $ GO TO 100
+ NCLUSTERS = NCLUSTERS + 1
+ 90 CONTINUE
+ 100 CONTINUE
+ ITMP( 1 ) = NCLUSTERS
+ ITMP( 2 ) = NCLUSTERS
+*
+ CALL IGAMN2D( DESCA( CTXT_ ), 'a', ' ', 1, 1, ITMP, 1, 1, 1,
+ $ -1, -1, 0 )
+ CALL IGAMX2D( DESCA( CTXT_ ), 'a', ' ', 1, 1, ITMP( 2 ), 1,
+ $ 1, 1, -1, -1, 0 )
+*
+ IF( ITMP( 1 ).NE.ITMP( 2 ) ) THEN
+ IF( IAM.EQ.0 )
+ $ WRITE( NOUT, FMT = 9985 )
+ RESULT = 1
+ ELSE
+*
+* Make sure that different processes return the same clusters
+*
+ DO 110 I = 1, NCLUSTERS
+ IWORK( INDIWRK+I ) = ICLUSTR( I+IPREPAD )
+ IWORK( INDIWRK+I+NCLUSTERS ) = ICLUSTR( I+IPREPAD )
+ 110 CONTINUE
+ CALL IGAMN2D( DESCA( CTXT_ ), 'a', ' ', NCLUSTERS*2+1, 1,
+ $ IWORK( INDIWRK+1 ), NCLUSTERS*2+1, 1, 1,
+ $ -1, -1, 0 )
+ CALL IGAMX2D( DESCA( CTXT_ ), 'a', ' ', NCLUSTERS*2+1, 1,
+ $ IWORK( INDIWRK+1+NCLUSTERS ),
+ $ NCLUSTERS*2+1, 1, 1, -1, -1, 0 )
+*
+ DO 120 I = 1, NCLUSTERS
+ IF( RESULT.EQ.0 .AND. IWORK( INDIWRK+I ).NE.
+ $ IWORK( INDIWRK+NCLUSTERS+I ) ) THEN
+ IF( IAM.EQ.0 )
+ $ WRITE( NOUT, FMT = 9984 )
+ RESULT = 1
+ END IF
+ 120 CONTINUE
+*
+ IF( ICLUSTR( 1+IPREPAD+NCLUSTERS*2 ).NE.0 ) THEN
+ IF( IAM.EQ.0 )
+ $ WRITE( NOUT, FMT = 9983 )
+ RESULT = 1
+ END IF
+ END IF
+ END IF
+*
+ CALL IGAMX2D( DESCA( CTXT_ ), 'a', ' ', 1, 1, RESULT, 1, 1, 1,
+ $ -1, -1, 0 )
+ IF( RESULT.NE.0 )
+ $ GO TO 150
+*
+* Compute eps * norm(A)
+*
+ IF( N.EQ.0 ) THEN
+ EPSNORMA = EPS
+ ELSE
+ EPSNORMA = PSLANSY( 'I', UPLO, N, COPYA, IA, JA, DESCA,
+ $ WORK )*EPS
+ END IF
+*
+ IF( LSAME( JOBZ, 'V' ) ) THEN
+*
+* Perform the |A Z - Z W| test
+*
+ CALL PSFILLPAD( DESCA( CTXT_ ), SIZECHK, 1, WORK, SIZECHK,
+ $ IPREPAD, IPOSTPAD, 4.3E0 )
+*
+ CALL PSSEPCHK( N, NZ, COPYA, IA, JA, DESCA,
+ $ MAX( ABSTOL+EPSNORMA, SAFMIN ), THRESH,
+ $ Z( 1+IPREPAD ), IA, JA, DESCZ,
+ $ A( 1+IPREPAD ), IA, JA, DESCA,
+ $ WNEW( 1+IPREPAD ), WORK( 1+IPREPAD ),
+ $ SIZECHK, TSTNRM, RES )
+*
+ CALL PSCHEKPAD( DESCA( CTXT_ ), 'PSSEPCHK-WORK', SIZECHK, 1,
+ $ WORK, SIZECHK, IPREPAD, IPOSTPAD, 4.3E0 )
+*
+ IF( RES.NE.0 )
+ $ RESULT = 1
+*
+* Perform the |QTQ - I| test
+*
+ CALL PSFILLPAD( DESCA( CTXT_ ), SIZEQTQ, 1, WORK, SIZEQTQ,
+ $ IPREPAD, IPOSTPAD, 4.3E0 )
+*
+*
+ CALL PSSEPQTQ( N, NZ, THRESH, Z( 1+IPREPAD ), IA, JA, DESCZ,
+ $ A( 1+IPREPAD ), IA, JA, DESCA,
+ $ IWORK( 1+IPREPAD+1 ), ICLUSTR( 1+IPREPAD ),
+ $ GAP( 1+IPREPAD ), WORK( IPREPAD+1 ), SIZEQTQ,
+ $ QTQNRM, INFO, RES )
+*
+ CALL PSCHEKPAD( DESCA( CTXT_ ), 'PSSEPQTQ-WORK', SIZEQTQ, 1,
+ $ WORK, SIZEQTQ, IPREPAD, IPOSTPAD, 4.3E0 )
+*
+ IF( RES.NE.0 )
+ $ RESULT = 1
+*
+ IF( INFO.NE.0 ) THEN
+ IF( IAM.EQ.0 )
+ $ WRITE( NOUT, FMT = 9998 )INFO
+ RESULT = 1
+ END IF
+ END IF
+*
+* Check to make sure that the right eigenvalues have been obtained
+*
+ IF( WKNOWN ) THEN
+* Set up MYIL if necessary
+ MYIL = IL
+*
+ IF( LSAME( RANGE, 'V' ) ) THEN
+ MYIL = 1
+ MINIL = 1
+ MAXIL = N - M + 1
+ ELSE
+ IF( LSAME( RANGE, 'A' ) ) THEN
+ MYIL = 1
+ END IF
+ MINIL = MYIL
+ MAXIL = MYIL
+ END IF
+*
+* Find the largest difference between the computed
+* and expected eigenvalues
+*
+ MINERROR = NORMWIN
+*
+ DO 140 MYIL = MINIL, MAXIL
+ MAXERROR = 0
+*
+* Make sure that we aren't skipping any important eigenvalues
+*
+ MISSSMALLEST = .TRUE.
+ IF( .NOT.LSAME( RANGE, 'V' ) .OR. ( MYIL.EQ.1 ) )
+ $ MISSSMALLEST = .FALSE.
+ IF( MISSSMALLEST .AND. ( WIN( MYIL-1 ).LT.VL+NORMWIN*
+ $ FIVE*THRESH*EPS ) )MISSSMALLEST = .FALSE.
+ MISSLARGEST = .TRUE.
+ IF( .NOT.LSAME( RANGE, 'V' ) .OR. ( MYIL.EQ.MAXIL ) )
+ $ MISSLARGEST = .FALSE.
+ IF( MISSLARGEST .AND. ( WIN( MYIL+M ).GT.VU-NORMWIN*FIVE*
+ $ THRESH*EPS ) )MISSLARGEST = .FALSE.
+ IF( .NOT.MISSSMALLEST ) THEN
+ IF( .NOT.MISSLARGEST ) THEN
+*
+* Make sure that the eigenvalues that we report are OK
+*
+ DO 130 I = 1, M
+* WRITE(*,*) 'WIN WNEW = ', WIN( I+MYIL-1 ),
+* $ WNEW( I+IPREPAD )
+ ERROR = ABS( WIN( I+MYIL-1 )-WNEW( I+IPREPAD ) )
+ MAXERROR = MAX( MAXERROR, ERROR )
+ 130 CONTINUE
+*
+ MINERROR = MIN( MAXERROR, MINERROR )
+ END IF
+ END IF
+ 140 CONTINUE
+*
+* If JOBZ = 'V' and RANGE='A', we might be comparing
+* against our estimate of what the eigenvalues ought to
+* be, rather than comparing against what was computed
+* last time around, so we have to be more generous.
+*
+ IF( LSAME( JOBZ, 'V' ) .AND. LSAME( RANGE, 'A' ) ) THEN
+ IF( MINERROR.GT.NORMWIN*FIVE*FIVE*THRESH*EPS ) THEN
+ IF( IAM.EQ.0 )
+ $ WRITE( NOUT, FMT = 9997 )MINERROR, NORMWIN
+ RESULT = 1
+ END IF
+ ELSE
+ IF( MINERROR.GT.NORMWIN*FIVE*THRESH*EPS ) THEN
+ IF( IAM.EQ.0 )
+ $ WRITE( NOUT, FMT = 9997 )MINERROR, NORMWIN
+ RESULT = 1
+ END IF
+ END IF
+ END IF
+*
+* Make sure that the IL, IU, VL and VU were not altered
+*
+ IF( IL.NE.OLDIL .OR. IU.NE.OLDIU .OR. VL.NE.OLDVL .OR. VU.NE.
+ $ OLDVU ) THEN
+ IF( IAM.EQ.0 )
+ $ WRITE( NOUT, FMT = 9982 )
+ RESULT = 1
+ END IF
+*
+ IF( LSAME( JOBZ, 'N' ) .AND. ( NZ.NE.OLDNZ ) ) THEN
+ IF( IAM.EQ.0 )
+ $ WRITE( NOUT, FMT = 9981 )
+ RESULT = 1
+ END IF
+*
+ END IF
+*
+* All processes should report the same result
+*
+ CALL IGAMX2D( DESCA( CTXT_ ), 'a', ' ', 1, 1, RESULT, 1, 1, 1, -1,
+ $ -1, 0 )
+*
+ 150 CONTINUE
+*
+ RETURN
+*
+ 9999 FORMAT( 'PSSYEVR returned INFO=', I7 )
+ 9998 FORMAT( 'PSSEPQTQ returned INFO=', I7 )
+ 9997 FORMAT( 'PSSEPRSUBTST minerror =', D11.2, ' normwin=', D11.2 )
+ 9996 FORMAT( 'PSSYEVR returned INFO=', I7,
+ $ ' despite adequate workspace' )
+ 9995 FORMAT( 'ICLUSTR(1).NE.0 but mod(INFO/2,2).NE.1' )
+ 9994 FORMAT( 'M not in the range 0 to N' )
+ 9993 FORMAT( 'M not equal to N' )
+ 9992 FORMAT( 'M not equal to IU-IL+1' )
+ 9991 FORMAT( 'M not equal to NZ' )
+ 9990 FORMAT( 'NZ > M' )
+ 9989 FORMAT( 'NZ < M' )
+ 9988 FORMAT( 'NZ not equal to M' )
+ 9987 FORMAT( 'Different processes return different values for M' )
+ 9986 FORMAT( 'Different processes return different eigenvalues' )
+ 9985 FORMAT( 'Different processes return ',
+ $ 'different numbers of clusters' )
+ 9984 FORMAT( 'Different processes return different clusters' )
+ 9983 FORMAT( 'ICLUSTR not zero terminated' )
+ 9982 FORMAT( 'IL, IU, VL or VU altered by PSSYEVR' )
+ 9981 FORMAT( 'NZ altered by PSSYEVR with JOBZ=N' )
+*
+* End of PSSEPRSUBTST
+*
+ END
diff --git a/TESTING/EIG/psseprtst.f b/TESTING/EIG/psseprtst.f
new file mode 100644
index 0000000..e21eb78
--- /dev/null
+++ b/TESTING/EIG/psseprtst.f
@@ -0,0 +1,801 @@
+ SUBROUTINE PSSEPRTST(DESCA, UPLO, N, MATTYPE, SUBTESTS, THRESH,
+ $ ORDER, ABSTOL, ISEED, A, COPYA, Z, LDA, WIN,
+ $ WNEW, IFAIL, ICLUSTR, GAP, IPREPAD, IPOSTPAD,
+ $ WORK, LWORK,
+ $ IWORK, LIWORK, HETERO, NOUT, INFO )
+*
+* -- ScaLAPACK routine (@(MODE)version *TBA*) --
+* University of California, Berkeley and
+* University of Tennessee, Knoxville.
+* October 21, 2006
+*
+ IMPLICIT NONE
+*
+* .. Scalar Arguments ..
+ CHARACTER HETERO, SUBTESTS, UPLO
+ INTEGER INFO, IPOSTPAD, IPREPAD, LDA, LIWORK, LWORK,
+ $ MATTYPE, N, NOUT, ORDER
+ REAL ABSTOL, THRESH
+* ..
+* .. Array Arguments ..
+ INTEGER DESCA( * ), ICLUSTR( * ), IFAIL( * ),
+ $ ISEED( 4 ), IWORK( * )
+ REAL A( LDA, * ), COPYA( LDA, * ), GAP( * ),
+ $ WIN( * ), WNEW( * ), WORK( * ), Z( LDA, * )
+* ..
+*
+* Purpose
+* =======
+*
+* PSSEPRTST builds a random matrix and runs PSSYEVR to
+* compute the eigenvalues and eigenvectors. Then it performs two tests
+* to determine if the result is good enough. The two tests are:
+* |AQ -QL| / (abstol + ulp * norm(A) )
+* and
+* |QT * Q - I| / ulp * norm(A)
+*
+* The random matrix built depends upon the following parameters:
+* N, NB, ISEED, ORDER
+*
+* Arguments
+* =========
+*
+* NP = the number of rows local to a given process.
+* NQ = the number of columns local to a given process.
+*
+* DESCA (global and local input) INTEGER array of dimension DLEN_
+* The array descriptor for the distributed matrices
+*
+* UPLO (global input) CHARACTER*1
+* Specifies whether the upper or lower triangular part of the
+* matrix A is stored:
+* = 'U': Upper triangular
+* = 'L': Lower triangular
+*
+* N (global input) INTEGER
+* Size of the matrix to be tested. (global size)
+*
+* MATTYPE (global input) INTEGER
+* Matrix type
+* Currently, the list of possible types is:
+*
+* (1) The zero matrix.
+* (2) The identity matrix.
+*
+* (3) A diagonal matrix with evenly spaced entries
+* 1, ..., ULP and random signs.
+* (ULP = (first number larger than 1) - 1 )
+* (4) A diagonal matrix with geometrically spaced entries
+* 1, ..., ULP and random signs.
+* (5) A diagonal matrix with "clustered" entries 1, ULP, ..., ULP
+* and random signs.
+*
+* (6) Same as (4), but multiplied by SQRT( overflow threshold )
+* (7) Same as (4), but multiplied by SQRT( underflow threshold )
+*
+* (8) A matrix of the form U' D U, where U is orthogonal and
+* D has evenly spaced entries 1, ..., ULP with random signs
+* on the diagonal.
+*
+* (9) A matrix of the form U' D U, where U is orthogonal and
+* D has geometrically spaced entries 1, ..., ULP with random
+* signs on the diagonal.
+*
+* (10) A matrix of the form U' D U, where U is orthogonal and
+* D has "clustered" entries 1, ULP,..., ULP with random
+* signs on the diagonal.
+*
+* (11) Same as (8), but multiplied by SQRT( overflow threshold )
+* (12) Same as (8), but multiplied by SQRT( underflow threshold )
+*
+* (13) A matrix with random entries chosen from (-1,1).
+* (14) Same as (13), but multiplied by SQRT( overflow threshold )
+* (15) Same as (13), but multiplied by SQRT( underflow threshold )
+* (16) Same as (8), but diagonal elements are all positive.
+* (17) Same as (9), but diagonal elements are all positive.
+* (18) Same as (10), but diagonal elements are all positive.
+* (19) Same as (16), but multiplied by SQRT( overflow threshold )
+* (20) Same as (16), but multiplied by SQRT( underflow threshold )
+* (21) A tridiagonal matrix that is a direct sum of smaller diagonally
+* dominant submatrices. Each unreduced submatrix has geometrically
+* spaced diagonal entries 1, ..., ULP.
+* (22) A matrix of the form U' D U, where U is orthogonal and
+* D has ceil(lgN) "clusters" at 0,1,2,...,ceil(lgN)-1. The
+* size of the cluster at the value I is 2^I.
+*
+* SUBTESTS (global input) CHARACTER*1
+* 'Y' - Perform subset tests
+* 'N' - Do not perform subset tests
+*
+* THRESH (global input) REAL
+* A test will count as "failed" if the "error", computed as
+* described below, exceeds THRESH. Note that the error
+* is scaled to be O(1), so THRESH should be a reasonably
+* small multiple of 1, e.g., 10 or 100. In particular,
+* it should not depend on the precision (single vs. double)
+* or the size of the matrix. It must be at least zero.
+*
+* ORDER (global input) INTEGER
+* Number of reflectors used in test matrix creation.
+* If ORDER is large, it will
+* take more time to create the test matrices but they will
+* be closer to random.
+* ORDER .lt. N not implemented
+*
+* ABSTOL (global input) REAL
+* For the purposes of this test, ABSTOL=0.0 is fine.
+* THis test does not test for high relative accuracy.
+*
+* ISEED (global input/output) INTEGER array, dimension (4)
+* On entry, the seed of the random number generator; the array
+* elements must be between 0 and 4095, and ISEED(4) must be
+* odd.
+* On exit, the seed is updated.
+*
+* A (local workspace) REAL array, dim (N*N)
+* global dimension (N, N), local dimension (LDA, NQ)
+* The test matrix, which is then overwritten.
+* A is distributed in a block cyclic manner over both rows
+* and columns. The actual location of a particular element
+* in A is controlled by the values of NPROW, NPCOL, and NB.
+*
+* COPYA (local workspace) REAL array, dim (N, N)
+* COPYA is used to hold an identical copy of the array A
+* identical in both form and content to A
+*
+* Z (local workspace) REAL array, dim (N*N)
+* Z is distributed in the same manner as A
+* Z is used as workspace by the test routines
+* PSSEPCHK and PSSEPQTQ
+*
+* W (local workspace) REAL array, dimension (N)
+* On normal exit, the first M entries
+* contain the selected eigenvalues in ascending order.
+*
+* IFAIL (global workspace) INTEGER array, dimension (N)
+* Not used, only for backward compatibility
+*
+* WORK (local workspace) REAL array, dimension (LWORK)
+*
+* LWORK (local input) INTEGER
+* The length of the array WORK. LWORK >= SIZETST as
+* returned by PSLASIZESEPR
+*
+* IWORK (local workspace) INTEGER array, dimension (LIWORK)
+*
+* LIWORK (local input) INTEGER
+* The length of the array IWORK. LIWORK >= ISIZETST as
+* returned by PSLASIZESEPR
+*
+* HETERO (input) INTEGER
+*
+* NOUT (local input) INTEGER
+* The unit number for output file. Only used on node 0.
+* NOUT = 6, output to screen,
+* NOUT = 0, output to stderr.
+* NOUT = 13, output to file, divide thresh by 10.0
+* NOUT = 14, output to file, divide thresh by 20.0
+* (This hack allows us to test more stringently internally
+* so that when errors on found on other computers they will
+* be serious enough to warrant our attention.)
+*
+* INFO (global output) INTEGER
+* -3 This process is not involved
+* 0 Test succeeded (passed |AQ -QL| and |QT*Q - I| tests)
+* 1 At least one test failed
+* 2 Residual test were not performed, thresh <= 0.0
+* 3 Test was skipped because of inadequate memory space
+*
+* .. Parameters ..
+ INTEGER CTXT_, MB_, NB_, RSRC_, CSRC_, LLD_
+ PARAMETER ( CTXT_ = 2, MB_ = 5, NB_ = 6,
+ $ RSRC_ = 7, CSRC_ = 8, LLD_ = 9 )
+ REAL HALF, ONE, TEN, ZERO
+ PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0,
+ $ TEN = 10.0E0, HALF = 0.5E0 )
+ REAL PADVAL
+ PARAMETER ( PADVAL = 19.25E0 )
+ INTEGER MAXTYP
+ PARAMETER ( MAXTYP = 22 )
+* ..
+*
+* .. Local Scalars ..
+ LOGICAL WKNOWN
+ CHARACTER JOBZ, RANGE
+ CHARACTER*14 PASSED
+ INTEGER CONTEXT, I, IAM, IHETERO, IINFO, IL, IMODE, IN,
+ $ INDD, INDWORK, ISIZESUBTST, ISIZEEVR,
+ $ ISIZETST, ITYPE, IU, J, LLWORK, LEVRSIZE,
+ $ MAXSIZE, MYCOL, MYROW, NB, NGEN, NLOC,
+ $ NNODES, NP, NPCOL, NPROW, NQ, RES, SIZECHK,
+ $ SIZEMQRLEFT, SIZEMQRRIGHT, SIZEQRF, SIZEQTQ,
+ $ SIZESUBTST, SIZEEVR, SIZETMS,
+ $ SIZETST, VALSIZE, VECSIZE
+ REAL ANINV, ANORM, COND, MAXQTQNRM, MAXTSTNRM, OVFL,
+ $ QTQNRM, RTOVFL, RTUNFL, TEMP1, TSTNRM, ULP,
+ $ ULPINV, UNFL, VL, VU
+* ..
+* .. Local Arrays ..
+ INTEGER ISEEDIN( 4 ), KMAGN( MAXTYP ), KMODE( MAXTYP ),
+ $ KTYPE( MAXTYP )
+ DOUBLE PRECISION CTIME( 10 ), WTIME( 10 )
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ INTEGER NUMROC
+ REAL SLARAN, PSLAMCH
+ EXTERNAL SLARAN, LSAME, NUMROC, PSLAMCH
+* ..
+* .. External Subroutines ..
+ EXTERNAL BLACS_GRIDINFO, BLACS_PINFO, IGAMX2D, IGEBR2D,
+ $ IGEBS2D, PSCHEKPAD, PSELSET, PSFILLPAD,
+ $ PSLASET, PSLASIZESEPR, PSLASIZESYEVR, PSLATMS,
+ $ PSMATGEN, PSSEPRSUBTST, SLABAD, SLASRT, SLATMS,
+ $ SLCOMBINE
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, REAL, INT, MAX, MIN, SQRT
+* ..
+* .. Data statements ..
+ DATA KTYPE / 1, 2, 4, 4, 4, 4, 4, 5, 5, 5, 5, 5, 8,
+ $ 8, 8, 9, 9, 9, 9, 9, 10, 11 /
+ DATA KMAGN / 1, 1, 1, 1, 1, 2, 3, 1, 1, 1, 2, 3, 1,
+ $ 2, 3, 1, 1, 1, 2, 3, 1, 1 /
+ DATA KMODE / 0, 0, 4, 3, 1, 4, 4, 4, 3, 1, 4, 4, 0,
+ $ 0, 0, 4, 3, 1, 4, 4, 3, 0 /
+* ..
+* .. Executable Statements ..
+*
+ INFO = 0
+ PASSED = 'PASSED EVR'
+ CONTEXT = DESCA( CTXT_ )
+ NB = DESCA( NB_ )
+*
+ CALL BLACS_PINFO( IAM, NNODES )
+ CALL BLACS_GRIDINFO( CONTEXT, NPROW, NPCOL, MYROW, MYCOL )
+*
+* Distribute HETERO across processes
+*
+ IF( IAM.EQ.0 ) THEN
+ IF( LSAME( HETERO, 'Y' ) ) THEN
+ IHETERO = 2
+ ELSE
+ IHETERO = 1
+ END IF
+ CALL IGEBS2D( CONTEXT, 'All', ' ', 1, 1, IHETERO, 1 )
+ ELSE
+ CALL IGEBR2D( CONTEXT, 'All', ' ', 1, 1, IHETERO, 1, 0, 0 )
+ END IF
+ IF( IHETERO.EQ.2 ) THEN
+ HETERO = 'Y'
+ ELSE
+ HETERO = 'N'
+ END IF
+*
+* Make sure that there is enough memory
+*
+ CALL PSLASIZESEPR( DESCA, IPREPAD, IPOSTPAD, SIZEMQRLEFT,
+ $ SIZEMQRRIGHT, SIZEQRF, SIZETMS, SIZEQTQ,
+ $ SIZECHK, SIZEEVR, ISIZEEVR,
+ $ SIZESUBTST,
+ $ ISIZESUBTST, SIZETST, ISIZETST )
+ IF( LWORK.LT.SIZETST ) THEN
+ INFO = 3
+ END IF
+*
+ CALL IGAMX2D( CONTEXT, 'a', ' ', 1, 1, INFO, 1, 1, 1, -1, -1, 0 )
+*
+ IF( INFO.EQ.0 ) THEN
+*
+ INDD = 1
+ INDWORK = INDD + N
+ LLWORK = LWORK - INDWORK + 1
+*
+ ULP = PSLAMCH( CONTEXT, 'P' )
+ ULPINV = ONE / ULP
+ UNFL = PSLAMCH( CONTEXT, 'Safe min' )
+ OVFL = ONE / UNFL
+ CALL SLABAD( UNFL, OVFL )
+ RTUNFL = SQRT( UNFL )
+ RTOVFL = SQRT( OVFL )
+ ANINV = ONE / REAL( MAX( 1, N ) )
+*
+* This ensures that everyone starts out with the same seed.
+*
+ IF( MYROW.EQ.0 .AND. MYCOL.EQ.0 ) THEN
+ CALL IGEBS2D( CONTEXT, 'a', ' ', 4, 1, ISEED, 4 )
+ ELSE
+ CALL IGEBR2D( CONTEXT, 'a', ' ', 4, 1, ISEED, 4, 0, 0 )
+ END IF
+ ISEEDIN( 1 ) = ISEED( 1 )
+ ISEEDIN( 2 ) = ISEED( 2 )
+ ISEEDIN( 3 ) = ISEED( 3 )
+ ISEEDIN( 4 ) = ISEED( 4 )
+*
+* Compute the matrix A
+*
+* Control parameters:
+*
+* KMAGN KMODE KTYPE
+* =1 O(1) clustered 1 zero
+* =2 large clustered 2 identity
+* =3 small exponential (none)
+* =4 arithmetic diagonal, (w/ eigenvalues)
+* =5 random log symmetric, w/ eigenvalues
+* =6 random (none)
+* =7 random diagonal
+* =8 random symmetric
+* =9 positive definite
+* =10 block diagonal with tridiagonal blocks
+* =11 Geometrically sized clusters.
+*
+ ITYPE = KTYPE( MATTYPE )
+ IMODE = KMODE( MATTYPE )
+*
+* Compute norm
+*
+ GO TO ( 10, 20, 30 )KMAGN( MATTYPE )
+*
+ 10 CONTINUE
+ ANORM = ONE
+ GO TO 40
+*
+ 20 CONTINUE
+ ANORM = ( RTOVFL*ULP )*ANINV
+ GO TO 40
+*
+ 30 CONTINUE
+ ANORM = RTUNFL*N*ULPINV
+ GO TO 40
+*
+ 40 CONTINUE
+ IF( MATTYPE.LE.15 ) THEN
+ COND = ULPINV
+ ELSE
+ COND = ULPINV*ANINV / TEN
+ END IF
+*
+* Special Matrices
+*
+ IF( ITYPE.EQ.1 ) THEN
+*
+* Zero Matrix
+*
+ DO 50 I = 1, N
+ WORK( INDD+I-1 ) = ZERO
+ 50 CONTINUE
+ CALL PSLASET( 'All', N, N, ZERO, ZERO, COPYA, 1, 1, DESCA )
+ WKNOWN = .TRUE.
+*
+ ELSE IF( ITYPE.EQ.2 ) THEN
+*
+* Identity Matrix
+*
+ DO 60 I = 1, N
+ WORK( INDD+I-1 ) = ONE
+ 60 CONTINUE
+ CALL PSLASET( 'All', N, N, ZERO, ONE, COPYA, 1, 1, DESCA )
+ WKNOWN = .TRUE.
+*
+ ELSE IF( ITYPE.EQ.4 ) THEN
+*
+* Diagonal Matrix, [Eigen]values Specified
+*
+ CALL PSFILLPAD( DESCA( CTXT_ ), SIZETMS, 1, WORK( INDWORK ),
+ $ SIZETMS, IPREPAD, IPOSTPAD, PADVAL+1.0E0 )
+*
+ CALL PSLATMS( N, N, 'S', ISEED, 'S', WORK( INDD ), IMODE,
+ $ COND, ANORM, 0, 0, 'N', COPYA, 1, 1, DESCA,
+ $ ORDER, WORK( INDWORK+IPREPAD ), SIZETMS,
+ $ IINFO )
+ WKNOWN = .TRUE.
+*
+ CALL PSCHEKPAD( DESCA( CTXT_ ), 'PSLATMS1-WORK', SIZETMS, 1,
+ $ WORK( INDWORK ), SIZETMS, IPREPAD, IPOSTPAD,
+ $ PADVAL+1.0E0 )
+*
+ ELSE IF( ITYPE.EQ.5 ) THEN
+*
+* symmetric, eigenvalues specified
+*
+ CALL PSFILLPAD( DESCA( CTXT_ ), SIZETMS, 1, WORK( INDWORK ),
+ $ SIZETMS, IPREPAD, IPOSTPAD, PADVAL+2.0E0 )
+*
+ CALL PSLATMS( N, N, 'S', ISEED, 'S', WORK( INDD ), IMODE,
+ $ COND, ANORM, N, N, 'N', COPYA, 1, 1, DESCA,
+ $ ORDER, WORK( INDWORK+IPREPAD ), SIZETMS,
+ $ IINFO )
+*
+ CALL PSCHEKPAD( DESCA( CTXT_ ), 'PSLATMS2-WORK', SIZETMS, 1,
+ $ WORK( INDWORK ), SIZETMS, IPREPAD, IPOSTPAD,
+ $ PADVAL+2.0E0 )
+*
+ WKNOWN = .TRUE.
+*
+ ELSE IF( ITYPE.EQ.8 ) THEN
+*
+* symmetric, random eigenvalues
+*
+ NP = NUMROC( N, DESCA( MB_ ), MYROW, 0, NPROW )
+ NQ = NUMROC( N, DESCA( NB_ ), MYCOL, 0, NPCOL )
+ CALL PSMATGEN( DESCA( CTXT_ ), 'S', 'N', N, N, DESCA( MB_ ),
+ $ DESCA( NB_ ), COPYA, DESCA( LLD_ ),
+ $ DESCA( RSRC_ ), DESCA( CSRC_ ), ISEED( 1 ),
+ $ 0, NP, 0, NQ, MYROW, MYCOL, NPROW, NPCOL )
+ INFO = 0
+ WKNOWN = .FALSE.
+*
+ ELSE IF( ITYPE.EQ.9 ) THEN
+*
+* Positive definite, eigenvalues specified.
+*
+ CALL PSFILLPAD( DESCA( CTXT_ ), SIZETMS, 1, WORK( INDWORK ),
+ $ SIZETMS, IPREPAD, IPOSTPAD, PADVAL+3.0E0 )
+*
+ CALL PSLATMS( N, N, 'S', ISEED, 'S', WORK( INDD ), IMODE,
+ $ COND, ANORM, N, N, 'N', COPYA, 1, 1, DESCA,
+ $ ORDER, WORK( INDWORK+IPREPAD ), SIZETMS,
+ $ IINFO )
+*
+ WKNOWN = .TRUE.
+*
+ CALL PSCHEKPAD( DESCA( CTXT_ ), 'PSLATMS3-WORK', SIZETMS, 1,
+ $ WORK( INDWORK ), SIZETMS, IPREPAD, IPOSTPAD,
+ $ PADVAL+3.0E0 )
+*
+ ELSE IF( ITYPE.EQ.10 ) THEN
+*
+* Block diagonal matrix with each block being a positive
+* definite tridiagonal submatrix.
+*
+ CALL PSLASET( 'All', N, N, ZERO, ZERO, COPYA, 1, 1, DESCA )
+ NP = NUMROC( N, DESCA( MB_ ), 0, 0, NPROW )
+ NQ = NUMROC( N, DESCA( NB_ ), 0, 0, NPCOL )
+ NLOC = MIN( NP, NQ )
+ NGEN = 0
+ 70 CONTINUE
+*
+ IF( NGEN.LT.N ) THEN
+ IN = MIN( 1+INT( SLARAN( ISEED )*REAL( NLOC ) ), N-NGEN )
+*
+ CALL SLATMS( IN, IN, 'S', ISEED, 'P', WORK( INDD ),
+ $ IMODE, COND, ANORM, 1, 1, 'N', A, LDA,
+ $ WORK( INDWORK ), IINFO )
+*
+ DO 80 I = 2, IN
+ TEMP1 = ABS( A( I-1, I ) ) /
+ $ SQRT( ABS( A( I-1, I-1 )*A( I, I ) ) )
+ IF( TEMP1.GT.HALF ) THEN
+ A( I-1, I ) = HALF*SQRT( ABS( A( I-1, I-1 )*A( I,
+ $ I ) ) )
+ A( I, I-1 ) = A( I-1, I )
+ END IF
+ 80 CONTINUE
+ CALL PSELSET( COPYA, NGEN+1, NGEN+1, DESCA, A( 1, 1 ) )
+ DO 90 I = 2, IN
+ CALL PSELSET( COPYA, NGEN+I, NGEN+I, DESCA,
+ $ A( I, I ) )
+ CALL PSELSET( COPYA, NGEN+I-1, NGEN+I, DESCA,
+ $ A( I-1, I ) )
+ CALL PSELSET( COPYA, NGEN+I, NGEN+I-1, DESCA,
+ $ A( I, I-1 ) )
+ 90 CONTINUE
+ NGEN = NGEN + IN
+ GO TO 70
+ END IF
+ WKNOWN = .FALSE.
+*
+ ELSE IF( ITYPE.EQ.11 ) THEN
+*
+* Geometrically sized clusters. Eigenvalues: 0,1,1,2,2,2,2,...
+*
+ NGEN = 0
+ J = 1
+ TEMP1 = ZERO
+ 100 CONTINUE
+ IF( NGEN.LT.N ) THEN
+ IN = MIN( J, N-NGEN )
+ DO 110 I = 0, IN - 1
+ WORK( INDD+NGEN+I ) = TEMP1
+ 110 CONTINUE
+ TEMP1 = TEMP1 + ONE
+ J = 2*J
+ NGEN = NGEN + IN
+ GO TO 100
+ END IF
+*
+ CALL PSFILLPAD( DESCA( CTXT_ ), SIZETMS, 1, WORK( INDWORK ),
+ $ SIZETMS, IPREPAD, IPOSTPAD, PADVAL+4.0E0 )
+*
+ CALL PSLATMS( N, N, 'S', ISEED, 'S', WORK( INDD ), IMODE,
+ $ COND, ANORM, 0, 0, 'N', COPYA, 1, 1, DESCA,
+ $ ORDER, WORK( INDWORK+IPREPAD ), SIZETMS,
+ $ IINFO )
+*
+ CALL PSCHEKPAD( DESCA( CTXT_ ), 'PSLATMS4-WORK', SIZETMS, 1,
+ $ WORK( INDWORK ), SIZETMS, IPREPAD, IPOSTPAD,
+ $ PADVAL+4.0E0 )
+*
+ ELSE
+ IINFO = 1
+ END IF
+*
+ IF( WKNOWN )
+ $ CALL SLASRT( 'I', N, WORK( INDD ), IINFO )
+*
+ CALL PSLASIZESYEVR( WKNOWN, 'A', N, DESCA, VL, VU, IL, IU,
+ $ ISEED, WORK( INDD ), MAXSIZE, VECSIZE,
+ $ VALSIZE )
+ LEVRSIZE = MIN( MAXSIZE, LLWORK )
+*
+ CALL PSSEPRSUBTST( WKNOWN, 'v', 'a', UPLO, N, VL, VU, IL, IU,
+ $ THRESH, ABSTOL, A, COPYA, Z, 1, 1, DESCA,
+ $ WORK( INDD ), WIN, IFAIL, ICLUSTR, GAP,
+ $ IPREPAD, IPOSTPAD, WORK( INDWORK ), LLWORK,
+ $ LEVRSIZE, IWORK, ISIZEEVR, RES, TSTNRM,
+ $ QTQNRM, NOUT )
+*
+ MAXTSTNRM = TSTNRM
+ MAXQTQNRM = QTQNRM
+*
+ IF( THRESH.LE.ZERO ) THEN
+ PASSED = 'SKIPPED '
+ INFO = 2
+ ELSE IF( RES.NE.0 ) THEN
+ PASSED = 'FAILED '
+ INFO = 1
+ END IF
+ END IF
+*
+ IF( THRESH.GT.ZERO .AND. LSAME( SUBTESTS, 'Y' ) ) THEN
+*
+* Subtest 1: JOBZ = 'N', RANGE = 'A', minimum memory
+*
+ IF( INFO.EQ.0 ) THEN
+*
+ JOBZ = 'N'
+ RANGE = 'A'
+ CALL PSLASIZESYEVR( .TRUE., RANGE, N, DESCA, VL, VU, IL, IU,
+ $ ISEED, WIN( 1+IPREPAD ), MAXSIZE,
+ $ VECSIZE, VALSIZE )
+*
+ LEVRSIZE = VALSIZE
+*
+ CALL PSSEPRSUBTST( .TRUE., JOBZ, RANGE, UPLO, N, VL, VU, IL,
+ $ IU, THRESH, ABSTOL, A, COPYA, Z, 1, 1,
+ $ DESCA, WIN( 1+IPREPAD ), WNEW, IFAIL,
+ $ ICLUSTR, GAP, IPREPAD, IPOSTPAD,
+ $ WORK( INDWORK ), LLWORK, LEVRSIZE,
+ $ IWORK, ISIZEEVR, RES, TSTNRM, QTQNRM,
+ $ NOUT )
+*
+ IF( RES.NE.0 ) THEN
+ MAXTSTNRM = MAX( TSTNRM, MAXTSTNRM )
+ MAXQTQNRM = MAX( QTQNRM, MAXQTQNRM )
+ PASSED = 'FAILED stest 1'
+ INFO = 1
+ END IF
+ END IF
+*
+* Subtest 2: JOBZ = 'N', RANGE = 'I', minimum memory
+*
+ IF( INFO.EQ.0 ) THEN
+*
+ IL = -1
+ IU = -1
+ JOBZ = 'N'
+ RANGE = 'I'
+*
+* Use PSLASIZESYEVR to choose IL and IU.
+*
+ CALL PSLASIZESYEVR( .TRUE., RANGE, N, DESCA, VL, VU, IL, IU,
+ $ ISEED, WIN( 1+IPREPAD ), MAXSIZE,
+ $ VECSIZE, VALSIZE )
+*
+ LEVRSIZE = VALSIZE
+*
+ CALL PSSEPRSUBTST( .TRUE., JOBZ, RANGE, UPLO, N, VL, VU, IL,
+ $ IU, THRESH, ABSTOL, A, COPYA, Z, 1, 1,
+ $ DESCA, WIN( 1+IPREPAD ), WNEW, IFAIL,
+ $ ICLUSTR, GAP, IPREPAD, IPOSTPAD,
+ $ WORK( INDWORK ), LLWORK, LEVRSIZE,
+ $ IWORK, ISIZEEVR, RES, TSTNRM, QTQNRM,
+ $ NOUT )
+*
+ IF( RES.NE.0 ) THEN
+ MAXTSTNRM = MAX( TSTNRM, MAXTSTNRM )
+ MAXQTQNRM = MAX( QTQNRM, MAXQTQNRM )
+ PASSED = 'FAILED stest 2'
+ INFO = 1
+ END IF
+ END IF
+*
+* Subtest 3: JOBZ = 'V', RANGE = 'I', minimum memory
+*
+ IF( INFO.EQ.0 ) THEN
+ IL = -1
+ IU = -1
+ JOBZ = 'V'
+ RANGE = 'I'
+*
+* We use PSLASIZESYEVR to choose IL and IU for us.
+*
+ CALL PSLASIZESYEVR( .TRUE., RANGE, N, DESCA, VL, VU, IL, IU,
+ $ ISEED, WIN( 1+IPREPAD ), MAXSIZE,
+ $ VECSIZE, VALSIZE )
+*
+ LEVRSIZE = VECSIZE
+*
+ CALL PSSEPRSUBTST( .TRUE., JOBZ, RANGE, UPLO, N, VL, VU, IL,
+ $ IU, THRESH, ABSTOL, A, COPYA, Z, 1, 1,
+ $ DESCA, WIN( 1+IPREPAD ), WNEW, IFAIL,
+ $ ICLUSTR, GAP, IPREPAD, IPOSTPAD,
+ $ WORK( INDWORK ), LLWORK, LEVRSIZE,
+ $ IWORK, ISIZEEVR, RES, TSTNRM, QTQNRM,
+ $ NOUT )
+*
+ IF( RES.NE.0 ) THEN
+ MAXTSTNRM = MAX( TSTNRM, MAXTSTNRM )
+ MAXQTQNRM = MAX( QTQNRM, MAXQTQNRM )
+ PASSED = 'FAILED stest 3'
+ INFO = 1
+ END IF
+ END IF
+*
+* Subtest 4: JOBZ = 'N', RANGE = 'V', minimum memory
+*
+ IF( INFO.EQ.0 ) THEN
+ VL = ONE
+ VU = -ONE
+ JOBZ = 'N'
+ RANGE = 'V'
+*
+* We use PSLASIZESYEVR to choose IL and IU for us.
+*
+ CALL PSLASIZESYEVR( .TRUE., RANGE, N, DESCA, VL, VU, IL, IU,
+ $ ISEED, WIN( 1+IPREPAD ), MAXSIZE,
+ $ VECSIZE, VALSIZE )
+*
+ LEVRSIZE = VALSIZE
+*
+ CALL PSSEPRSUBTST( .TRUE., JOBZ, RANGE, UPLO, N, VL, VU, IL,
+ $ IU, THRESH, ABSTOL, A, COPYA, Z, 1, 1,
+ $ DESCA, WIN( 1+IPREPAD ), WNEW, IFAIL,
+ $ ICLUSTR, GAP, IPREPAD, IPOSTPAD,
+ $ WORK( INDWORK ), LLWORK, LEVRSIZE,
+ $ IWORK, ISIZEEVR, RES, TSTNRM, QTQNRM,
+ $ NOUT )
+*
+ IF( RES.NE.0 ) THEN
+ MAXTSTNRM = MAX( TSTNRM, MAXTSTNRM )
+ MAXQTQNRM = MAX( QTQNRM, MAXQTQNRM )
+ PASSED = 'FAILED stest 4'
+ INFO = 1
+ END IF
+ END IF
+*
+* Subtest 5: JOBZ = 'V', RANGE = 'V', minimum memory
+*
+ IF( INFO.EQ.0 ) THEN
+ VL = ONE
+ VU = -ONE
+ JOBZ = 'V'
+ RANGE = 'V'
+*
+* We use PSLASIZESYEVR to choose VL and VU for us.
+*
+ CALL PSLASIZESYEVR( .TRUE., RANGE, N, DESCA, VL, VU, IL, IU,
+ $ ISEED, WIN( 1+IPREPAD ), MAXSIZE,
+ $ VECSIZE, VALSIZE )
+*
+ LEVRSIZE = VECSIZE
+*
+ CALL PSSEPRSUBTST( .TRUE., JOBZ, RANGE, UPLO, N, VL, VU, IL,
+ $ IU, THRESH, ABSTOL, A, COPYA, Z, 1, 1,
+ $ DESCA, WIN( 1+IPREPAD ), WNEW, IFAIL,
+ $ ICLUSTR, GAP, IPREPAD, IPOSTPAD,
+ $ WORK( INDWORK ), LLWORK, LEVRSIZE,
+ $ IWORK, ISIZEEVR, RES, TSTNRM, QTQNRM,
+ $ NOUT )
+*
+ IF( RES.NE.0 ) THEN
+ MAXTSTNRM = MAX( TSTNRM, MAXTSTNRM )
+ MAXQTQNRM = MAX( QTQNRM, MAXQTQNRM )
+ PASSED = 'FAILED stest 5'
+ INFO = 1
+ END IF
+ END IF
+ END IF
+*
+ CALL IGAMX2D( CONTEXT, 'All', ' ', 1, 1, INFO, 1, -1, -1, -1, -1,
+ $ -1 )
+ IF( INFO.EQ.1 ) THEN
+ IF( IAM.EQ.0 .AND. .FALSE. ) THEN
+ WRITE( NOUT, FMT = 9994 )'C '
+ WRITE( NOUT, FMT = 9993 )ISEEDIN( 1 )
+ WRITE( NOUT, FMT = 9992 )ISEEDIN( 2 )
+ WRITE( NOUT, FMT = 9991 )ISEEDIN( 3 )
+ WRITE( NOUT, FMT = 9990 )ISEEDIN( 4 )
+ IF( LSAME( UPLO, 'L' ) ) THEN
+ WRITE( NOUT, FMT = 9994 )' UPLO= ''L'' '
+ ELSE
+ WRITE( NOUT, FMT = 9994 )' UPLO= ''U'' '
+ END IF
+ IF( LSAME( SUBTESTS, 'Y' ) ) THEN
+ WRITE( NOUT, FMT = 9994 )' SUBTESTS= ''Y'' '
+ ELSE
+ WRITE( NOUT, FMT = 9994 )' SUBTESTS= ''N'' '
+ END IF
+ WRITE( NOUT, FMT = 9989 )N
+ WRITE( NOUT, FMT = 9988 )NPROW
+ WRITE( NOUT, FMT = 9987 )NPCOL
+ WRITE( NOUT, FMT = 9986 )NB
+ WRITE( NOUT, FMT = 9985 )MATTYPE
+ WRITE( NOUT, FMT = 9982 )ABSTOL
+ WRITE( NOUT, FMT = 9981 )THRESH
+ WRITE( NOUT, FMT = 9994 )'C '
+ END IF
+ END IF
+*
+ CALL SLCOMBINE( CONTEXT, 'All', '>', 'W', 6, 1, WTIME )
+ CALL SLCOMBINE( CONTEXT, 'All', '>', 'C', 6, 1, CTIME )
+ IF( IAM.EQ.0 ) THEN
+ IF( INFO.EQ.0 .OR. INFO.EQ.1 ) THEN
+ IF( WTIME( 1 ).GE.0.0 ) THEN
+ WRITE( NOUT, FMT = 9999 )N, NB, NPROW, NPCOL, MATTYPE,
+ $ SUBTESTS, WTIME( 1 ), CTIME( 1 ), MAXTSTNRM,
+ $ MAXQTQNRM, PASSED
+ ELSE
+ WRITE( NOUT, FMT = 9998 )N, NB, NPROW, NPCOL, MATTYPE,
+ $ SUBTESTS, CTIME( 1 ), MAXTSTNRM, MAXQTQNRM, PASSED
+ END IF
+ ELSE IF( INFO.EQ.2 ) THEN
+ IF( WTIME( 1 ).GE.0.0 ) THEN
+ WRITE( NOUT, FMT = 9997 )N, NB, NPROW, NPCOL, MATTYPE,
+ $ SUBTESTS, WTIME( 1 ), CTIME( 1 )
+ ELSE
+ WRITE( NOUT, FMT = 9996 )N, NB, NPROW, NPCOL, MATTYPE,
+ $ SUBTESTS, CTIME( 1 )
+ END IF
+ ELSE IF( INFO.EQ.3 ) THEN
+ WRITE( NOUT, FMT = 9995 )N, NB, NPROW, NPCOL, MATTYPE,
+ $ SUBTESTS
+ END IF
+C WRITE(*,*)'************************************************'
+ END IF
+*
+
+ RETURN
+ 9999 FORMAT( 1X, I5, 1X, I3, 1X, I3, 1X, I3, 1X, I3, 3X, A1, 1X,
+ $ F8.2, 1X, F8.2, 1X, G9.2, 1X, G9.2, 1X, A14 )
+ 9998 FORMAT( 1X, I5, 1X, I3, 1X, I3, 1X, I3, 1X, I3, 3X, A1, 1X, 8X,
+ $ 1X, F8.2, 1X, G9.2, 1X, G9.2, A14 )
+ 9997 FORMAT( 1X, I5, 1X, I3, 1X, I3, 1X, I3, 1X, I3, 3X, A1, 1X, F8.2,
+ $ 1X, F8.2, 21X, 'Bypassed' )
+ 9996 FORMAT( 1X, I5, 1X, I3, 1X, I3, 1X, I3, 1X, I3, 3X, A1, 1X, 8X,
+ $ 1X, F8.2, 21X, 'Bypassed' )
+ 9995 FORMAT( 1X, I5, 1X, I3, 1X, I3, 1X, I3, 1X, I3, 3X, A1, 32X,
+ $ 'Bad MEMORY parameters' )
+ 9994 FORMAT( A )
+ 9993 FORMAT( ' ISEED( 1 ) =', I8 )
+ 9992 FORMAT( ' ISEED( 2 ) =', I8 )
+ 9991 FORMAT( ' ISEED( 3 ) =', I8 )
+ 9990 FORMAT( ' ISEED( 4 ) =', I8 )
+ 9989 FORMAT( ' N=', I8 )
+ 9988 FORMAT( ' NPROW=', I8 )
+ 9987 FORMAT( ' NPCOL=', I8 )
+ 9986 FORMAT( ' NB=', I8 )
+ 9985 FORMAT( ' MATTYPE=', I8 )
+C 9984 FORMAT( ' IBTYPE=', I8 )
+C 9983 FORMAT( ' SUBTESTS=', A1 )
+ 9982 FORMAT( ' ABSTOL=', D16.6 )
+ 9981 FORMAT( ' THRESH=', D16.6 )
+C 9980 FORMAT( ' Increase TOTMEM in PSSEPRDRIVER' )
+*
+* End of PSSEPRTST
+*
+ END
+
+
+
+
diff --git a/TESTING/EIG/psseptst.f b/TESTING/EIG/psseptst.f
index 394116e..b808d44 100644
--- a/TESTING/EIG/psseptst.f
+++ b/TESTING/EIG/psseptst.f
@@ -533,6 +533,11 @@
$ WORK( INDWORK ), SIZETMS, IPREPAD, IPOSTPAD,
$ PADVAL+4.0E+0 )
*
+*
+* WKNOWN ... NOT SET, GUESS A DEFAULT
+*
+ WKNOWN = .TRUE.
+
ELSE
IINFO = 1
END IF
diff --git a/TESTING/EIG/pssvdtst.f b/TESTING/EIG/pssvdtst.f
index 91c0735..b7137ac 100644
--- a/TESTING/EIG/pssvdtst.f
+++ b/TESTING/EIG/pssvdtst.f
@@ -642,7 +642,7 @@
CALL BLACS_GRIDEXIT( CONTEXT )
110 CONTINUE
*
- 9999 FORMAT( A6, 2E10.4, 2I6, 2I4, I5, I6, 3F6.2, 4X, A1 )
+ 9999 FORMAT( A6, 2E10.3, 2I6, 2I4, I5, I6, 3F6.2, 4X, A1 )
120 CONTINUE
*
* End of PSSVDTST
diff --git a/TESTING/EIG/pzgseptst.f b/TESTING/EIG/pzgseptst.f
index 536f607..efc953e 100644
--- a/TESTING/EIG/pzgseptst.f
+++ b/TESTING/EIG/pzgseptst.f
@@ -547,6 +547,10 @@
$ WORK( INDWORK ), SIZETMS, IPREPAD, IPOSTPAD,
$ PADVAL+4.0D+0 )
*
+*
+* WKNOWN ... NOT SET, GUESS A DEFAULT
+*
+ WKNOWN = .TRUE.
ELSE
IINFO = 1
END IF
diff --git a/TESTING/EIG/pzlasizeheevr.f b/TESTING/EIG/pzlasizeheevr.f
new file mode 100644
index 0000000..7b7219d
--- /dev/null
+++ b/TESTING/EIG/pzlasizeheevr.f
@@ -0,0 +1,188 @@
+ SUBROUTINE PZLASIZEHEEVR( WKNOWN, RANGE, N, DESCA, VL, VU, IL, IU,
+ $ ISEED, WIN, MAXSIZE, VECSIZE, VALSIZE )
+*
+* -- ScaLAPACK routine (@(MODE)version *TBA*) --
+* University of California, Berkeley and
+* University of Tennessee, Knoxville.
+* October 21, 2006
+*
+ IMPLICIT NONE
+*
+* .. Scalar Arguments ..
+ LOGICAL WKNOWN
+ CHARACTER RANGE
+ INTEGER IL, IU, MAXSIZE, N, VALSIZE, VECSIZE
+ DOUBLE PRECISION VL, VU
+
+* ..
+* .. Array Arguments ..
+ INTEGER DESCA( * ), ISEED( 4 )
+ DOUBLE PRECISION WIN( * )
+* ..
+*
+* Purpose
+* =======
+*
+* PZLASIZEHEEVR computes the amount of memory needed by PZHEEVR
+* to ensure:
+* 1) Orthogonal Eigenvectors
+* 2) Eigenpairs with small residual norms
+*
+* Arguments
+* =========
+*
+* WKNOWN (global input) INTEGER
+* .FALSE.: WIN does not contain the eigenvalues
+* .TRUE.: WIN does contain the eigenvalues
+*
+* RANGE (global input) CHARACTER*1
+* = 'A': all eigenvalues will be found.
+* = 'V': all eigenvalues in the interval [VL,VU]
+* will be found.
+* = 'I': the IL-th through IU-th eigenvalues will be found.
+*
+* N (global input) INTEGER
+* Size of the matrix to be tested. (global size)
+*
+* DESCA (global input) INTEGER array dimension ( DLEN_ )
+*
+* VL (global input/output ) DOUBLE PRECISION
+* If RANGE='V', the lower bound of the interval to be searched
+* for eigenvalues. Not referenced if RANGE = 'A' or 'I'.
+* If VL > VU, RANGE='V' and WKNOWN = .TRUE., VL is set
+* to a random value near an entry in WIN
+*
+* VU (global input/output ) DOUBLE PRECISION
+* If RANGE='V', the upper bound of the interval to be searched
+* for eigenvalues. Not referenced if RANGE = 'A' or 'I'.
+* If VL > VU, RANGE='V' and WKNOWN = .TRUE., VU is set
+* to a random value near an entry in WIN
+*
+* IL (global input/output ) INTEGER
+* If RANGE='I', the index (from smallest to largest) of the
+* smallest eigenvalue to be returned. IL >= 1.
+* Not referenced if RANGE = 'A' or 'V'.
+* If IL < 0, RANGE='I' and WKNOWN = .TRUE., IL is set
+* to a random value from 1 to N
+*
+* IU (global input/output ) INTEGER
+* If RANGE='I', the index (from smallest to largest) of the
+* largest eigenvalue to be returned. min(IL,N) <= IU <= N.
+* Not referenced if RANGE = 'A' or 'V'.
+* If IU < 0, RANGE='I' and WKNOWN = .TRUE., IU is set
+* to a random value from IL to N
+*
+* ISEED (global input/output) INTEGER array, dimension (4)
+* On entry, the seed of the random number generator; the array
+* elements must be between 0 and 4095, and ISEED(4) must be
+* odd.
+* On exit, the seed is updated.
+* ISEED is not touched unless IL, IU, VL or VU are modified.
+*
+* WIN (global input) DOUBLE PRECISION array, dimension (N)
+* If WKNOWN=1, WIN contains the eigenvalues of the matrix.
+*
+* MAXSIZE (global output) INTEGER
+* Workspace required to guarantee that PZHEEVR will return
+* orthogonal eigenvectors. IF WKNOWN=0, MAXSIZE is set to a
+* a value which guarantees orthogonality no matter what the
+* spectrum is. If WKNOWN=1, MAXSIZE is set to a value which
+* guarantees orthogonality on a matrix with eigenvalues given
+* by WIN.
+*
+* VECSIZE (global output) INTEGER
+* Workspace required to guarantee that PZHEEVR
+* will compute eigenvectors.
+*
+* VALSIZE (global output) INTEGER
+* Workspace required to guarantee that PZHEEVR
+* will compute eigenvalues.
+*
+*
+* .. Parameters ..
+ INTEGER CTXT_, MB_
+ PARAMETER ( CTXT_ = 2, MB_ = 5 )
+ DOUBLE PRECISION TWENTY
+ PARAMETER ( TWENTY = 20.0D0 )
+* ..
+* .. Local Scalars ..
+*
+ INTEGER ILMIN, IUMAX,
+ $ MQ0, MYCOL, MYIL, MYIU, MYROW, NB, NEIG, NN,
+ $ NP0, NPCOL, NPROW
+ DOUBLE PRECISION ANORM, EPS, SAFMIN
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ INTEGER ICEIL, NUMROC
+ DOUBLE PRECISION DLARAN, PDLAMCH
+ EXTERNAL LSAME, ICEIL, NUMROC, DLARAN, PDLAMCH
+* ..
+* .. External Subroutines ..
+ EXTERNAL BLACS_GRIDINFO
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, DBLE, INT, MAX
+
+* ..
+* .. Executable Statements ..
+*
+ CALL BLACS_GRIDINFO( DESCA( CTXT_ ), NPROW, NPCOL, MYROW, MYCOL )
+ EPS = PDLAMCH( DESCA( CTXT_ ), 'Precision' )
+ SAFMIN = PDLAMCH( DESCA( CTXT_ ), 'Safe Minimum' )
+ NB = DESCA( MB_ )
+ NN = MAX( N, NB, 2 )
+ NP0 = NUMROC( NN, NB, 0, 0, NPROW )
+
+ VALSIZE = 3 + 5*N + MAX( 12*NN, NB*( NP0+1 ) )
+
+ IF( WKNOWN ) THEN
+ ANORM = SAFMIN / EPS
+ IF( N.GE.1 )
+ $ ANORM = MAX( ABS( WIN( 1 ) ), ABS( WIN( N ) ), ANORM )
+ IF( LSAME( RANGE, 'I' ) ) THEN
+ IF( IL.LT.0 )
+ $ IL = INT( DLARAN( ISEED )*DBLE( N ) ) + 1
+ IF( IU.LT.0 )
+ $ IU = INT( DLARAN( ISEED )*DBLE( N-IL ) ) + IL
+ IF( N.EQ.0 )
+ $ IU = 0
+ ELSE IF( LSAME( RANGE, 'V' ) ) THEN
+ IF( VL.GT.VU ) THEN
+ MYIL = INT( DLARAN( ISEED )*DBLE( N ) ) + 1
+ MYIU = INT( DLARAN( ISEED )*DBLE( N-MYIL ) ) + MYIL
+ VL = WIN( MYIL ) - TWENTY*EPS*ABS( WIN( MYIL ) )
+ VU = WIN( MYIU ) + TWENTY*EPS*ABS( WIN( MYIU ) )
+ VU = MAX( VU, VL+EPS*TWENTY*ABS( VL )+SAFMIN )
+ END IF
+ END IF
+*
+ END IF
+ IF( LSAME( RANGE, 'V' ) ) THEN
+* We do not know how many eigenvalues will be computed
+ ILMIN = 1
+ IUMAX = N
+ ELSE IF( LSAME( RANGE, 'I' ) ) THEN
+ ILMIN = IL
+ IUMAX = IU
+ ELSE IF( LSAME( RANGE, 'A' ) ) THEN
+ ILMIN = 1
+ IUMAX = N
+ END IF
+*
+ NEIG = IUMAX - ILMIN + 1
+*
+ MQ0 = NUMROC( MAX( NEIG, NB, 2 ), NB, 0, 0, NPCOL )
+*
+ VECSIZE = 3 + 5*N + MAX( 18*NN, NP0*MQ0+2*NB*NB ) +
+ $ (2 + ICEIL( NEIG, NPROW*NPCOL ))*NN
+
+ VALSIZE = MAX(3, VALSIZE)
+ VECSIZE = MAX(3, VECSIZE)
+ MAXSIZE = VECSIZE
+*
+ RETURN
+*
+* End of PZLASIZEHEEVR
+*
+ END
diff --git a/TESTING/EIG/pzlasizesepr.f b/TESTING/EIG/pzlasizesepr.f
new file mode 100644
index 0000000..0b978be
--- /dev/null
+++ b/TESTING/EIG/pzlasizesepr.f
@@ -0,0 +1,167 @@
+ SUBROUTINE PZLASIZESEPR( DESCA, IPREPAD, IPOSTPAD, SIZEMQRLEFT,
+ $ SIZEMQRRIGHT, SIZEQRF, SIZETMS, SIZEQTQ,
+ $ SIZECHK, SIZEHEEVR, RSIZEHEEVR,
+ $ ISIZEHEEVR, SIZESUBTST, RSIZESUBTST,
+ $ ISIZESUBTST, SIZETST, RSIZETST,
+ $ ISIZETST )
+*
+* -- ScaLAPACK routine (@(MODE)version *TBA*) --
+* University of California, Berkeley and
+* University of Tennessee, Knoxville.
+* October 21, 2006
+*
+ IMPLICIT NONE
+*
+* .. Scalar Arguments ..
+ INTEGER IPOSTPAD, IPREPAD, ISIZEHEEVR, ISIZESUBTST,
+ $ ISIZETST, RSIZEHEEVR, RSIZESUBTST, RSIZETST,
+ $ SIZECHK, SIZEHEEVR, SIZEMQRLEFT, SIZEMQRRIGHT,
+ $ SIZEQRF, SIZEQTQ, SIZESUBTST, SIZETMS, SIZETST
+* ..
+* .. Array Arguments ..
+ INTEGER DESCA( * )
+*
+* Purpose
+* =======
+*
+* PZLASIZESEPR computes the amount of memory needed by
+* various SEPR test routines, as well as PZHEEVR itself.
+*
+* Arguments
+* =========
+*
+* DESCA (global input) INTEGER array dimension ( DLEN_ )
+* Array descriptor for dense matrix.
+*
+* SIZEMQRLEFT LWORK for the 1st PZUNMQR call in PZLAGHE
+*
+* SIZEMQRRIGHT LWORK for the 2nd PZUNMQR call in PZLAGHE
+*
+* SIZEQRF LWORK for PZGEQRF in PZLAGHE
+*
+* SIZETMS LWORK for PZLATMS
+*
+* SIZEQTQ LWORK for PZSEPQTQ
+*
+* SIZECHK LWORK for PZSEPCHK
+*
+* SIZEHEEVR LWORK for PZHEEVR
+*
+* RSIZEHEEVR LRWORK for PZHEEVR
+*
+* ISIZEHEEVR LIWORK for PZHEEVR
+*
+* SIZESUBTST LWORK for PZSEPRSUBTST
+*
+* RSIZESUBTST LRWORK for PZSEPRSUBTST
+*
+* ISIZESUBTST LIWORK for PZSEPRSUBTST
+*
+* SIZETST LWORK for PZSEPRTST
+*
+* RSIZETST LRWORK for PZSEPRTST
+*
+* ISIZETST LIWORK for PZSEPRTST
+*
+*
+* .. Parameters ..
+ INTEGER CTXT_, M_,
+ $ MB_, NB_, RSRC_, CSRC_, LLD_
+ PARAMETER (
+ $ CTXT_ = 2, M_ = 3, MB_ = 5, NB_ = 6,
+ $ RSRC_ = 7, CSRC_ = 8, LLD_ = 9 )
+* ..
+* .. Local Scalars ..
+ INTEGER CSRC_A, IACOL, IAROW, ICOFFA, IROFFA, LCM,
+ $ LCMQ, LDA, MQ0, MYCOL, MYROW, N, NB, NEIG, NN,
+ $ NNP, NP, NP0, NPCOL, NPROW, NQ, RSRC_A
+ INTEGER ANB, ICTXT, NHETRD_LWOPT, NPS, SQNPC
+* ..
+* .. External Functions ..
+ INTEGER ICEIL, ILCM, INDXG2P, NUMROC
+ EXTERNAL ICEIL, ILCM, INDXG2P, NUMROC
+ INTEGER PJLAENV
+ EXTERNAL PJLAENV
+*
+* .. External Subroutines ..
+ EXTERNAL BLACS_GRIDINFO
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC DBLE, INT, MAX, SQRT
+* ..
+* .. Executable Statements ..
+*
+ N = DESCA( M_ )
+ NB = DESCA( MB_ )
+ RSRC_A = DESCA( RSRC_ )
+ CSRC_A = DESCA( CSRC_ )
+*
+ LDA = DESCA( LLD_ )
+ CALL BLACS_GRIDINFO( DESCA( CTXT_ ), NPROW, NPCOL, MYROW, MYCOL )
+*
+ LCM = ILCM( NPROW, NPCOL )
+ LCMQ = LCM / NPCOL
+ IROFFA = 0
+ ICOFFA = 0
+ IAROW = INDXG2P( 1, NB, MYROW, RSRC_A, NPROW )
+ IACOL = INDXG2P( 1, NB, MYCOL, CSRC_A, NPCOL )
+ NP = NUMROC( N+IROFFA, NB, MYROW, IAROW, NPROW )
+ NQ = NUMROC( N+ICOFFA, NB, MYCOL, IACOL, NPCOL )
+ SIZEMQRLEFT = MAX( ( NB*( NB-1 ) ) / 2, ( NP+NQ )*NB ) + NB*NB
+ SIZEMQRRIGHT = MAX( ( NB*( NB-1 ) ) / 2,
+ $ ( NQ+MAX( NP+NUMROC( NUMROC( N+ICOFFA, NB, 0, 0,
+ $ NPCOL ), NB, 0, 0, LCMQ ), NP ) )*NB ) + NB*NB
+ SIZEQRF = NB*NP + NB*NQ + NB*NB
+ SIZETMS = ( LDA+1 )*MAX( 1, NQ ) +
+ $ MAX( SIZEMQRLEFT, SIZEMQRRIGHT, SIZEQRF )
+*
+ NP0 = NUMROC( N, DESCA( MB_ ), 0, 0, NPROW )
+ MQ0 = NUMROC( N, DESCA( NB_ ), 0, 0, NPCOL )
+ SIZEQTQ = 2 + MAX( DESCA( MB_ ), 2 )*( 2*NP0+MQ0 )
+ SIZECHK = NUMROC( N, DESCA( NB_ ), MYCOL, 0, NPCOL )
+*
+ NEIG = N
+ NN = MAX( N, NB, 2 ) + 1
+ NP0 = NUMROC( NN, NB, 0, 0, NPROW )
+ MQ0 = NUMROC( MAX( NEIG, NB, 2 ), NB, 0, 0, NPCOL )
+ NNP = MAX( N, NPROW*NPCOL+1, 4 )
+*
+*
+ SIZEHEEVR = 1+N + ( NP0+MQ0+NB )*NB
+ SIZEHEEVR = MAX(3, SIZEHEEVR)
+ RSIZEHEEVR = 1 + 5*N + MAX( 18*NN, NP0*MQ0+2*NB*NB ) +
+ $ (2 + ICEIL( NEIG, NPROW*NPCOL ))*NN
+ RSIZEHEEVR = MAX(3, RSIZEHEEVR)
+*
+ ISIZEHEEVR = 12*NNP + 2*N
+*
+ ICTXT = DESCA( CTXT_ )
+ ANB = PJLAENV( ICTXT, 3, 'PZHETTRD', 'L', 0, 0, 0, 0 )
+ SQNPC = INT( SQRT( DBLE( NPROW*NPCOL ) ) )
+ NPS = MAX( NUMROC( N, 1, 0, 0, SQNPC ), 2*ANB )
+ NHETRD_LWOPT = 2*( ANB+1 )*( 4*NPS+2 ) + ( NPS+2 )*NPS
+ SIZEHEEVR = MAX( SIZEHEEVR, N + NHETRD_LWOPT )
+*
+ SIZESUBTST = MAX( SIZETMS, SIZEHEEVR ) +
+ $ IPREPAD + IPOSTPAD
+ RSIZESUBTST = MAX( SIZEQTQ, SIZECHK, RSIZEHEEVR ) +
+ $ IPREPAD + IPOSTPAD
+ ISIZESUBTST = ISIZEHEEVR + IPREPAD + IPOSTPAD
+*
+* Allow room for A, COPYA, Z, WORK
+*
+ SIZETST = 3*( LDA*NP+IPREPAD+IPOSTPAD ) + SIZESUBTST
+*
+* Allow room for DIAG, WIN, WNEW, GAP, RWORK
+*
+ RSIZETST = 4*( N+IPREPAD+IPOSTPAD ) + RSIZESUBTST
+*
+* Allow room for IFAIL, ICLUSTR, and IWORK
+* (only needed for PZHEEVX)
+*
+ ISIZETST = N + 2*NPROW*NPCOL + 2*( IPREPAD+IPOSTPAD ) +
+ $ ISIZESUBTST
+*
+*
+ RETURN
+ END
diff --git a/TESTING/EIG/pzsdpsubtst.f b/TESTING/EIG/pzsdpsubtst.f
index 77a7c00..3405114 100644
--- a/TESTING/EIG/pzsdpsubtst.f
+++ b/TESTING/EIG/pzsdpsubtst.f
@@ -172,7 +172,7 @@
* .. Local Scalars ..
INTEGER I, IAM, INFO, ISIZEHEEVD, ISIZEHEEVX,
$ ISIZESUBTST, ISIZETST, MYCOL, MYROW, NP, NPCOL,
- $ NPROW, NQ, NZ, RES, RSIZECHK, RSIZEHEEVD,
+ $ NPROW, NQ, RES, RSIZECHK, RSIZEHEEVD,
$ RSIZEHEEVX, RSIZEQTQ, RSIZESUBTST, RSIZETST,
$ SIZEHEEVD, SIZEHEEVX, SIZEMQRLEFT,
$ SIZEMQRRIGHT, SIZEQRF, SIZESUBTST, SIZETMS,
@@ -352,7 +352,7 @@
CALL PDFILLPAD( DESCA( CTXT_ ), RSIZECHK, 1, RWORK, RSIZECHK,
$ IPREPAD, IPOSTPAD, 4.3D+0 )
*
- CALL PZSEPCHK( N, NZ, COPYA, IA, JA, DESCA,
+ CALL PZSEPCHK( N, N, COPYA, IA, JA, DESCA,
$ MAX( ABSTOL+EPSNORMA, SAFMIN ), THRESH,
$ Z( 1+IPREPAD ), IA, JA, DESCA, A( 1+IPREPAD ),
$ IA, JA, DESCA, WNEW( 1+IPREPAD ),
diff --git a/TESTING/EIG/pzsepchk.f b/TESTING/EIG/pzsepchk.f
index d50e109..ad7bd1a 100644
--- a/TESTING/EIG/pzsepchk.f
+++ b/TESTING/EIG/pzsepchk.f
@@ -4,10 +4,9 @@
$ Q, IQ, JQ, DESCQ, C, IC, JC, DESCC, W, WORK,
$ LWORK, TSTNRM, RESULT )
*
-* -- ScaLAPACK routine (version 1.7) --
-* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
-* and University of California, Berkeley.
-* November 15, 1997
+* -- ScaLAPACK routine (version 2.0.2) --
+* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver
+* May 1 2012
*
* .. Scalar Arguments ..
INTEGER IA, IC, IQ, JA, JC, JQ, LWORK, MS, NV, RESULT
@@ -216,7 +215,7 @@
CALL BLACS_GRIDINFO( DESCA( CTXT_ ), NPROW, NPCOL, MYROW, MYCOL )
*
INFO = 0
- CALL CHK1MAT( MS, 1, MS, 2, IA, JA, DESCA, 6, INFO )
+ CALL CHK1MAT( MS, 1, MS, 1, IA, JA, DESCA, 6, INFO )
CALL CHK1MAT( MS, 1, NV, 2, IQ, JQ, DESCQ, 12, INFO )
CALL CHK1MAT( MS, 1, NV, 2, IC, JC, DESCC, 16, INFO )
*
diff --git a/TESTING/EIG/pzseprdriver.f b/TESTING/EIG/pzseprdriver.f
new file mode 100644
index 0000000..306e7bc
--- /dev/null
+++ b/TESTING/EIG/pzseprdriver.f
@@ -0,0 +1,260 @@
+ PROGRAM PZSEPRDRIVER
+*
+* Parallel COMPLEX*16 symmetric eigenproblem test driver for PZSYEVR
+*
+ IMPLICIT NONE
+*
+* The user should modify TOTMEM to indicate the maximum amount of
+* memory in bytes her system has. Remember to leave room in memory
+* for operating system, the BLACS buffer, etc. DBLESZ
+* indicates the length in bytes on the given platform for a number,
+* real for SINGLE/DOUBLE PRECISION, and complex for COMPLEX/COMPLEX*16.
+* For example, on a standard system, the length of a
+* DBLE is 16, and an integer takes up 4 bytes. Some playing around
+* to discover what the maximum value you can set MEMSIZ to may be
+* required.
+* All arrays used by factorization and solve are allocated out of
+* big array called MEM.
+*
+* TESTS PERFORMED
+* ===============
+*
+* This routine performs tests for combinations of: matrix size, process
+* configuration (nprow and npcol), block size (nb),
+* matrix type, range of eigenvalue (all, by value, by index),
+* and upper vs. lower storage.
+*
+* It returns an error message when heterogeneity is detected.
+*
+* The input file allows multiple requests where each one is
+* of the following sets:
+* matrix sizes: n
+* process configuration triples: nprow, npcol, nb
+* matrix types:
+* eigenvalue requests: all, by value, by position
+* storage (upper vs. lower): uplo
+*
+* TERMS:
+* Request - means a set of tests, which is the cross product of
+* a set of specifications from the input file.
+* Test - one element in the cross product, i.e. a specific input
+* size and type, process configuration, etc.
+*
+* .. Parameters ..
+*
+ INTEGER TOTMEM, DBLESZ, NIN
+ PARAMETER ( TOTMEM = 100000000, DBLESZ = 16, NIN = 11 )
+ INTEGER MEMSIZ
+ PARAMETER ( MEMSIZ = TOTMEM / DBLESZ )
+* ..
+* .. Local Scalars ..
+ CHARACTER HETERO
+ CHARACTER*80 SUMMRY, USRINFO
+ INTEGER CONTEXT, IAM, INFO, ISIEEE, MAXNODES, NNOCHECK,
+ $ NOUT, NPASSED, NPROCS, NSKIPPED, NTESTS
+* ..
+* .. Local Arrays ..
+*
+ INTEGER ISEED( 4 )
+ COMPLEX*16 MEM( MEMSIZ )
+* ..
+* .. External Functions ..
+ DOUBLE PRECISION DLAMCH
+ EXTERNAL DLAMCH
+* ..
+* .. External Subroutines ..
+*
+ EXTERNAL BLACS_EXIT, BLACS_GET, BLACS_GRIDEXIT,
+ $ BLACS_GRIDINIT, BLACS_PINFO, BLACS_SETUP,
+ $ IGAMN2D, PDLACHKIEEE, PDLASNBT, PZSEPRREQ
+* ..
+* .. Executable Statements ..
+*
+* Get starting information
+*
+ CALL BLACS_PINFO( IAM, NPROCS )
+*
+*
+ IF( IAM.EQ.0 ) THEN
+*
+* Open file and skip data file header
+*
+ OPEN( UNIT = NIN, FILE = 'SEPR.dat', STATUS = 'OLD' )
+ READ( NIN, FMT = * )SUMMRY
+ SUMMRY = ' '
+*
+* Read in user-supplied info about machine type, compiler, etc.
+*
+ READ( NIN, FMT = 9999 )USRINFO
+*
+* Read name and unit number for summary output file
+*
+ READ( NIN, FMT = * )SUMMRY
+ READ( NIN, FMT = * )NOUT
+ IF( NOUT.NE.0 .AND. NOUT.NE.6 )
+ $ OPEN( NOUT, FILE = SUMMRY, STATUS = 'UNKNOWN' )
+ READ( NIN, FMT = * )MAXNODES
+ READ( NIN, FMT = * )HETERO
+ END IF
+*
+ IF( NPROCS.LT.1 ) THEN
+ CALL BLACS_SETUP( IAM, MAXNODES )
+ NPROCS = MAXNODES
+ END IF
+*
+ CALL BLACS_GET( -1, 0, CONTEXT )
+ CALL BLACS_GRIDINIT( CONTEXT, 'R', 1, NPROCS )
+*
+ CALL PDLASNBT( ISIEEE )
+*
+ CALL IGAMN2D( CONTEXT, 'a', ' ', 1, 1, ISIEEE, 1, 1, 1, -1, -1,
+ $ 0 )
+*
+ IF( ( ISIEEE.NE.0 ) ) THEN
+ IF( IAM.EQ.0 ) THEN
+ WRITE( NOUT, FMT = 9997 )
+ WRITE( NOUT, FMT = 9996 )
+ WRITE( NOUT, FMT = 9995 )
+ END IF
+*
+ CALL PDLACHKIEEE( ISIEEE, DLAMCH( 'O' ), DLAMCH( 'U' ) )
+*
+ CALL IGAMN2D( CONTEXT, 'a', ' ', 1, 1, ISIEEE, 1, 1, 1, -1, -1,
+ $ 0 )
+*
+ IF( ISIEEE.EQ.0 ) THEN
+ GO TO 20
+ END IF
+*
+ IF( IAM.EQ.0 ) THEN
+ WRITE( NOUT, FMT = 9986 )
+ END IF
+*
+ END IF
+*
+ IF( IAM.EQ.0 ) THEN
+ WRITE( NOUT, FMT = 9999 )
+ $ 'Test ScaLAPACK symmetric eigendecomposition routine.'
+ WRITE( NOUT, FMT = 9999 )USRINFO
+ WRITE( NOUT, FMT = 9999 )' '
+ WRITE( NOUT, FMT = 9999 )'Running tests of the parallel ' //
+ $ 'symmetric eigenvalue routine: PZSYEVR.'
+ WRITE( NOUT, FMT = 9999 )'The following scaled residual ' //
+ $ 'checks will be computed:'
+ WRITE( NOUT, FMT = 9999 )' ||AQ - QL|| ' //
+ $ '/ ((abstol + ||A|| * eps) * N)'
+ WRITE( NOUT, FMT = 9999 )' ||Q^T*Q - I|| ' // '/ (N * eps)'
+ WRITE( NOUT, FMT = 9999 )
+ WRITE( NOUT, FMT = 9999 )'An explanation of the ' //
+ $ 'input/output parameters follows:'
+ WRITE( NOUT, FMT = 9999 )'RESULT : passed; or ' //
+ $ 'an indication of which eigen request test failed'
+ WRITE( NOUT, FMT = 9999 )
+ $ 'N : The number of rows and columns ' //
+ $ 'of the matrix A.'
+ WRITE( NOUT, FMT = 9999 )
+ $ 'P : The number of process rows.'
+ WRITE( NOUT, FMT = 9999 )
+ $ 'Q : The number of process columns.'
+ WRITE( NOUT, FMT = 9999 )
+ $ 'NB : The size of the square blocks' //
+ $ ' the matrix A is split into.'
+ WRITE( NOUT, FMT = 9999 )
+ $ 'THRESH : If a residual value is less ' //
+ $ 'than THRESH, RESULT = PASSED.'
+ WRITE( NOUT, FMT = 9999 )
+ $ 'TYP : matrix type (see PZSEPRTST).'
+ WRITE( NOUT, FMT = 9999 )'SUB : Subtests (Y/N).'
+ WRITE( NOUT, FMT = 9999 )'WALL : Wallclock time.'
+ WRITE( NOUT, FMT = 9999 )'CPU : CPU time.'
+ WRITE( NOUT, FMT = 9999 )'CHK : ||AQ - QL|| ' //
+ $ '/ ((abstol + ||A|| * eps) * N)'
+ WRITE( NOUT, FMT = 9999 )'QTQ : ||Q^T*Q - I||/ (N * eps)'
+ WRITE( NOUT, FMT = 9999 )
+ $ ' : when the adjusted QTQ norm exceeds THRESH',
+ $ ' it is printed,'
+ WRITE( NOUT, FMT = 9999 )
+ $ ' otherwise the true QTQ norm is printed.'
+ WRITE( NOUT, FMT = 9999 )
+ $ ' : If more than one test is done, CHK and QTQ '
+ WRITE( NOUT, FMT = 9999 )
+ $ ' are the max over all eigentests performed.'
+ WRITE( NOUT, FMT = 9999 )
+ $ 'TEST : EVR - testing PZSYEVR'
+ WRITE( NOUT, FMT = 9999 )' '
+ END IF
+*
+ NTESTS = 0
+ NPASSED = 0
+ NSKIPPED = 0
+ NNOCHECK = 0
+*
+ IF( IAM.EQ.0 ) THEN
+ WRITE( NOUT, FMT = 9979 )
+ WRITE( NOUT, FMT = 9978 )
+ END IF
+*
+ 10 CONTINUE
+*
+ ISEED( 1 ) = 139
+ ISEED( 2 ) = 1139
+ ISEED( 3 ) = 2139
+ ISEED( 4 ) = 3139
+*
+ CALL PZSEPRREQ( HETERO, NIN, MEM, MEMSIZ, NOUT, ISEED, NTESTS,
+ $ NSKIPPED, NNOCHECK, NPASSED, INFO )
+ IF( INFO.EQ.0 )
+ $ GO TO 10
+*
+ IF( IAM.EQ.0 ) THEN
+ WRITE( NOUT, FMT = 9985 )NTESTS
+ WRITE( NOUT, FMT = 9984 )NPASSED
+ WRITE( NOUT, FMT = 9983 )NNOCHECK
+ WRITE( NOUT, FMT = 9982 )NSKIPPED
+ WRITE( NOUT, FMT = 9981 )NTESTS - NPASSED - NSKIPPED -
+ $ NNOCHECK
+ WRITE( NOUT, FMT = * )
+ WRITE( NOUT, FMT = * )
+ WRITE( NOUT, FMT = 9980 )
+ END IF
+*
+* Uncomment this line on SUN systems to avoid the useless print out
+*
+c CALL IEEE_FLAGS( 'clear', 'exception', 'underflow', ' ')
+*
+ 20 CONTINUE
+ IF( IAM.EQ.0 ) THEN
+ CLOSE ( NIN )
+ IF( NOUT.NE.6 .AND. NOUT.NE.0 )
+ $ CLOSE ( NOUT )
+ END IF
+*
+ CALL BLACS_GRIDEXIT( CONTEXT )
+*
+ CALL BLACS_EXIT( 0 )
+ STOP
+*
+ 9999 FORMAT( A )
+ 9997 FORMAT( 'Check if overflow is handled in ieee default manner.' )
+ 9996 FORMAT( 'If this is the last output you see, you should assume')
+ 9995 FORMAT( 'that overflow caused a floating point exception.' )
+*
+ 9986 FORMAT( 'Test ok. The system appears to handle ieee overflow.' )
+*
+ 9985 FORMAT( 'Finished ', I6, ' tests, with the following results:' )
+ 9984 FORMAT( I5, ' tests completed and passed residual checks.' )
+ 9983 FORMAT( I5, ' tests completed without checking.' )
+ 9982 FORMAT( I5, ' tests skipped for lack of memory.' )
+ 9981 FORMAT( I5, ' tests completed and failed.' )
+ 9980 FORMAT( 'END OF TESTS.' )
+ 9979 FORMAT( ' N NB P Q TYP SUB WALL CPU ',
+ $ ' CHK QTQ CHECK TEST' )
+ 9978 FORMAT( ' ----- --- --- --- --- --- -------- --------',
+ $ ' --------- --------- ----- ----' )
+*
+* End of PZSEPRDRIVER
+*
+ END
+
+
+
diff --git a/TESTING/EIG/pzseprreq.f b/TESTING/EIG/pzseprreq.f
new file mode 100644
index 0000000..afa68f0
--- /dev/null
+++ b/TESTING/EIG/pzseprreq.f
@@ -0,0 +1,227 @@
+ SUBROUTINE PZSEPRREQ( HETERO, NIN, MEM, MEMSIZE, NOUT, ISEED,
+ $ NTESTS, NSKIPPED, NNOCHECK, NPASSED, INFO )
+*
+* -- ScaLAPACK routine (@(MODE)version *TBA*) --
+* University of California, Berkeley and
+* University of Tennessee, Knoxville.
+* October 21, 2006
+*
+ IMPLICIT NONE
+*
+* .. Scalar Arguments ..
+ CHARACTER HETERO
+ INTEGER INFO, MEMSIZE, NIN, NNOCHECK, NOUT, NPASSED,
+ $ NSKIPPED, NTESTS
+* ..
+* .. Array Arguments ..
+ INTEGER ISEED( 4 )
+ COMPLEX*16 MEM( MEMSIZE )
+*
+* Purpose
+* =======
+*
+* PZSEPRREQ performs one request from the input file 'SEPR.dat'
+* A request is the cross product of the specifications in the
+* input file. It prints one line per test.
+*
+* Arguments
+* =========
+*
+* NIN (local input) INTEGER
+* The unit number for the input file 'SEPR.dat'
+*
+* MEM (local input ) COMPLEX*16 ARRAY, dimension MEMSIZE
+* Array encompassing the available single precision memory
+*
+* MEMSIZE (local input) INTEGER
+* Size of MEM array
+*
+* NOUT (local input) INTEGER
+* The unit number for output file.
+* NOUT = 6, output to screen,
+* NOUT = 0, output to stderr.
+* NOUT = 13, output to file, divide thresh by 10
+* NOUT = 14, output to file, divide thresh by 20
+* Only used on node 0.
+* NOUT = 13, 14 allow the threshold to be tighter for our
+* internal testing which means that when a user reports
+* a threshold error, it is more likely to be significant.
+*
+* ISEED (global input/output) INTEGER array, dimension 4
+* Random number generator seed
+*
+* NTESTS (global input/output) INTEGER
+* NTESTS = NTESTS + tests requested
+*
+* NSKIPPED (global input/output) INTEGER
+* NSKIPPED = NSKIPPED + tests skipped
+*
+* NNOCHECK (global input/output) INTEGER
+* NNOCHECK = NNOCHECK + tests completed but not checked
+*
+* NPASSED (global input/output) INTEGER
+* NPASSED = NPASSED + tests which passed all checks
+*
+* INFO (global output) INTEGER
+* 0 = test request ran
+* -1 = end of file
+* -2 = incorrect .dat file
+*
+* .. Parameters ..
+*
+ INTEGER DLEN_
+ PARAMETER ( DLEN_ = 9 )
+ INTEGER DBLESZ, INTGSZ
+ PARAMETER ( DBLESZ = 8, INTGSZ = 4 )
+ INTEGER KMPXSZ
+ PARAMETER ( KMPXSZ = 16 )
+ INTEGER MAXSETSIZE
+ PARAMETER ( MAXSETSIZE = 50 )
+* ..
+* .. Local Scalars ..
+ CHARACTER SUBTESTS
+ INTEGER CONTEXT, IAM, IMIDPAD, INITCON, IPOSTPAD,
+ $ IPREPAD, ISIZESUBTST, ISIZEEVR, ISIZETST,
+ $ LDA, LLWORK, MATSIZE, MATTYPE, MYCOL, MYROW, N,
+ $ NB, NMATSIZES, NMATTYPES, NNODES, NP, NPCOL,
+ $ NPCONFIGS, NPROW, NQ, NUPLOS, ORDER, PCONFIG,
+ $ PTRA, PTRCOPYA, PTRGAP, PTRICLUS, PTRIFAIL,
+ $ PTRIWRK, PTRW, PTRW2, PTRWORK, PTRZ, RES,
+ $ SIZECHK, SIZEMQRLEFT, SIZEMQRRIGHT, SIZEQRF,
+ $ SIZEQTQ, SIZESUBTST, SIZEEVR,
+ $ SIZETMS, SIZETST, UPLO
+ INTEGER PTRRWORK, RSIZEEVR, RSIZESUBTST, RSIZETST
+*
+ DOUBLE PRECISION ABSTOL, THRESH
+* ..
+* .. Local Arrays ..
+ CHARACTER UPLOS( 2 )
+ INTEGER DESCA( DLEN_ ), MATSIZES( MAXSETSIZE ),
+ $ MATTYPES( MAXSETSIZE ), NBS( MAXSETSIZE ),
+ $ NPCOLS( MAXSETSIZE ), NPROWS( MAXSETSIZE )
+* ..
+* .. External Functions ..
+ INTEGER ICEIL, NUMROC
+ EXTERNAL ICEIL, NUMROC
+* ..
+* .. External Subroutines ..
+ EXTERNAL BLACS_ABORT, BLACS_GET, BLACS_GRIDEXIT,
+ $ BLACS_GRIDINFO, BLACS_GRIDINIT, BLACS_PINFO,
+ $ DESCINIT, PZLASIZESEPR, PDSEPINFO, PZSEPRTST
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX
+* ..
+* .. Executable Statements ..
+*
+ CALL BLACS_PINFO( IAM, NNODES )
+ CALL BLACS_GET( -1, 0, INITCON )
+ CALL BLACS_GRIDINIT( INITCON, 'R', 1, NNODES )
+*
+ CALL PDSEPINFO( INITCON, IAM, NIN, NOUT, MAXSETSIZE, NMATSIZES,
+ $ MATSIZES, NUPLOS, UPLOS, NPCONFIGS, NPROWS,
+ $ NPCOLS, NBS, NMATTYPES, MATTYPES, 22, SUBTESTS,
+ $ THRESH, ORDER, ABSTOL, INFO )
+*
+ CALL BLACS_GRIDEXIT( INITCON )
+*
+ IF( INFO.EQ.0 ) THEN
+*
+ DO 40 MATSIZE = 1, NMATSIZES
+*
+ DO 30 PCONFIG = 1, NPCONFIGS
+*
+ DO 20 MATTYPE = 1, NMATTYPES
+*
+ DO 10 UPLO = 1, NUPLOS
+*
+ N = MATSIZES( MATSIZE )
+ ORDER = N
+*
+ NPROW = NPROWS( PCONFIG )
+ NPCOL = NPCOLS( PCONFIG )
+ NB = NBS( PCONFIG )
+*
+ NP = NUMROC( N, NB, 0, 0, NPROW )
+ NQ = NUMROC( N, NB, 0, 0, NPCOL )
+ IPREPAD = MAX( NB, NP )
+ IMIDPAD = NB
+ IPOSTPAD = MAX( NB, NQ )
+*
+ LDA = MAX( NP, 1 ) + IMIDPAD
+*
+ CALL BLACS_GET( -1, 0, CONTEXT )
+ CALL BLACS_GRIDINIT( CONTEXT, 'R', NPROW, NPCOL )
+ CALL BLACS_GRIDINFO( CONTEXT, NPROW, NPCOL, MYROW,
+ $ MYCOL )
+*
+ IF( MYROW.GE.0 ) THEN
+ CALL DESCINIT( DESCA, N, N, NB, NB, 0, 0,
+ $ CONTEXT, LDA, INFO )
+ CALL PZLASIZESEPR( DESCA, IPREPAD, IPOSTPAD,
+ $ SIZEMQRLEFT, SIZEMQRRIGHT,
+ $ SIZEQRF, SIZETMS, SIZEQTQ,
+ $ SIZECHK, SIZEEVR, RSIZEEVR,
+ $ ISIZEEVR, SIZESUBTST,
+ $ RSIZESUBTST, ISIZESUBTST,
+ $ SIZETST, RSIZETST, ISIZETST )
+*
+ PTRA = 1
+ PTRZ = PTRA + LDA*NQ + IPREPAD + IPOSTPAD
+ PTRCOPYA = PTRZ + LDA*NQ + IPREPAD + IPOSTPAD
+ PTRW = PTRCOPYA + LDA*NQ + IPREPAD + IPOSTPAD
+ PTRW2 = PTRW + ICEIL( MAX( N, 1 )+IPREPAD+
+ $ IPOSTPAD, KMPXSZ / DBLESZ )
+ PTRWORK = PTRW2 + ICEIL( MAX( N, 1 )+IPREPAD+
+ $ IPOSTPAD, KMPXSZ / DBLESZ )
+ PTRGAP = PTRWORK + SIZETST + IPREPAD + IPOSTPAD
+ PTRIFAIL = PTRGAP + ICEIL( NPROW*NPCOL+IPREPAD+
+ $ IPOSTPAD, KMPXSZ / DBLESZ )
+ PTRICLUS = PTRIFAIL + ICEIL( N+IPREPAD+IPOSTPAD,
+ $ KMPXSZ / INTGSZ )
+ PTRIWRK = PTRICLUS + ICEIL( 2*NPROW*NPCOL+
+ $ IPREPAD+IPOSTPAD, KMPXSZ / INTGSZ )
+ PTRRWORK = PTRIWRK + ICEIL( ISIZETST+IPREPAD+
+ $ IPOSTPAD, KMPXSZ / INTGSZ )
+ LLWORK = ( MEMSIZE-PTRRWORK+1 )*KMPXSZ / DBLESZ
+
+ NTESTS = NTESTS + 1
+ IF( LLWORK.LT.RSIZETST ) THEN
+ NSKIPPED = NSKIPPED + 1
+ ELSE
+ CALL PZSEPRTST( DESCA, UPLOS( UPLO ), N,
+ $ MATTYPES( MATTYPE ), SUBTESTS,
+ $ THRESH, N, ABSTOL, ISEED,
+ $ MEM( PTRA ), MEM( PTRCOPYA ),
+ $ MEM( PTRZ ), LDA, MEM( PTRW ),
+ $ MEM( PTRW2 ), MEM( PTRIFAIL ),
+ $ MEM( PTRICLUS ),
+ $ MEM( PTRGAP ), IPREPAD,
+ $ IPOSTPAD, MEM( PTRWORK ),
+ $ SIZETST, MEM( PTRRWORK ),
+ $ LLWORK, MEM( PTRIWRK ),
+ $ ISIZETST, HETERO, NOUT, RES )
+*
+ IF( RES.EQ.0 ) THEN
+ NPASSED = NPASSED + 1
+ ELSE IF( RES.EQ.2 ) THEN
+ NNOCHECK = NNOCHECK + 1
+ ELSE IF( RES.EQ.3 ) THEN
+ NSKIPPED = NSKIPPED + 1
+ WRITE( NOUT, FMT = * )' PZSEPRREQ failed'
+ CALL BLACS_ABORT( CONTEXT, -1 )
+ END IF
+ END IF
+ CALL BLACS_GRIDEXIT( CONTEXT )
+ END IF
+ 10 CONTINUE
+ 20 CONTINUE
+ 30 CONTINUE
+ 40 CONTINUE
+ END IF
+*
+ RETURN
+*
+* End of PZSEPRREQ
+*
+ END
diff --git a/TESTING/EIG/pzseprsubtst.f b/TESTING/EIG/pzseprsubtst.f
new file mode 100644
index 0000000..a7e09d6
--- /dev/null
+++ b/TESTING/EIG/pzseprsubtst.f
@@ -0,0 +1,828 @@
+ SUBROUTINE PZSEPRSUBTST( WKNOWN, JOBZ, RANGE, UPLO, N, VL, VU, IL,
+ $ IU, THRESH, ABSTOL, A, COPYA, Z, IA, JA,
+ $ DESCA, WIN, WNEW, IFAIL, ICLUSTR, GAP,
+ $ IPREPAD, IPOSTPAD, WORK, LWORK, RWORK,
+ $ LRWORK, LWORK1, IWORK, LIWORK, RESULT,
+ $ TSTNRM, QTQNRM, NOUT )
+*
+* -- ScaLAPACK routine (@(MODE)version *TBA*) --
+* University of California, Berkeley and
+* University of Tennessee, Knoxville.
+* October 21, 2006
+*
+ IMPLICIT NONE
+*
+* .. Scalar Arguments ..
+ LOGICAL WKNOWN
+ CHARACTER JOBZ, RANGE, UPLO
+ INTEGER IA, IL, IPOSTPAD, IPREPAD, IU, JA, LIWORK,
+ $ LWORK, LWORK1, N, NOUT, RESULT
+ DOUBLE PRECISION ABSTOL, QTQNRM, THRESH, TSTNRM, VL, VU
+ INTEGER LRWORK
+* ..
+* .. Array Arguments ..
+ INTEGER DESCA( * ), ICLUSTR( * ), IFAIL( * ),
+ $ IWORK( * )
+ COMPLEX*16 A( * ), COPYA( * ), WORK( * ), Z( * )
+ DOUBLE PRECISION GAP( * ), RWORK( * ), WIN( * ), WNEW( * )
+* ..
+*
+* Purpose
+* =======
+*
+* PZSEPRSUBTST calls PZSYEVR and then tests its output.
+* If JOBZ = 'V' then the following two tests are performed:
+* |AQ -QL| / (abstol + eps * norm(A) ) < N*THRESH
+* |QT * Q - I| / eps < N*THRESH
+* If WKNOWN then
+* we check to make sure that the eigenvalues match expectations
+* i.e. |WIN - WNEW(1+IPREPAD)| / (eps * |WIN|) < THRESH
+* where WIN is the array of eigenvalues computed.
+*
+* Arguments
+* =========
+*
+* NP = the number of rows local to a given process.
+* NQ = the number of columns local to a given process.
+*
+* WKNOWN (global input) INTEGER
+* .FALSE.: WIN does not contain the eigenvalues
+* .TRUE.: WIN does contain the eigenvalues
+*
+* JOBZ (global input) CHARACTER*1
+* Specifies whether or not to compute the eigenvectors:
+* = 'N': Compute eigenvalues only.
+* = 'V': Compute eigenvalues and eigenvectors.
+* Must be 'V' on first call.
+*
+* RANGE (global input) CHARACTER*1
+* = 'A': all eigenvalues will be found.
+* = 'V': all eigenvalues in the interval [VL,VU]
+* will be found.
+* = 'I': the IL-th through IU-th eigenvalues will be found.
+* Must be 'A' on first call.
+*
+* UPLO (global input) CHARACTER*1
+* Specifies whether the upper or lower triangular part of the
+* matrix A is stored:
+* = 'U': Upper triangular
+* = 'L': Lower triangular
+*
+* N (global input) INTEGER
+* Size of the matrix to be tested. (global size)
+*
+* VL (global input) DOUBLE PRECISION
+* If RANGE='V', the lower bound of the interval to be searched
+* for eigenvalues. Not referenced if RANGE = 'A' or 'I'.
+*
+* VU (global input) DOUBLE PRECISION
+* If RANGE='V', the upper bound of the interval to be searched
+* for eigenvalues. Not referenced if RANGE = 'A' or 'I'.
+*
+* IL (global input) INTEGER
+* If RANGE='I', the index (from smallest to largest) of the
+* smallest eigenvalue to be returned. IL >= 1.
+* Not referenced if RANGE = 'A' or 'V'.
+*
+* IU (global input) INTEGER
+* If RANGE='I', the index (from smallest to largest) of the
+* largest eigenvalue to be returned. min(IL,N) <= IU <= N.
+* Not referenced if RANGE = 'A' or 'V'.
+*
+* THRESH (global input) DOUBLE PRECISION
+* A test will count as "failed" if the "error", computed as
+* described below, exceeds THRESH. Note that the error
+* is scaled to be O(1), so THRESH should be a reasonably
+* small multiple of 1, e.g., 100 or 250. In particular,
+* it should not depend on the size of the matrix.
+* It must be at least zero.
+*
+* ABSTOL (global input) DOUBLE PRECISION
+* The absolute tolerance for the residual test.
+*
+* A (local workspace) COMPLEX*16 array
+* global dimension (N, N), local dimension (DESCA(DLEN_), NQ)
+* The test matrix, which is subsequently overwritten.
+* A is distributed in a 2D-block cyclic manner over both rows
+* and columns.
+* A has already been padded front and back, use A(1+IPREPAD)
+*
+* COPYA (local input) COMPLEX*16 array, dimension(N*N)
+* COPYA holds a copy of the original matrix A
+* identical in both form and content to A
+*
+* Z (local workspace) COMPLEX*16 array, dim (N*N)
+* Z is distributed in the same manner as A
+* Z contains the eigenvector matrix
+* Z is used as workspace by the test routines
+* PZSEPCHK and PZSEPQTQ.
+* Z has already been padded front and back, use Z(1+IPREPAD)
+*
+* IA (global input) INTEGER
+* On entry, IA specifies the global row index of the submatrix
+* of the global matrix A, COPYA and Z to operate on.
+*
+* JA (global input) INTEGER
+* On entry, IA specifies the global column index of the submat
+* of the global matrix A, COPYA and Z to operate on.
+*
+* DESCA (global/local input) INTEGER array of dimension 8
+* The array descriptor for the matrix A, COPYA and Z.
+*
+* WIN (global input) DOUBLE PRECISION array, dimension (N)
+* If .not. WKNOWN, WIN is ignored on input
+* Otherwise, WIN() is taken as the standard by which the
+* eigenvalues are to be compared against.
+*
+* WNEW (global workspace) DOUBLE PRECISION array, dimension (N)
+* The computed eigenvalues.
+* If JOBZ <> 'V' or RANGE <> 'A' these eigenvalues are
+* compared against those in WIN().
+* WNEW has already been padded front and back,
+* use WNEW(1+IPREPAD)
+*
+* IFAIL (global output) INTEGER array, dimension (N)
+* If JOBZ = 'V', then on normal exit, the first M elements of
+* IFAIL are zero. If INFO > 0 on exit, then IFAIL contains the
+* indices of the eigenvectors that failed to converge.
+* If JOBZ = 'N', then IFAIL is not referenced.
+* IFAIL has already been padded front and back,
+* use IFAIL(1+IPREPAD)
+*
+* ICLUSTR (global workspace) integer array, dimension (2*NPROW*NPCOL)
+*
+* GAP (global workspace) DOUBLE PRECISION array,
+* dimension (NPROW*NPCOL)
+*
+* WORK (local workspace) COMPLEX*16 array, dimension (LWORK)
+* WORK has already been padded front and back,
+* use WORK(1+IPREPAD)
+*
+* LWORK (local input) INTEGER
+* The actual length of the array WORK after padding.
+*
+* RWORK (local workspace) DOUBLE PRECISION array, dimension (LRWORK)
+* RWORK has already been padded front and back,
+* use RWORK(1+IPREPAD)
+*
+* LRWORK (local input) INTEGER
+* The actual length of the array RWORK after padding.
+*
+* LWORK1 (local input) INTEGER
+* The amount of real workspace to pass to the eigensolver.
+*
+* IWORK (local workspace) INTEGER array, dimension (LIWORK)
+* IWORK has already been padded front and back,
+* use IWORK(1+IPREPAD)
+*
+* LIWORK (local input) INTEGER
+* The length of the array IWORK after padding.
+*
+* RESULT (global output) INTEGER
+* The result of this call.
+* RESULT = -3 => This process did not participate
+* RESULT = 0 => All tests passed
+* RESULT = 1 => ONe or more tests failed
+*
+* TSTNRM (global output) DOUBLE PRECISION
+* |AQ- QL| / (ABSTOL+EPS*|A|)*N
+*
+* QTQNRM (global output) DOUBLE PRECISION
+* |QTQ -I| / N*EPS
+*
+* .. Parameters ..
+*
+ INTEGER DLEN_, CTXT_, M_, N_,
+ $ MB_, NB_, RSRC_, CSRC_, LLD_
+ PARAMETER ( DLEN_ = 9,
+ $ CTXT_ = 2, M_ = 3, N_ = 4, MB_ = 5, NB_ = 6,
+ $ RSRC_ = 7, CSRC_ = 8, LLD_ = 9 )
+ DOUBLE PRECISION PADVAL, FIVE, NEGONE
+ PARAMETER ( PADVAL = 13.5285D0, FIVE = 5.0D0,
+ $ NEGONE = -1.0D0 )
+ COMPLEX*16 ZPADVAL
+ PARAMETER ( ZPADVAL = ( 13.989D0, 1.93D0 ) )
+ INTEGER IPADVAL
+ PARAMETER ( IPADVAL = 927 )
+* ..
+* .. Local Scalars ..
+ LOGICAL MISSLARGEST, MISSSMALLEST
+ INTEGER I, IAM, INDIWRK, INFO, ISIZESUBTST, ISIZEEVR,
+ $ ISIZETST, J, M, MAXEIGS, MAXIL, MAXIU, MAXSIZE,
+ $ MINIL, MQ, MYCOL, MYIL, MYROW, NCLUSTERS, NP,
+ $ NPCOL, NPROW, NQ, NZ, OLDIL, OLDIU, OLDNZ, RES,
+ $ SIZECHK, SIZEMQRLEFT, SIZEMQRRIGHT, SIZEQRF,
+ $ SIZEQTQ, SIZESUBTST, SIZEEVR, SIZETMS,
+ $ SIZETST, VALSIZE, VECSIZE
+ INTEGER RSIZEEVR, RSIZESUBTST, RSIZETST
+ DOUBLE PRECISION EPS, EPSNORMA, ERROR, MAXERROR, MAXVU,
+ $ MINERROR, MINVL, NORMWIN, OLDVL, OLDVU,
+ $ SAFMIN
+* ..
+* .. Local Arrays ..
+ INTEGER DESCZ( DLEN_ ), ISEED( 4 ), ITMP( 2 )
+* ..
+* .. External Functions ..
+*
+ LOGICAL LSAME
+ INTEGER NUMROC
+ DOUBLE PRECISION PDLAMCH, PZLANHE
+ EXTERNAL LSAME, NUMROC, PDLAMCH, PZLANHE
+* ..
+* .. External Subroutines ..
+ EXTERNAL BLACS_GRIDINFO, DESCINIT, DGAMN2D, DGAMX2D,
+ $ IGAMN2D, IGAMX2D, PDCHEKPAD, PDFILLPAD,
+ $ PICHEKPAD, PIFILLPAD, PZCHEKPAD, PZELSET,
+ $ PZFILLPAD, PZHEEVR, PZLASIZEHEEVR,
+ $ PZLASIZESEPR, PZSEPCHK, PZSEPQTQ, SLBOOT,
+ $ SLTIMER, ZLACPY
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX, MIN, MOD
+* ..
+* .. Executable Statements ..
+*
+ CALL PZLASIZESEPR( DESCA, IPREPAD, IPOSTPAD, SIZEMQRLEFT,
+ $ SIZEMQRRIGHT, SIZEQRF, SIZETMS, SIZEQTQ,
+ $ SIZECHK, SIZEEVR, RSIZEEVR, ISIZEEVR,
+ $ SIZESUBTST, RSIZESUBTST, ISIZESUBTST,
+ $ SIZETST, RSIZETST, ISIZETST )
+*
+ TSTNRM = NEGONE
+ QTQNRM = NEGONE
+ EPS = PDLAMCH( DESCA( CTXT_ ), 'Eps' )
+ SAFMIN = PDLAMCH( DESCA( CTXT_ ), 'Safe min' )
+*
+ NORMWIN = SAFMIN / EPS
+ IF( N.GE.1 )
+ $ NORMWIN = MAX( ABS( WIN( 1 ) ), ABS( WIN( N ) ), NORMWIN )
+*
+* Make sure that no information from previous calls is used
+*
+ NZ = -13
+ OLDNZ = NZ
+ OLDIL = IL
+ OLDIU = IU
+ OLDVL = VL
+ OLDVU = VU
+*
+ DO 10 I = 1, LWORK1, 1
+ RWORK( I+IPREPAD ) = 14.3D0
+ 10 CONTINUE
+*
+ DO 15 I = 1, LWORK, 1
+ WORK( I+IPREPAD ) = ( 15.63D0, 1.1D0 )
+ 15 CONTINUE
+*
+ DO 20 I = 1, LIWORK, 1
+ IWORK( I+IPREPAD ) = 14
+ 20 CONTINUE
+*
+ DO 30 I = 1, N
+ WNEW( I+IPREPAD ) = 3.14159D0
+ 30 CONTINUE
+*
+ ICLUSTR( 1+IPREPAD ) = 139
+*
+ IF (LSAME( RANGE, 'V' ) ) THEN
+* WRITE(*,*) 'VL VU = ', VL, ' ', VU
+ END IF
+
+ IF( LSAME( JOBZ, 'N' ) ) THEN
+ MAXEIGS = 0
+ ELSE
+ IF( LSAME( RANGE, 'A' ) ) THEN
+ MAXEIGS = N
+ ELSE IF( LSAME( RANGE, 'I' ) ) THEN
+ MAXEIGS = IU - IL + 1
+ ELSE
+ MINVL = VL - NORMWIN*FIVE*EPS - ABSTOL
+ MAXVU = VU + NORMWIN*FIVE*EPS + ABSTOL
+* WRITE(*,*) 'MINVL = ', MINVL, ' MAXVU = ', MAXVU
+* WRITE(*,*) 'WIN = ', WIN( 1 )
+ MINIL = 1
+ MAXIU = 0
+ DO 40 I = 1, N
+ IF( WIN( I ).LT.MINVL )
+ $ MINIL = MINIL + 1
+ IF( WIN( I ).LE.MAXVU )
+ $ MAXIU = MAXIU + 1
+ 40 CONTINUE
+*
+ MAXEIGS = MAXIU - MINIL + 1
+ END IF
+ END IF
+*
+*
+ CALL DESCINIT( DESCZ, DESCA( M_ ), DESCA( N_ ), DESCA( MB_ ),
+ $ DESCA( NB_ ), DESCA( RSRC_ ), DESCA( CSRC_ ),
+ $ DESCA( CTXT_ ), DESCA( LLD_ ), INFO )
+*
+ CALL BLACS_GRIDINFO( DESCA( CTXT_ ), NPROW, NPCOL, MYROW, MYCOL )
+ INDIWRK = 1 + IPREPAD + NPROW*NPCOL + 1
+*
+ IAM = 1
+ IF( MYROW.EQ.0 .AND. MYCOL.EQ.0 )
+ $ IAM = 0
+*
+* If this process is not involved in this test, bail out now
+*
+ RESULT = -3
+ IF( MYROW.GE.NPROW .OR. MYROW.LT.0 )
+ $ GO TO 150
+ RESULT = 0
+*
+ ISEED( 1 ) = 1
+*
+ CALL PZLASIZEHEEVR( WKNOWN, RANGE, N, DESCA, VL, VU, IL, IU,
+ $ ISEED, WIN, MAXSIZE, VECSIZE, VALSIZE )
+*
+ NP = NUMROC( N, DESCA( MB_ ), MYROW, 0, NPROW )
+ NQ = NUMROC( N, DESCA( NB_ ), MYCOL, 0, NPCOL )
+ MQ = NUMROC( MAXEIGS, DESCA( NB_ ), MYCOL, 0, NPCOL )
+*
+ CALL ZLACPY( 'A', NP, NQ, COPYA, DESCA( LLD_ ), A( 1+IPREPAD ),
+ $ DESCA( LLD_ ) )
+*
+ CALL PZFILLPAD( DESCA( CTXT_ ), NP, NQ, A, DESCA( LLD_ ), IPREPAD,
+ $ IPOSTPAD, ZPADVAL )
+*
+ CALL PZFILLPAD( DESCZ( CTXT_ ), NP, MQ, Z, DESCZ( LLD_ ), IPREPAD,
+ $ IPOSTPAD, ZPADVAL+1.0D0 )
+*
+* WRITE(*,*) ' NP = ', NP, ' MQ = ', MQ, ' LDZ = ', DESCZ( LLD_ ),
+* $ ' IPREPAD = ', IPREPAD, ' IPOSTPAD = ', IPOSTPAD,
+* $ ' MAXEIGS = ', MAXEIGS
+* WRITE(*,*) ' PADZ( 1 ) = ', Z( 1 ), ' PADZ( 2 ) = ', Z( 2 ),
+* $ ' PADZ( 3 ) = ', Z( 3 ), ' PADZ( 4 ) = ', Z( 4 )
+*
+ CALL PDFILLPAD( DESCA( CTXT_ ), N, 1, WNEW, N, IPREPAD, IPOSTPAD,
+ $ PADVAL+2.0D0 )
+*
+ CALL PDFILLPAD( DESCA( CTXT_ ), NPROW*NPCOL, 1, GAP, NPROW*NPCOL,
+ $ IPREPAD, IPOSTPAD, PADVAL+3.0D0 )
+*
+ CALL PDFILLPAD( DESCA( CTXT_ ), LWORK1, 1, RWORK,LWORK1, IPREPAD,
+ $ IPOSTPAD, PADVAL+4.0D0 )
+*
+ CALL PIFILLPAD( DESCA( CTXT_ ), LIWORK, 1, IWORK, LIWORK, IPREPAD,
+ $ IPOSTPAD, IPADVAL )
+*
+ CALL PIFILLPAD( DESCA( CTXT_ ), N, 1, IFAIL, N, IPREPAD, IPOSTPAD,
+ $ IPADVAL )
+*
+ CALL PIFILLPAD( DESCA( CTXT_ ), 2*NPROW*NPCOL, 1, ICLUSTR,
+ $ 2*NPROW*NPCOL, IPREPAD, IPOSTPAD, IPADVAL )
+*
+ CALL PZFILLPAD( DESCA( CTXT_ ), LWORK, 1, WORK, LWORK, IPREPAD,
+ $ IPOSTPAD, ZPADVAL+4.1D0 )
+*
+* Make sure that PZHEEVR does not cheat (i.e. use answers
+* already computed.)
+*
+ DO 60 I = 1, N, 1
+ DO 50 J = 1, MAXEIGS, 1
+ CALL PZELSET( Z( 1+IPREPAD ), I, J, DESCA,
+ $ ( 13.0D0, 1.34D0 ) )
+ 50 CONTINUE
+ 60 CONTINUE
+*
+* Reset and start the timer
+*
+ CALL SLBOOT
+ CALL SLTIMER( 1 )
+ CALL SLTIMER( 6 )
+
+*********************************
+*
+* Main call to PZHEEVR
+*
+ CALL PZHEEVR( JOBZ, RANGE, UPLO, N, A( 1+IPREPAD ), IA, JA, DESCA,
+ $ VL, VU, IL, IU, M, NZ, WNEW( 1+IPREPAD ),
+ $ Z( 1+IPREPAD ), IA, JA, DESCA,
+ $ WORK( 1+IPREPAD ), SIZEEVR,
+ $ RWORK( 1+IPREPAD ), LWORK1,
+ $ IWORK( 1+IPREPAD ), LIWORK, INFO )
+*
+*********************************
+*
+* Stop timer
+*
+ CALL SLTIMER( 6 )
+ CALL SLTIMER( 1 )
+*
+* Indicate that there are no unresolved clusters.
+* This is necessary so that the tester
+* (adapted from the one originally made for PDSYEVX)
+* works correctly.
+ ICLUSTR( 1+IPREPAD ) = 0
+*
+ IF( THRESH.LE.0 ) THEN
+ RESULT = 0
+ ELSE
+ CALL PZCHEKPAD( DESCA( CTXT_ ), 'PZHEEVR-A', NP, NQ, A,
+ $ DESCA( LLD_ ), IPREPAD, IPOSTPAD, ZPADVAL )
+*
+ CALL PZCHEKPAD( DESCZ( CTXT_ ), 'PZHEEVR-Z', NP, MQ, Z,
+ $ DESCZ( LLD_ ), IPREPAD, IPOSTPAD,
+ $ ZPADVAL+1.0D0 )
+*
+ CALL PDCHEKPAD( DESCA( CTXT_ ), 'PZHEEVR-WNEW', N, 1, WNEW, N,
+ $ IPREPAD, IPOSTPAD, PADVAL+2.0D0 )
+*
+ CALL PDCHEKPAD( DESCA( CTXT_ ), 'PZHEEVR-GAP', NPROW*NPCOL, 1,
+ $ GAP, NPROW*NPCOL, IPREPAD, IPOSTPAD,
+ $ PADVAL+3.0D0 )
+*
+ CALL PDCHEKPAD( DESCA( CTXT_ ), 'PZHEEVR-RWORK',LWORK1, 1,
+ $ RWORK, LWORK1, IPREPAD, IPOSTPAD,
+ $ PADVAL+4.0D0 )
+*
+ CALL PZCHEKPAD( DESCA( CTXT_ ), 'PZHEEVR-WORK',LWORK, 1,
+ $ WORK, LWORK, IPREPAD, IPOSTPAD,
+ $ ZPADVAL+4.1D0 )
+*
+ CALL PICHEKPAD( DESCA( CTXT_ ), 'PZHEEVR-IWORK', LIWORK, 1,
+ $ IWORK, LIWORK, IPREPAD, IPOSTPAD, IPADVAL )
+*
+ CALL PICHEKPAD( DESCA( CTXT_ ), 'PZHEEVR-IFAIL', N, 1, IFAIL,
+ $ N, IPREPAD, IPOSTPAD, IPADVAL )
+*
+ CALL PICHEKPAD( DESCA( CTXT_ ), 'PZHEEVR-ICLUSTR',
+ $ 2*NPROW*NPCOL, 1, ICLUSTR, 2*NPROW*NPCOL,
+ $ IPREPAD, IPOSTPAD, IPADVAL )
+*
+* If we now know the spectrum, we can potentially reduce MAXSIZE.
+*
+ IF( LSAME( RANGE, 'A' ) ) THEN
+ CALL PZLASIZEHEEVR( .TRUE., RANGE, N, DESCA, VL, VU, IL, IU,
+ $ ISEED, WNEW( 1+IPREPAD ), MAXSIZE,
+ $ VECSIZE, VALSIZE )
+ END IF
+*
+* Check INFO
+* Make sure that all processes return the same value of INFO
+*
+ ITMP( 1 ) = INFO
+ ITMP( 2 ) = INFO
+*
+ CALL IGAMN2D( DESCA( CTXT_ ), 'a', ' ', 1, 1, ITMP, 1, 1, 1,
+ $ -1, -1, 0 )
+ CALL IGAMX2D( DESCA( CTXT_ ), 'a', ' ', 1, 1, ITMP( 2 ), 1, 1,
+ $ 1, -1, -1, 0 )
+*
+*
+ IF( ITMP( 1 ).NE.ITMP( 2 ) ) THEN
+ IF( IAM.EQ.0 )
+ $ WRITE( NOUT, FMT = * )
+ $ 'Different processes return different INFO'
+ RESULT = 1
+ ELSE IF( MOD( INFO, 2 ).EQ.1 .OR. INFO.GT.7 .OR. INFO.LT.0 )
+ $ THEN
+ IF( IAM.EQ.0 )
+ $ WRITE( NOUT, FMT = 9999 )INFO
+ RESULT = 1
+ ELSE IF( MOD( INFO / 2, 2 ).EQ.1 .AND. LWORK1.GE.MAXSIZE ) THEN
+ IF( IAM.EQ.0 )
+ $ WRITE( NOUT, FMT = 9996 )INFO
+ RESULT = 1
+ ELSE IF( MOD( INFO / 4, 2 ).EQ.1 .AND. LWORK1.GE.VECSIZE ) THEN
+ IF( IAM.EQ.0 )
+ $ WRITE( NOUT, FMT = 9996 )INFO
+ RESULT = 1
+ END IF
+*
+ IF( LSAME( JOBZ, 'V' ) .AND. ( ICLUSTR( 1+IPREPAD ).NE.
+ $ 0 ) .AND. ( MOD( INFO / 2, 2 ).NE.1 ) ) THEN
+ IF( IAM.EQ.0 )
+ $ WRITE( NOUT, FMT = 9995 )
+ RESULT = 1
+ END IF
+*
+* Check M
+*
+ IF( ( M.LT.0 ) .OR. ( M.GT.N ) ) THEN
+ IF( IAM.EQ.0 )
+ $ WRITE( NOUT, FMT = 9994 )
+ WRITE( NOUT,*) 'M = ', M, '\n', 'N = ', N
+ RESULT = 1
+ ELSE IF( LSAME( RANGE, 'A' ) .AND. ( M.NE.N ) ) THEN
+ IF( IAM.EQ.0 )
+ $ WRITE( NOUT, FMT = 9993 )
+ RESULT = 1
+ ELSE IF( LSAME( RANGE, 'I' ) .AND. ( M.NE.IU-IL+1 ) ) THEN
+ IF( IAM.EQ.0 ) THEN
+ WRITE( NOUT, FMT = 9992 )
+ WRITE( NOUT,*) 'IL = ', IL, ' IU = ', IU, ' M = ', M
+ END IF
+ RESULT = 1
+ ELSE IF( LSAME( JOBZ, 'V' ) .AND.
+ $ ( .NOT.( LSAME( RANGE, 'V' ) ) ) .AND. ( M.NE.NZ ) )
+ $ THEN
+ IF( IAM.EQ.0 )
+ $ WRITE( NOUT, FMT = 9991 )
+ RESULT = 1
+ END IF
+*
+* Check NZ
+*
+ IF( LSAME( JOBZ, 'V' ) ) THEN
+ IF( LSAME( RANGE, 'V' ) ) THEN
+ IF( NZ.GT.M ) THEN
+ IF( IAM.EQ.0 )
+ $ WRITE( NOUT, FMT = 9990 )
+ RESULT = 1
+ END IF
+ IF( NZ.LT.M .AND. MOD( INFO / 4, 2 ).NE.1 ) THEN
+ IF( IAM.EQ.0 )
+ $ WRITE( NOUT, FMT = 9989 )
+ RESULT = 1
+ END IF
+ ELSE
+ IF( NZ.NE.M ) THEN
+ IF( IAM.EQ.0 )
+ $ WRITE( NOUT, FMT = 9988 )
+ RESULT = 1
+ END IF
+ END IF
+ END IF
+ IF( RESULT.EQ.0 ) THEN
+*
+* Make sure that all processes return the same # of eigenvalues
+*
+ ITMP( 1 ) = M
+ ITMP( 2 ) = M
+*
+ CALL IGAMN2D( DESCA( CTXT_ ), 'a', ' ', 1, 1, ITMP, 1, 1, 1,
+ $ -1, -1, 0 )
+ CALL IGAMX2D( DESCA( CTXT_ ), 'a', ' ', 1, 1, ITMP( 2 ), 1,
+ $ 1, 1, -1, -1, 0 )
+*
+ IF( ITMP( 1 ).NE.ITMP( 2 ) ) THEN
+ IF( IAM.EQ.0 )
+ $ WRITE( NOUT, FMT = 9987 )
+ RESULT = 1
+ ELSE
+*
+* Ensure that different processes return the same eigenvalues
+*
+ DO 70 I = 1, M
+ RWORK( I ) = WNEW( I+IPREPAD )
+ RWORK( I+M ) = WNEW( I+IPREPAD )
+ 70 CONTINUE
+*
+ CALL DGAMN2D( DESCA( CTXT_ ), 'a', ' ', M, 1, RWORK, M,
+ $ 1, 1, -1, -1, 0 )
+ CALL DGAMX2D( DESCA( CTXT_ ), 'a', ' ', M, 1,
+ $ RWORK( 1+M ), M, 1, 1, -1, -1, 0 )
+*
+ DO 80 I = 1, M
+ IF( RESULT.EQ.0 .AND. ( ABS( RWORK( I )-RWORK( M+
+ $ I ) ).GT.FIVE*EPS*ABS( RWORK( I ) ) ) ) THEN
+ IF( IAM.EQ.0 )
+ $ WRITE( NOUT, FMT = 9986 )
+ RESULT = 1
+ END IF
+ 80 CONTINUE
+ END IF
+ END IF
+*
+* Make sure that all processes return the same # of clusters
+*
+ IF( LSAME( JOBZ, 'V' ) ) THEN
+ NCLUSTERS = 0
+ DO 90 I = 0, NPROW*NPCOL - 1
+ IF( ICLUSTR( 1+IPREPAD+2*I ).EQ.0 )
+ $ GO TO 100
+ NCLUSTERS = NCLUSTERS + 1
+ 90 CONTINUE
+ 100 CONTINUE
+ ITMP( 1 ) = NCLUSTERS
+ ITMP( 2 ) = NCLUSTERS
+*
+ CALL IGAMN2D( DESCA( CTXT_ ), 'a', ' ', 1, 1, ITMP, 1, 1, 1,
+ $ -1, -1, 0 )
+ CALL IGAMX2D( DESCA( CTXT_ ), 'a', ' ', 1, 1, ITMP( 2 ), 1,
+ $ 1, 1, -1, -1, 0 )
+*
+ IF( ITMP( 1 ).NE.ITMP( 2 ) ) THEN
+ IF( IAM.EQ.0 )
+ $ WRITE( NOUT, FMT = 9985 )
+ RESULT = 1
+ ELSE
+*
+* Make sure that different processes return the same clusters
+*
+ DO 110 I = 1, NCLUSTERS
+ IWORK( INDIWRK+I ) = ICLUSTR( I+IPREPAD )
+ IWORK( INDIWRK+I+NCLUSTERS ) = ICLUSTR( I+IPREPAD )
+ 110 CONTINUE
+ CALL IGAMN2D( DESCA( CTXT_ ), 'a', ' ', NCLUSTERS*2+1, 1,
+ $ IWORK( INDIWRK+1 ), NCLUSTERS*2+1, 1, 1,
+ $ -1, -1, 0 )
+ CALL IGAMX2D( DESCA( CTXT_ ), 'a', ' ', NCLUSTERS*2+1, 1,
+ $ IWORK( INDIWRK+1+NCLUSTERS ),
+ $ NCLUSTERS*2+1, 1, 1, -1, -1, 0 )
+*
+ DO 120 I = 1, NCLUSTERS
+ IF( RESULT.EQ.0 .AND. IWORK( INDIWRK+I ).NE.
+ $ IWORK( INDIWRK+NCLUSTERS+I ) ) THEN
+ IF( IAM.EQ.0 )
+ $ WRITE( NOUT, FMT = 9984 )
+ RESULT = 1
+ END IF
+ 120 CONTINUE
+*
+ IF( ICLUSTR( 1+IPREPAD+NCLUSTERS*2 ).NE.0 ) THEN
+ IF( IAM.EQ.0 )
+ $ WRITE( NOUT, FMT = 9983 )
+ RESULT = 1
+ END IF
+ END IF
+ END IF
+*
+ CALL IGAMX2D( DESCA( CTXT_ ), 'a', ' ', 1, 1, RESULT, 1, 1, 1,
+ $ -1, -1, 0 )
+ IF( RESULT.NE.0 )
+ $ GO TO 150
+*
+* Compute eps * norm(A)
+*
+ IF( N.EQ.0 ) THEN
+ EPSNORMA = EPS
+ ELSE
+ EPSNORMA = PZLANHE( 'I', UPLO, N, COPYA, IA, JA, DESCA,
+ $ RWORK )*EPS
+ END IF
+*
+ IF( LSAME( JOBZ, 'V' ) ) THEN
+*
+* Perform the |A Z - Z W| test
+*
+ CALL PDFILLPAD( DESCA( CTXT_ ), SIZECHK, 1, RWORK,SIZECHK,
+ $ IPREPAD, IPOSTPAD, 4.3D0 )
+*
+ CALL PZSEPCHK( N, NZ, COPYA, IA, JA, DESCA,
+ $ MAX( ABSTOL+EPSNORMA, SAFMIN ), THRESH,
+ $ Z( 1+IPREPAD ), IA, JA, DESCZ,
+ $ A( 1+IPREPAD ), IA, JA, DESCA,
+ $ WNEW( 1+IPREPAD ), RWORK( 1+IPREPAD ),
+ $ SIZECHK, TSTNRM, RES )
+*
+ CALL PDCHEKPAD( DESCA( CTXT_ ), 'PZSEPCHK-RWORK',SIZECHK, 1,
+ $ RWORK,SIZECHK, IPREPAD, IPOSTPAD, 4.3D0 )
+*
+ IF( RES.NE.0 )
+ $ RESULT = 1
+*
+* Perform the |QTQ - I| test
+*
+ CALL PDFILLPAD( DESCA( CTXT_ ), SIZEQTQ, 1,RWORK, SIZEQTQ,
+ $ IPREPAD, IPOSTPAD, 4.3D0 )
+*
+*
+ CALL PZSEPQTQ( N, NZ, THRESH, Z( 1+IPREPAD ), IA, JA, DESCZ,
+ $ A( 1+IPREPAD ), IA, JA, DESCA,
+ $ IWORK( 1+IPREPAD+1 ), ICLUSTR( 1+IPREPAD ),
+ $ GAP( 1+IPREPAD ),RWORK( IPREPAD+1 ), SIZEQTQ,
+ $ QTQNRM, INFO, RES )
+*
+ CALL PDCHEKPAD( DESCA( CTXT_ ), 'PDSEPQTQ-RWORK',SIZEQTQ, 1,
+ $ RWORK,SIZEQTQ, IPREPAD, IPOSTPAD, 4.3D0 )
+*
+ IF( RES.NE.0 )
+ $ RESULT = 1
+*
+ IF( INFO.NE.0 ) THEN
+ IF( IAM.EQ.0 )
+ $ WRITE( NOUT, FMT = 9998 )INFO
+ RESULT = 1
+ END IF
+ END IF
+*
+* Check to make sure that the right eigenvalues have been obtained
+*
+ IF( WKNOWN ) THEN
+* Set up MYIL if necessary
+ MYIL = IL
+*
+ IF( LSAME( RANGE, 'V' ) ) THEN
+ MYIL = 1
+ MINIL = 1
+ MAXIL = N - M + 1
+ ELSE
+ IF( LSAME( RANGE, 'A' ) ) THEN
+ MYIL = 1
+ END IF
+ MINIL = MYIL
+ MAXIL = MYIL
+ END IF
+*
+* Find the largest difference between the computed
+* and expected eigenvalues
+*
+ MINERROR = NORMWIN
+*
+ DO 140 MYIL = MINIL, MAXIL
+ MAXERROR = 0
+*
+* Make sure that we aren't skipping any important eigenvalues
+*
+ MISSSMALLEST = .TRUE.
+ IF( .NOT.LSAME( RANGE, 'V' ) .OR. ( MYIL.EQ.1 ) )
+ $ MISSSMALLEST = .FALSE.
+ IF( MISSSMALLEST .AND. ( WIN( MYIL-1 ).LT.VL+NORMWIN*
+ $ FIVE*THRESH*EPS ) )MISSSMALLEST = .FALSE.
+ MISSLARGEST = .TRUE.
+ IF( .NOT.LSAME( RANGE, 'V' ) .OR. ( MYIL.EQ.MAXIL ) )
+ $ MISSLARGEST = .FALSE.
+ IF( MISSLARGEST .AND. ( WIN( MYIL+M ).GT.VU-NORMWIN*FIVE*
+ $ THRESH*EPS ) )MISSLARGEST = .FALSE.
+ IF( .NOT.MISSSMALLEST ) THEN
+ IF( .NOT.MISSLARGEST ) THEN
+*
+* Make sure that the eigenvalues that we report are OK
+*
+ DO 130 I = 1, M
+* WRITE(*,*) 'WIN WNEW = ', WIN( I+MYIL-1 ),
+* $ WNEW( I+IPREPAD )
+ ERROR = ABS( WIN( I+MYIL-1 )-WNEW( I+IPREPAD ) )
+ MAXERROR = MAX( MAXERROR, ERROR )
+ 130 CONTINUE
+*
+ MINERROR = MIN( MAXERROR, MINERROR )
+ END IF
+ END IF
+ 140 CONTINUE
+*
+* If JOBZ = 'V' and RANGE='A', we might be comparing
+* against our estimate of what the eigenvalues ought to
+* be, rather than comparing against what was computed
+* last time around, so we have to be more generous.
+*
+ IF( LSAME( JOBZ, 'V' ) .AND. LSAME( RANGE, 'A' ) ) THEN
+ IF( MINERROR.GT.NORMWIN*FIVE*FIVE*THRESH*EPS ) THEN
+ IF( IAM.EQ.0 )
+ $ WRITE( NOUT, FMT = 9997 )MINERROR, NORMWIN
+ RESULT = 1
+ END IF
+ ELSE
+ IF( MINERROR.GT.NORMWIN*FIVE*THRESH*EPS ) THEN
+ IF( IAM.EQ.0 )
+ $ WRITE( NOUT, FMT = 9997 )MINERROR, NORMWIN
+ RESULT = 1
+ END IF
+ END IF
+ END IF
+*
+* Make sure that the IL, IU, VL and VU were not altered
+*
+ IF( IL.NE.OLDIL .OR. IU.NE.OLDIU .OR. VL.NE.OLDVL .OR. VU.NE.
+ $ OLDVU ) THEN
+ IF( IAM.EQ.0 )
+ $ WRITE( NOUT, FMT = 9982 )
+ RESULT = 1
+ END IF
+*
+ IF( LSAME( JOBZ, 'N' ) .AND. ( NZ.NE.OLDNZ ) ) THEN
+ IF( IAM.EQ.0 )
+ $ WRITE( NOUT, FMT = 9981 )
+ RESULT = 1
+ END IF
+*
+ END IF
+*
+* All processes should report the same result
+*
+ CALL IGAMX2D( DESCA( CTXT_ ), 'a', ' ', 1, 1, RESULT, 1, 1, 1, -1,
+ $ -1, 0 )
+*
+ 150 CONTINUE
+*
+ RETURN
+*
+ 9999 FORMAT( 'PZHEEVR returned INFO=', I7 )
+ 9998 FORMAT( 'PZSEPQTQ returned INFO=', I7 )
+ 9997 FORMAT( 'PZSEPRSUBTST minerror =', D11.2, ' normwin=', D11.2 )
+ 9996 FORMAT( 'PZHEEVR returned INFO=', I7,
+ $ ' despite adequate workspace' )
+ 9995 FORMAT( 'ICLUSTR(1).NE.0 but mod(INFO/2,2).NE.1' )
+ 9994 FORMAT( 'M not in the range 0 to N' )
+ 9993 FORMAT( 'M not equal to N' )
+ 9992 FORMAT( 'M not equal to IU-IL+1' )
+ 9991 FORMAT( 'M not equal to NZ' )
+ 9990 FORMAT( 'NZ > M' )
+ 9989 FORMAT( 'NZ < M' )
+ 9988 FORMAT( 'NZ not equal to M' )
+ 9987 FORMAT( 'Different processes return different values for M' )
+ 9986 FORMAT( 'Different processes return different eigenvalues' )
+ 9985 FORMAT( 'Different processes return ',
+ $ 'different numbers of clusters' )
+ 9984 FORMAT( 'Different processes return different clusters' )
+ 9983 FORMAT( 'ICLUSTR not zero terminated' )
+ 9982 FORMAT( 'IL, IU, VL or VU altered by PZHEEVR' )
+ 9981 FORMAT( 'NZ altered by PZHEEVR with JOBZ=N' )
+*
+* End of PZSEPRSUBTST
+*
+ END
diff --git a/TESTING/EIG/pzseprtst.f b/TESTING/EIG/pzseprtst.f
new file mode 100644
index 0000000..cea03d6
--- /dev/null
+++ b/TESTING/EIG/pzseprtst.f
@@ -0,0 +1,823 @@
+ SUBROUTINE PZSEPRTST(DESCA, UPLO, N, MATTYPE, SUBTESTS, THRESH,
+ $ ORDER, ABSTOL, ISEED, A, COPYA, Z, LDA, WIN,
+ $ WNEW, IFAIL, ICLUSTR, GAP, IPREPAD, IPOSTPAD,
+ $ WORK, LWORK, RWORK, LRWORK,
+ $ IWORK, LIWORK, HETERO, NOUT, INFO )
+*
+* -- ScaLAPACK routine (@(MODE)version *TBA*) --
+* University of California, Berkeley and
+* University of Tennessee, Knoxville.
+* October 21, 2006
+*
+ IMPLICIT NONE
+*
+* .. Scalar Arguments ..
+ CHARACTER HETERO, SUBTESTS, UPLO
+ INTEGER INFO, IPOSTPAD, IPREPAD, LDA, LIWORK, LWORK,
+ $ MATTYPE, N, NOUT, ORDER
+ INTEGER LRWORK
+ DOUBLE PRECISION ABSTOL, THRESH
+* ..
+* .. Array Arguments ..
+ INTEGER DESCA( * ), ICLUSTR( * ), IFAIL( * ),
+ $ ISEED( 4 ), IWORK( * )
+ DOUBLE PRECISION GAP( * ), WIN( * ), WNEW( * ), RWORK( * )
+ COMPLEX*16 A( LDA, * ), COPYA( LDA, * ),
+ $ WORK( * ), Z( LDA, * )
+* ..
+*
+* Purpose
+* =======
+*
+* PZSEPRTST builds a random matrix and runs PZHEEVR to
+* compute the eigenvalues and eigenvectors. Then it performs two tests
+* to determine if the result is good enough. The two tests are:
+* |AQ -QL| / (abstol + ulp * norm(A) )
+* and
+* |QT * Q - I| / ulp * norm(A)
+*
+* The random matrix built depends upon the following parameters:
+* N, NB, ISEED, ORDER
+*
+* Arguments
+* =========
+*
+* NP = the number of rows local to a given process.
+* NQ = the number of columns local to a given process.
+*
+* DESCA (global and local input) INTEGER array of dimension DLEN_
+* The array descriptor for the distributed matrices
+*
+* UPLO (global input) CHARACTER*1
+* Specifies whether the upper or lower triangular part of the
+* matrix A is stored:
+* = 'U': Upper triangular
+* = 'L': Lower triangular
+*
+* N (global input) INTEGER
+* Size of the matrix to be tested. (global size)
+*
+* MATTYPE (global input) INTEGER
+* Matrix type
+* Currently, the list of possible types is:
+*
+* (1) The zero matrix.
+* (2) The identity matrix.
+*
+* (3) A diagonal matrix with evenly spaced entries
+* 1, ..., ULP and random signs.
+* (ULP = (first number larger than 1) - 1 )
+* (4) A diagonal matrix with geometrically spaced entries
+* 1, ..., ULP and random signs.
+* (5) A diagonal matrix with "clustered" entries 1, ULP, ..., ULP
+* and random signs.
+*
+* (6) Same as (4), but multiplied by SQRT( overflow threshold )
+* (7) Same as (4), but multiplied by SQRT( underflow threshold )
+*
+* (8) A matrix of the form U' D U, where U is orthogonal and
+* D has evenly spaced entries 1, ..., ULP with random signs
+* on the diagonal.
+*
+* (9) A matrix of the form U' D U, where U is orthogonal and
+* D has geometrically spaced entries 1, ..., ULP with random
+* signs on the diagonal.
+*
+* (10) A matrix of the form U' D U, where U is orthogonal and
+* D has "clustered" entries 1, ULP,..., ULP with random
+* signs on the diagonal.
+*
+* (11) Same as (8), but multiplied by SQRT( overflow threshold )
+* (12) Same as (8), but multiplied by SQRT( underflow threshold )
+*
+* (13) A matrix with random entries chosen from (-1,1).
+* (14) Same as (13), but multiplied by SQRT( overflow threshold )
+* (15) Same as (13), but multiplied by SQRT( underflow threshold )
+* (16) Same as (8), but diagonal elements are all positive.
+* (17) Same as (9), but diagonal elements are all positive.
+* (18) Same as (10), but diagonal elements are all positive.
+* (19) Same as (16), but multiplied by SQRT( overflow threshold )
+* (20) Same as (16), but multiplied by SQRT( underflow threshold )
+* (21) A tridiagonal matrix that is a direct sum of smaller diagonally
+* dominant submatrices. Each unreduced submatrix has geometrically
+* spaced diagonal entries 1, ..., ULP.
+* (22) A matrix of the form U' D U, where U is orthogonal and
+* D has ceil(lgN) "clusters" at 0,1,2,...,ceil(lgN)-1. The
+* size of the cluster at the value I is 2^I.
+*
+* SUBTESTS (global input) CHARACTER*1
+* 'Y' - Perform subset tests
+* 'N' - Do not perform subset tests
+*
+* THRESH (global input) DOUBLE PRECISION
+* A test will count as "failed" if the "error", computed as
+* described below, exceeds THRESH. Note that the error
+* is scaled to be O(1), so THRESH should be a reasonably
+* small multiple of 1, e.g., 10 or 100. In particular,
+* it should not depend on the precision (single vs. double)
+* or the size of the matrix. It must be at least zero.
+*
+* ORDER (global input) INTEGER
+* Number of reflectors used in test matrix creation.
+* If ORDER is large, it will
+* take more time to create the test matrices but they will
+* be closer to random.
+* ORDER .lt. N not implemented
+*
+* ABSTOL (global input) DOUBLE PRECISION
+* For the purposes of this test, ABSTOL=0.0 is fine.
+* THis test does not test for high relative accuracy.
+*
+* ISEED (global input/output) INTEGER array, dimension (4)
+* On entry, the seed of the random number generator; the array
+* elements must be between 0 and 4095, and ISEED(4) must be
+* odd.
+* On exit, the seed is updated.
+*
+* A (local workspace) COMPLEX*16 array, dim (N*N)
+* global dimension (N, N), local dimension (LDA, NQ)
+* The test matrix, which is then overwritten.
+* A is distributed in a block cyclic manner over both rows
+* and columns. The actual location of a particular element
+* in A is controlled by the values of NPROW, NPCOL, and NB.
+*
+* COPYA (local workspace) COMPLEX*16 array, dim (N, N)
+* COPYA is used to hold an identical copy of the array A
+* identical in both form and content to A
+*
+* Z (local workspace) COMPLEX*16 array, dim (N*N)
+* Z is distributed in the same manner as A
+* Z is used as workspace by the test routines
+* PZSEPCHK and PZSEPQTQ
+*
+* W (local workspace) DOUBLE PRECISION array, dimension (N)
+* On normal exit, the first M entries
+* contain the selected eigenvalues in ascending order.
+*
+* IFAIL (global workspace) INTEGER array, dimension (N)
+* Not used, only for backward compatibility
+*
+* WORK (local workspace) COMPLEX*16 array, dimension (LWORK)
+*
+* LWORK (local input) INTEGER
+* The length of the array WORK. LWORK >= SIZETST as
+* returned by PZLASIZESEPR
+*
+* RWORK (local workspace) DOUBLE PRECISION array, dimension (LRWORK)
+*
+* LRWORK (local input) INTEGER
+* The length of the array WORK. LRWORK >= RSIZETST as
+* returned by P@(CRPF)LASIZESEPR
+*
+* IWORK (local workspace) INTEGER array, dimension (LIWORK)
+*
+* LIWORK (local input) INTEGER
+* The length of the array IWORK. LIWORK >= ISIZETST as
+* returned by PZLASIZESEPR
+*
+* HETERO (input) INTEGER
+*
+* NOUT (local input) INTEGER
+* The unit number for output file. Only used on node 0.
+* NOUT = 6, output to screen,
+* NOUT = 0, output to stderr.
+* NOUT = 13, output to file, divide thresh by 10.0
+* NOUT = 14, output to file, divide thresh by 20.0
+* (This hack allows us to test more stringently internally
+* so that when errors on found on other computers they will
+* be serious enough to warrant our attention.)
+*
+* INFO (global output) INTEGER
+* -3 This process is not involved
+* 0 Test succeeded (passed |AQ -QL| and |QT*Q - I| tests)
+* 1 At least one test failed
+* 2 Residual test were not performed, thresh <= 0.0
+* 3 Test was skipped because of inadequate memory space
+*
+* .. Parameters ..
+ INTEGER CTXT_, MB_, NB_, RSRC_, CSRC_, LLD_
+ PARAMETER ( CTXT_ = 2, MB_ = 5, NB_ = 6,
+ $ RSRC_ = 7, CSRC_ = 8, LLD_ = 9 )
+ DOUBLE PRECISION HALF, ONE, TEN, ZERO
+ PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0,
+ $ TEN = 10.0D0, HALF = 0.5D0 )
+ COMPLEX*16 PADVAL
+ PARAMETER ( PADVAL = ( 19.25D0, 1.1D1 ) )
+ COMPLEX*16 ZZERO
+ PARAMETER ( ZZERO = ( 0.0D0, 0.0D0 ) )
+ COMPLEX*16 ZONE
+ PARAMETER ( ZONE = ( 1.0D0, 0.0D0 ) )
+ INTEGER MAXTYP
+ PARAMETER ( MAXTYP = 22 )
+* ..
+*
+* .. Local Scalars ..
+ LOGICAL WKNOWN
+ CHARACTER JOBZ, RANGE
+ CHARACTER*14 PASSED
+ INTEGER CONTEXT, I, IAM, IHETERO, IINFO, IL, IMODE, IN,
+ $ INDD, INDWORK, ISIZESUBTST, ISIZEEVR,
+ $ ISIZETST, ITYPE, IU, J, LLWORK, LEVRSIZE,
+ $ MAXSIZE, MYCOL, MYROW, NB, NGEN, NLOC,
+ $ NNODES, NP, NPCOL, NPROW, NQ, RES, SIZECHK,
+ $ SIZEMQRLEFT, SIZEMQRRIGHT, SIZEQRF, SIZEQTQ,
+ $ SIZESUBTST, SIZEEVR, SIZETMS,
+ $ SIZETST, VALSIZE, VECSIZE
+ INTEGER INDRWORK, LLRWORK, RSIZEEVR, RSIZESUBTST,
+ $ RSIZETST
+ DOUBLE PRECISION ANINV, ANORM, COND, MAXQTQNRM, MAXTSTNRM, OVFL,
+ $ QTQNRM, RTOVFL, RTUNFL, TEMP1, TSTNRM, ULP,
+ $ ULPINV, UNFL, VL, VU
+* ..
+* .. Local Arrays ..
+ INTEGER ISEEDIN( 4 ), KMAGN( MAXTYP ), KMODE( MAXTYP ),
+ $ KTYPE( MAXTYP )
+ DOUBLE PRECISION CTIME( 10 ), WTIME( 10 )
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ INTEGER NUMROC
+ DOUBLE PRECISION DLARAN, PDLAMCH
+ EXTERNAL DLARAN, LSAME, NUMROC, PDLAMCH
+* ..
+* .. External Subroutines ..
+ EXTERNAL BLACS_GRIDINFO, BLACS_PINFO, DLABAD, DLASRT,
+ $ IGAMX2D, IGEBR2D, IGEBS2D, PZCHEKPAD, PZELSET,
+ $ PZFILLPAD, PZLASET, PZLASIZEHEEVR,
+ $ PZLASIZESEPR, PZLATMS, PZMATGEN, PZSEPRSUBTST,
+ $ SLCOMBINE, ZLATMS
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, DBLE, INT, MAX, MIN, SQRT
+* ..
+* .. Data statements ..
+ DATA KTYPE / 1, 2, 4, 4, 4, 4, 4, 5, 5, 5, 5, 5, 8,
+ $ 8, 8, 9, 9, 9, 9, 9, 10, 11 /
+ DATA KMAGN / 1, 1, 1, 1, 1, 2, 3, 1, 1, 1, 2, 3, 1,
+ $ 2, 3, 1, 1, 1, 2, 3, 1, 1 /
+ DATA KMODE / 0, 0, 4, 3, 1, 4, 4, 4, 3, 1, 4, 4, 0,
+ $ 0, 0, 4, 3, 1, 4, 4, 3, 0 /
+* ..
+* .. Executable Statements ..
+*
+ INFO = 0
+ PASSED = 'PASSED EVR'
+ CONTEXT = DESCA( CTXT_ )
+ NB = DESCA( NB_ )
+*
+ CALL BLACS_PINFO( IAM, NNODES )
+ CALL BLACS_GRIDINFO( CONTEXT, NPROW, NPCOL, MYROW, MYCOL )
+*
+* Distribute HETERO across processes
+*
+ IF( IAM.EQ.0 ) THEN
+ IF( LSAME( HETERO, 'Y' ) ) THEN
+ IHETERO = 2
+ ELSE
+ IHETERO = 1
+ END IF
+ CALL IGEBS2D( CONTEXT, 'All', ' ', 1, 1, IHETERO, 1 )
+ ELSE
+ CALL IGEBR2D( CONTEXT, 'All', ' ', 1, 1, IHETERO, 1, 0, 0 )
+ END IF
+ IF( IHETERO.EQ.2 ) THEN
+ HETERO = 'Y'
+ ELSE
+ HETERO = 'N'
+ END IF
+*
+* Make sure that there is enough memory
+*
+ CALL PZLASIZESEPR( DESCA, IPREPAD, IPOSTPAD, SIZEMQRLEFT,
+ $ SIZEMQRRIGHT, SIZEQRF, SIZETMS, SIZEQTQ,
+ $ SIZECHK, SIZEEVR, RSIZEEVR, ISIZEEVR,
+ $ SIZESUBTST, RSIZESUBTST,
+ $ ISIZESUBTST, SIZETST, RSIZETST, ISIZETST )
+ IF( LRWORK.LT.RSIZETST ) THEN
+ INFO = 3
+ END IF
+*
+ CALL IGAMX2D( CONTEXT, 'a', ' ', 1, 1, INFO, 1, 1, 1, -1, -1, 0 )
+*
+ IF( INFO.EQ.0 ) THEN
+*
+ INDD = 1
+ INDRWORK = INDD + N
+ INDWORK = 1
+ LLWORK = LWORK - INDWORK + 1
+ LLRWORK = LRWORK - INDRWORK + 1
+*
+ ULP = PDLAMCH( CONTEXT, 'P' )
+ ULPINV = ONE / ULP
+ UNFL = PDLAMCH( CONTEXT, 'Safe min' )
+ OVFL = ONE / UNFL
+ CALL DLABAD( UNFL, OVFL )
+ RTUNFL = SQRT( UNFL )
+ RTOVFL = SQRT( OVFL )
+ ANINV = ONE / DBLE( MAX( 1, N ) )
+*
+* This ensures that everyone starts out with the same seed.
+*
+ IF( MYROW.EQ.0 .AND. MYCOL.EQ.0 ) THEN
+ CALL IGEBS2D( CONTEXT, 'a', ' ', 4, 1, ISEED, 4 )
+ ELSE
+ CALL IGEBR2D( CONTEXT, 'a', ' ', 4, 1, ISEED, 4, 0, 0 )
+ END IF
+ ISEEDIN( 1 ) = ISEED( 1 )
+ ISEEDIN( 2 ) = ISEED( 2 )
+ ISEEDIN( 3 ) = ISEED( 3 )
+ ISEEDIN( 4 ) = ISEED( 4 )
+*
+* Compute the matrix A
+*
+* Control parameters:
+*
+* KMAGN KMODE KTYPE
+* =1 O(1) clustered 1 zero
+* =2 large clustered 2 identity
+* =3 small exponential (none)
+* =4 arithmetic diagonal, (w/ eigenvalues)
+* =5 random log Hermitian, w/ eigenvalues
+* =6 random (none)
+* =7 random diagonal
+* =8 random Hermitian
+* =9 positive definite
+* =10 block diagonal with tridiagonal blocks
+* =11 Geometrically sized clusters.
+*
+ ITYPE = KTYPE( MATTYPE )
+ IMODE = KMODE( MATTYPE )
+*
+* Compute norm
+*
+ GO TO ( 10, 20, 30 )KMAGN( MATTYPE )
+*
+ 10 CONTINUE
+ ANORM = ONE
+ GO TO 40
+*
+ 20 CONTINUE
+ ANORM = ( RTOVFL*ULP )*ANINV
+ GO TO 40
+*
+ 30 CONTINUE
+ ANORM = RTUNFL*N*ULPINV
+ GO TO 40
+*
+ 40 CONTINUE
+ IF( MATTYPE.LE.15 ) THEN
+ COND = ULPINV
+ ELSE
+ COND = ULPINV*ANINV / TEN
+ END IF
+*
+* Special Matrices
+*
+ IF( ITYPE.EQ.1 ) THEN
+*
+* Zero Matrix
+*
+ DO 50 I = 1, N
+ RWORK( INDD+I-1 ) = ZERO
+ 50 CONTINUE
+ CALL PZLASET( 'All', N, N,ZZERO,ZZERO, COPYA, 1, 1, DESCA )
+ WKNOWN = .TRUE.
+*
+ ELSE IF( ITYPE.EQ.2 ) THEN
+*
+* Identity Matrix
+*
+ DO 60 I = 1, N
+ RWORK( INDD+I-1 ) = ONE
+ 60 CONTINUE
+ CALL PZLASET( 'All', N, N,ZZERO,ZONE, COPYA, 1, 1, DESCA )
+ WKNOWN = .TRUE.
+*
+ ELSE IF( ITYPE.EQ.4 ) THEN
+*
+* Diagonal Matrix, [Eigen]values Specified
+*
+ CALL PZFILLPAD( DESCA( CTXT_ ), SIZETMS, 1, WORK( INDWORK ),
+ $ SIZETMS, IPREPAD, IPOSTPAD, PADVAL+1.0D0 )
+*
+ CALL PZLATMS( N, N, 'S', ISEED, 'S',RWORK( INDD ), IMODE,
+ $ COND, ANORM, 0, 0, 'N', COPYA, 1, 1, DESCA,
+ $ ORDER, WORK( INDWORK+IPREPAD ), SIZETMS,
+ $ IINFO )
+ WKNOWN = .TRUE.
+*
+ CALL PZCHEKPAD( DESCA( CTXT_ ), 'PZLATMS1-WORK', SIZETMS, 1,
+ $ WORK( INDWORK ), SIZETMS, IPREPAD, IPOSTPAD,
+ $ PADVAL+1.0D0 )
+*
+ ELSE IF( ITYPE.EQ.5 ) THEN
+*
+* Hermitian, eigenvalues specified
+*
+ CALL PZFILLPAD( DESCA( CTXT_ ), SIZETMS, 1, WORK( INDWORK ),
+ $ SIZETMS, IPREPAD, IPOSTPAD, PADVAL+2.0D0 )
+*
+ CALL PZLATMS( N, N, 'S', ISEED, 'S',RWORK( INDD ), IMODE,
+ $ COND, ANORM, N, N, 'N', COPYA, 1, 1, DESCA,
+ $ ORDER, WORK( INDWORK+IPREPAD ), SIZETMS,
+ $ IINFO )
+*
+ CALL PZCHEKPAD( DESCA( CTXT_ ), 'PZLATMS2-WORK', SIZETMS, 1,
+ $ WORK( INDWORK ), SIZETMS, IPREPAD, IPOSTPAD,
+ $ PADVAL+2.0D0 )
+*
+ WKNOWN = .TRUE.
+*
+ ELSE IF( ITYPE.EQ.8 ) THEN
+*
+* Hermitian, random eigenvalues
+*
+ NP = NUMROC( N, DESCA( MB_ ), MYROW, 0, NPROW )
+ NQ = NUMROC( N, DESCA( NB_ ), MYCOL, 0, NPCOL )
+ CALL PZMATGEN( DESCA( CTXT_ ), 'H', 'N', N, N, DESCA( MB_ ),
+ $ DESCA( NB_ ), COPYA, DESCA( LLD_ ),
+ $ DESCA( RSRC_ ), DESCA( CSRC_ ), ISEED( 1 ),
+ $ 0, NP, 0, NQ, MYROW, MYCOL, NPROW, NPCOL )
+ INFO = 0
+ WKNOWN = .FALSE.
+*
+ ELSE IF( ITYPE.EQ.9 ) THEN
+*
+* Positive definite, eigenvalues specified.
+*
+ CALL PZFILLPAD( DESCA( CTXT_ ), SIZETMS, 1, WORK( INDWORK ),
+ $ SIZETMS, IPREPAD, IPOSTPAD, PADVAL+3.0D0 )
+*
+ CALL PZLATMS( N, N, 'S', ISEED, 'S',RWORK( INDD ), IMODE,
+ $ COND, ANORM, N, N, 'N', COPYA, 1, 1, DESCA,
+ $ ORDER, WORK( INDWORK+IPREPAD ), SIZETMS,
+ $ IINFO )
+*
+ WKNOWN = .TRUE.
+*
+ CALL PZCHEKPAD( DESCA( CTXT_ ), 'PZLATMS3-WORK', SIZETMS, 1,
+ $ WORK( INDWORK ), SIZETMS, IPREPAD, IPOSTPAD,
+ $ PADVAL+3.0D0 )
+*
+ ELSE IF( ITYPE.EQ.10 ) THEN
+*
+* Block diagonal matrix with each block being a positive
+* definite tridiagonal submatrix.
+*
+ CALL PZLASET( 'All', N, N,ZZERO,ZZERO, COPYA, 1, 1, DESCA )
+ NP = NUMROC( N, DESCA( MB_ ), 0, 0, NPROW )
+ NQ = NUMROC( N, DESCA( NB_ ), 0, 0, NPCOL )
+ NLOC = MIN( NP, NQ )
+ NGEN = 0
+ 70 CONTINUE
+*
+ IF( NGEN.LT.N ) THEN
+ IN = MIN( 1+INT( DLARAN( ISEED )*DBLE( NLOC ) ), N-NGEN )
+*
+ CALL ZLATMS( IN, IN, 'S', ISEED, 'P',RWORK( INDD ),
+ $ IMODE, COND, ANORM, 1, 1, 'N', A, LDA,
+ $ WORK( INDWORK ), IINFO )
+*
+ DO 80 I = 2, IN
+ TEMP1 = ABS( A( I-1, I ) ) /
+ $ SQRT( ABS( A( I-1, I-1 )*A( I, I ) ) )
+ IF( TEMP1.GT.HALF ) THEN
+ A( I-1, I ) = HALF*SQRT( ABS( A( I-1, I-1 )*A( I,
+ $ I ) ) )
+ A( I, I-1 ) = A( I-1, I )
+ END IF
+ 80 CONTINUE
+ CALL PZELSET( COPYA, NGEN+1, NGEN+1, DESCA, A( 1, 1 ) )
+ DO 90 I = 2, IN
+ CALL PZELSET( COPYA, NGEN+I, NGEN+I, DESCA,
+ $ A( I, I ) )
+ CALL PZELSET( COPYA, NGEN+I-1, NGEN+I, DESCA,
+ $ A( I-1, I ) )
+ CALL PZELSET( COPYA, NGEN+I, NGEN+I-1, DESCA,
+ $ A( I, I-1 ) )
+ 90 CONTINUE
+ NGEN = NGEN + IN
+ GO TO 70
+ END IF
+ WKNOWN = .FALSE.
+*
+ ELSE IF( ITYPE.EQ.11 ) THEN
+*
+* Geometrically sized clusters. Eigenvalues: 0,1,1,2,2,2,2,...
+*
+ NGEN = 0
+ J = 1
+ TEMP1 = ZERO
+ 100 CONTINUE
+ IF( NGEN.LT.N ) THEN
+ IN = MIN( J, N-NGEN )
+ DO 110 I = 0, IN - 1
+ RWORK( INDD+NGEN+I ) = TEMP1
+ 110 CONTINUE
+ TEMP1 = TEMP1 + ONE
+ J = 2*J
+ NGEN = NGEN + IN
+ GO TO 100
+ END IF
+*
+ CALL PZFILLPAD( DESCA( CTXT_ ), SIZETMS, 1, WORK( INDWORK ),
+ $ SIZETMS, IPREPAD, IPOSTPAD, PADVAL+4.0D0 )
+*
+ CALL PZLATMS( N, N, 'S', ISEED, 'S',RWORK( INDD ), IMODE,
+ $ COND, ANORM, 0, 0, 'N', COPYA, 1, 1, DESCA,
+ $ ORDER, WORK( INDWORK+IPREPAD ), SIZETMS,
+ $ IINFO )
+*
+ CALL PZCHEKPAD( DESCA( CTXT_ ), 'PZLATMS4-WORK', SIZETMS, 1,
+ $ WORK( INDWORK ), SIZETMS, IPREPAD, IPOSTPAD,
+ $ PADVAL+4.0D0 )
+*
+ ELSE
+ IINFO = 1
+ END IF
+*
+ IF( WKNOWN )
+ $ CALL DLASRT( 'I', N,RWORK( INDD ), IINFO )
+*
+ CALL PZLASIZEHEEVR( WKNOWN, 'A', N, DESCA, VL, VU, IL, IU,
+ $ ISEED,RWORK( INDD ), MAXSIZE, VECSIZE,
+ $ VALSIZE )
+ LEVRSIZE = MIN( MAXSIZE, LLRWORK )
+*
+ CALL PZSEPRSUBTST( WKNOWN, 'v', 'a', UPLO, N, VL, VU, IL, IU,
+ $ THRESH, ABSTOL, A, COPYA, Z, 1, 1, DESCA,
+ $ RWORK( INDD ), WIN, IFAIL, ICLUSTR, GAP,
+ $ IPREPAD, IPOSTPAD, WORK( INDWORK ), LLWORK,
+ $ RWORK( INDRWORK ), LLRWORK,
+ $ LEVRSIZE, IWORK, ISIZEEVR, RES, TSTNRM,
+ $ QTQNRM, NOUT )
+*
+ MAXTSTNRM = TSTNRM
+ MAXQTQNRM = QTQNRM
+*
+ IF( THRESH.LE.ZERO ) THEN
+ PASSED = 'SKIPPED '
+ INFO = 2
+ ELSE IF( RES.NE.0 ) THEN
+ PASSED = 'FAILED '
+ INFO = 1
+ END IF
+ END IF
+*
+ IF( THRESH.GT.ZERO .AND. LSAME( SUBTESTS, 'Y' ) ) THEN
+*
+* Subtest 1: JOBZ = 'N', RANGE = 'A', minimum memory
+*
+ IF( INFO.EQ.0 ) THEN
+*
+ JOBZ = 'N'
+ RANGE = 'A'
+ CALL PZLASIZEHEEVR( .TRUE., RANGE, N, DESCA, VL, VU, IL, IU,
+ $ ISEED, WIN( 1+IPREPAD ), MAXSIZE,
+ $ VECSIZE, VALSIZE )
+*
+ LEVRSIZE = VALSIZE
+*
+ CALL PZSEPRSUBTST( .TRUE., JOBZ, RANGE, UPLO, N, VL, VU, IL,
+ $ IU, THRESH, ABSTOL, A, COPYA, Z, 1, 1,
+ $ DESCA, WIN( 1+IPREPAD ), WNEW, IFAIL,
+ $ ICLUSTR, GAP, IPREPAD, IPOSTPAD,
+ $ WORK( INDWORK ), LLWORK,
+ $ RWORK, LRWORK, LEVRSIZE,
+ $ IWORK, ISIZEEVR, RES, TSTNRM, QTQNRM,
+ $ NOUT )
+*
+ IF( RES.NE.0 ) THEN
+ MAXTSTNRM = MAX( TSTNRM, MAXTSTNRM )
+ MAXQTQNRM = MAX( QTQNRM, MAXQTQNRM )
+ PASSED = 'FAILED stest 1'
+ INFO = 1
+ END IF
+ END IF
+*
+* Subtest 2: JOBZ = 'N', RANGE = 'I', minimum memory
+*
+ IF( INFO.EQ.0 ) THEN
+*
+ IL = -1
+ IU = -1
+ JOBZ = 'N'
+ RANGE = 'I'
+*
+* Use PZLASIZEHEEVR to choose IL and IU.
+*
+ CALL PZLASIZEHEEVR( .TRUE., RANGE, N, DESCA, VL, VU, IL, IU,
+ $ ISEED, WIN( 1+IPREPAD ), MAXSIZE,
+ $ VECSIZE, VALSIZE )
+*
+ LEVRSIZE = VALSIZE
+*
+ CALL PZSEPRSUBTST( .TRUE., JOBZ, RANGE, UPLO, N, VL, VU, IL,
+ $ IU, THRESH, ABSTOL, A, COPYA, Z, 1, 1,
+ $ DESCA, WIN( 1+IPREPAD ), WNEW, IFAIL,
+ $ ICLUSTR, GAP, IPREPAD, IPOSTPAD,
+ $ WORK( INDWORK ), LLWORK,
+ $ RWORK, LRWORK, LEVRSIZE,
+ $ IWORK, ISIZEEVR, RES, TSTNRM, QTQNRM,
+ $ NOUT )
+*
+ IF( RES.NE.0 ) THEN
+ MAXTSTNRM = MAX( TSTNRM, MAXTSTNRM )
+ MAXQTQNRM = MAX( QTQNRM, MAXQTQNRM )
+ PASSED = 'FAILED stest 2'
+ INFO = 1
+ END IF
+ END IF
+*
+* Subtest 3: JOBZ = 'V', RANGE = 'I', minimum memory
+*
+ IF( INFO.EQ.0 ) THEN
+ IL = -1
+ IU = -1
+ JOBZ = 'V'
+ RANGE = 'I'
+*
+* We use PZLASIZEHEEVR to choose IL and IU for us.
+*
+ CALL PZLASIZEHEEVR( .TRUE., RANGE, N, DESCA, VL, VU, IL, IU,
+ $ ISEED, WIN( 1+IPREPAD ), MAXSIZE,
+ $ VECSIZE, VALSIZE )
+*
+ LEVRSIZE = VECSIZE
+*
+ CALL PZSEPRSUBTST( .TRUE., JOBZ, RANGE, UPLO, N, VL, VU, IL,
+ $ IU, THRESH, ABSTOL, A, COPYA, Z, 1, 1,
+ $ DESCA, WIN( 1+IPREPAD ), WNEW, IFAIL,
+ $ ICLUSTR, GAP, IPREPAD, IPOSTPAD,
+ $ WORK( INDWORK ), LLWORK,
+ $ RWORK, LRWORK, LEVRSIZE,
+ $ IWORK, ISIZEEVR, RES, TSTNRM, QTQNRM,
+ $ NOUT )
+*
+ IF( RES.NE.0 ) THEN
+ MAXTSTNRM = MAX( TSTNRM, MAXTSTNRM )
+ MAXQTQNRM = MAX( QTQNRM, MAXQTQNRM )
+ PASSED = 'FAILED stest 3'
+ INFO = 1
+ END IF
+ END IF
+*
+* Subtest 4: JOBZ = 'N', RANGE = 'V', minimum memory
+*
+ IF( INFO.EQ.0 ) THEN
+ VL = ONE
+ VU = -ONE
+ JOBZ = 'N'
+ RANGE = 'V'
+*
+* We use PZLASIZEHEEVR to choose IL and IU for us.
+*
+ CALL PZLASIZEHEEVR( .TRUE., RANGE, N, DESCA, VL, VU, IL, IU,
+ $ ISEED, WIN( 1+IPREPAD ), MAXSIZE,
+ $ VECSIZE, VALSIZE )
+*
+ LEVRSIZE = VALSIZE
+*
+ CALL PZSEPRSUBTST( .TRUE., JOBZ, RANGE, UPLO, N, VL, VU, IL,
+ $ IU, THRESH, ABSTOL, A, COPYA, Z, 1, 1,
+ $ DESCA, WIN( 1+IPREPAD ), WNEW, IFAIL,
+ $ ICLUSTR, GAP, IPREPAD, IPOSTPAD,
+ $ WORK( INDWORK ), LLWORK,
+ $ RWORK, LRWORK, LEVRSIZE,
+ $ IWORK, ISIZEEVR, RES, TSTNRM, QTQNRM,
+ $ NOUT )
+*
+ IF( RES.NE.0 ) THEN
+ MAXTSTNRM = MAX( TSTNRM, MAXTSTNRM )
+ MAXQTQNRM = MAX( QTQNRM, MAXQTQNRM )
+ PASSED = 'FAILED stest 4'
+ INFO = 1
+ END IF
+ END IF
+*
+* Subtest 5: JOBZ = 'V', RANGE = 'V', minimum memory
+*
+ IF( INFO.EQ.0 ) THEN
+ VL = ONE
+ VU = -ONE
+ JOBZ = 'V'
+ RANGE = 'V'
+*
+* We use PZLASIZEHEEVR to choose VL and VU for us.
+*
+ CALL PZLASIZEHEEVR( .TRUE., RANGE, N, DESCA, VL, VU, IL, IU,
+ $ ISEED, WIN( 1+IPREPAD ), MAXSIZE,
+ $ VECSIZE, VALSIZE )
+*
+ LEVRSIZE = VECSIZE
+*
+ CALL PZSEPRSUBTST( .TRUE., JOBZ, RANGE, UPLO, N, VL, VU, IL,
+ $ IU, THRESH, ABSTOL, A, COPYA, Z, 1, 1,
+ $ DESCA, WIN( 1+IPREPAD ), WNEW, IFAIL,
+ $ ICLUSTR, GAP, IPREPAD, IPOSTPAD,
+ $ WORK( INDWORK ), LLWORK,
+ $ RWORK, LRWORK, LEVRSIZE,
+ $ IWORK, ISIZEEVR, RES, TSTNRM, QTQNRM,
+ $ NOUT )
+*
+ IF( RES.NE.0 ) THEN
+ MAXTSTNRM = MAX( TSTNRM, MAXTSTNRM )
+ MAXQTQNRM = MAX( QTQNRM, MAXQTQNRM )
+ PASSED = 'FAILED stest 5'
+ INFO = 1
+ END IF
+ END IF
+ END IF
+*
+ CALL IGAMX2D( CONTEXT, 'All', ' ', 1, 1, INFO, 1, -1, -1, -1, -1,
+ $ -1 )
+ IF( INFO.EQ.1 ) THEN
+ IF( IAM.EQ.0 .AND. .FALSE. ) THEN
+ WRITE( NOUT, FMT = 9994 )'C '
+ WRITE( NOUT, FMT = 9993 )ISEEDIN( 1 )
+ WRITE( NOUT, FMT = 9992 )ISEEDIN( 2 )
+ WRITE( NOUT, FMT = 9991 )ISEEDIN( 3 )
+ WRITE( NOUT, FMT = 9990 )ISEEDIN( 4 )
+ IF( LSAME( UPLO, 'L' ) ) THEN
+ WRITE( NOUT, FMT = 9994 )' UPLO= ''L'' '
+ ELSE
+ WRITE( NOUT, FMT = 9994 )' UPLO= ''U'' '
+ END IF
+ IF( LSAME( SUBTESTS, 'Y' ) ) THEN
+ WRITE( NOUT, FMT = 9994 )' SUBTESTS= ''Y'' '
+ ELSE
+ WRITE( NOUT, FMT = 9994 )' SUBTESTS= ''N'' '
+ END IF
+ WRITE( NOUT, FMT = 9989 )N
+ WRITE( NOUT, FMT = 9988 )NPROW
+ WRITE( NOUT, FMT = 9987 )NPCOL
+ WRITE( NOUT, FMT = 9986 )NB
+ WRITE( NOUT, FMT = 9985 )MATTYPE
+ WRITE( NOUT, FMT = 9982 )ABSTOL
+ WRITE( NOUT, FMT = 9981 )THRESH
+ WRITE( NOUT, FMT = 9994 )'C '
+ END IF
+ END IF
+*
+ CALL SLCOMBINE( CONTEXT, 'All', '>', 'W', 6, 1, WTIME )
+ CALL SLCOMBINE( CONTEXT, 'All', '>', 'C', 6, 1, CTIME )
+ IF( IAM.EQ.0 ) THEN
+ IF( INFO.EQ.0 .OR. INFO.EQ.1 ) THEN
+ IF( WTIME( 1 ).GE.0.0 ) THEN
+ WRITE( NOUT, FMT = 9999 )N, NB, NPROW, NPCOL, MATTYPE,
+ $ SUBTESTS, WTIME( 1 ), CTIME( 1 ), MAXTSTNRM,
+ $ MAXQTQNRM, PASSED
+ ELSE
+ WRITE( NOUT, FMT = 9998 )N, NB, NPROW, NPCOL, MATTYPE,
+ $ SUBTESTS, CTIME( 1 ), MAXTSTNRM, MAXQTQNRM, PASSED
+ END IF
+ ELSE IF( INFO.EQ.2 ) THEN
+ IF( WTIME( 1 ).GE.0.0 ) THEN
+ WRITE( NOUT, FMT = 9997 )N, NB, NPROW, NPCOL, MATTYPE,
+ $ SUBTESTS, WTIME( 1 ), CTIME( 1 )
+ ELSE
+ WRITE( NOUT, FMT = 9996 )N, NB, NPROW, NPCOL, MATTYPE,
+ $ SUBTESTS, CTIME( 1 )
+ END IF
+ ELSE IF( INFO.EQ.3 ) THEN
+ WRITE( NOUT, FMT = 9995 )N, NB, NPROW, NPCOL, MATTYPE,
+ $ SUBTESTS
+ END IF
+C WRITE(*,*)'************************************************'
+ END IF
+*
+
+ RETURN
+ 9999 FORMAT( 1X, I5, 1X, I3, 1X, I3, 1X, I3, 1X, I3, 3X, A1, 1X,
+ $ F8.2, 1X, F8.2, 1X, G9.2, 1X, G9.2, 1X, A14 )
+ 9998 FORMAT( 1X, I5, 1X, I3, 1X, I3, 1X, I3, 1X, I3, 3X, A1, 1X, 8X,
+ $ 1X, F8.2, 1X, G9.2, 1X, G9.2, A14 )
+ 9997 FORMAT( 1X, I5, 1X, I3, 1X, I3, 1X, I3, 1X, I3, 3X, A1, 1X, F8.2,
+ $ 1X, F8.2, 21X, 'Bypassed' )
+ 9996 FORMAT( 1X, I5, 1X, I3, 1X, I3, 1X, I3, 1X, I3, 3X, A1, 1X, 8X,
+ $ 1X, F8.2, 21X, 'Bypassed' )
+ 9995 FORMAT( 1X, I5, 1X, I3, 1X, I3, 1X, I3, 1X, I3, 3X, A1, 32X,
+ $ 'Bad MEMORY parameters' )
+ 9994 FORMAT( A )
+ 9993 FORMAT( ' ISEED( 1 ) =', I8 )
+ 9992 FORMAT( ' ISEED( 2 ) =', I8 )
+ 9991 FORMAT( ' ISEED( 3 ) =', I8 )
+ 9990 FORMAT( ' ISEED( 4 ) =', I8 )
+ 9989 FORMAT( ' N=', I8 )
+ 9988 FORMAT( ' NPROW=', I8 )
+ 9987 FORMAT( ' NPCOL=', I8 )
+ 9986 FORMAT( ' NB=', I8 )
+ 9985 FORMAT( ' MATTYPE=', I8 )
+C 9984 FORMAT( ' IBTYPE=', I8 )
+C 9983 FORMAT( ' SUBTESTS=', A1 )
+ 9982 FORMAT( ' ABSTOL=', D16.6 )
+ 9981 FORMAT( ' THRESH=', D16.6 )
+C 9980 FORMAT( ' Increase TOTMEM in PZSEPRDRIVER' )
+*
+* End of PZSEPRTST
+*
+ END
+
+
+
+
diff --git a/TESTING/EIG/pzseptst.f b/TESTING/EIG/pzseptst.f
index a0b828c..06c5970 100644
--- a/TESTING/EIG/pzseptst.f
+++ b/TESTING/EIG/pzseptst.f
@@ -537,6 +537,10 @@
$ WORK( INDWORK ), SIZETMS, IPREPAD, IPOSTPAD,
$ PADVAL+4.0D+0 )
*
+*
+* WKNOWN ... NOT SET, GUESS A DEFAULT
+*
+ WKNOWN = .TRUE.
ELSE
IINFO = 1
END IF
diff --git a/TESTING/EIG/xpjlaenv.f b/TESTING/EIG/xpjlaenv.f
index 48fbd33..de8df1a 100644
--- a/TESTING/EIG/xpjlaenv.f
+++ b/TESTING/EIG/xpjlaenv.f
@@ -464,6 +464,7 @@ c CALL EXIT( 13 )
100 CONTINUE
*
IF( GLOBAL ) THEN
+ IDUMM = 0
CALL IGAMX2D( ICTXT, 'All', ' ', 1, 1, PJLAENV, 1, IDUMM,
$ IDUMM, -1, -1, IDUMM )
END IF
diff --git a/TESTING/LIN/CMakeLists.txt b/TESTING/LIN/CMakeLists.txt
new file mode 100644
index 0000000..55a53e9
--- /dev/null
+++ b/TESTING/LIN/CMakeLists.txt
@@ -0,0 +1,112 @@
+set(CMAKE_RUNTIME_OUTPUT_DIRECTORY ${SCALAPACK_BINARY_DIR}/TESTING)
+
+set (smatgen psmatgen.f pmatgeninc.f)
+set (dmatgen pdmatgen.f pmatgeninc.f)
+set (cmatgen pcmatgen.f pmatgeninc.f)
+set (zmatgen pzmatgen.f pmatgeninc.f)
+
+set (slinchk pslaschk.f pslafchk.f)
+set (dlinchk pdlaschk.f pdlafchk.f)
+set (clinchk pclaschk.f pclafchk.f)
+set (zlinchk pzlaschk.f pzlafchk.f)
+
+add_executable(xslu psludriver.f psluinfo.f psgetrrv.f ${smatgen} ${slinchk})
+add_executable(xdlu pdludriver.f pdluinfo.f pdgetrrv.f ${dmatgen} ${dlinchk})
+add_executable(xclu pcludriver.f pcluinfo.f pcgetrrv.f ${cmatgen} ${clinchk})
+add_executable(xzlu pzludriver.f pzluinfo.f pzgetrrv.f ${zmatgen} ${zlinchk})
+
+add_executable(xsdblu psdbdriver.f psdbinfo.f psdblaschk.f psdbmv1.f psbmatgen.f ${smatgen})
+add_executable(xddblu pddbdriver.f pddbinfo.f pddblaschk.f pddbmv1.f pdbmatgen.f ${dmatgen})
+add_executable(xcdblu pcdbdriver.f pcdbinfo.f pcdblaschk.f pcdbmv1.f pcbmatgen.f ${cmatgen})
+add_executable(xzdblu pzdbdriver.f pzdbinfo.f pzdblaschk.f pzdbmv1.f pzbmatgen.f ${zmatgen})
+
+add_executable(xsdtlu psdtdriver.f psdtinfo.f psdtlaschk.f psdbmv1.f psbmatgen.f ${smatgen})
+add_executable(xddtlu pddtdriver.f pddtinfo.f pddtlaschk.f pddbmv1.f pdbmatgen.f ${dmatgen})
+add_executable(xcdtlu pcdtdriver.f pcdtinfo.f pcdtlaschk.f pcdbmv1.f pcbmatgen.f ${cmatgen})
+add_executable(xzdtlu pzdtdriver.f pzdtinfo.f pzdtlaschk.f pzdbmv1.f pzbmatgen.f ${zmatgen})
+
+add_executable(xsgblu psgbdriver.f psgbinfo.f psdblaschk.f psgbmv1.f psbmatgen.f ${smatgen})
+add_executable(xdgblu pdgbdriver.f pdgbinfo.f pddblaschk.f pdgbmv1.f pdbmatgen.f ${dmatgen})
+add_executable(xcgblu pcgbdriver.f pcgbinfo.f pcdblaschk.f pcgbmv1.f pcbmatgen.f ${cmatgen})
+add_executable(xzgblu pzgbdriver.f pzgbinfo.f pzdblaschk.f pzgbmv1.f pzbmatgen.f ${zmatgen})
+
+add_executable(xsllt pslltdriver.f pslltinfo.f pspotrrv.f ${smatgen} ${slinchk})
+add_executable(xdllt pdlltdriver.f pdlltinfo.f pdpotrrv.f ${dmatgen} ${dlinchk})
+add_executable(xcllt pclltdriver.f pclltinfo.f pcpotrrv.f ${cmatgen} ${clinchk})
+add_executable(xzllt pzlltdriver.f pzlltinfo.f pzpotrrv.f ${zmatgen} ${zlinchk})
+
+add_executable(xspbllt pspbdriver.f pspbinfo.f pspblaschk.f pspbmv1.f psbmatgen.f ${smatgen})
+add_executable(xdpbllt pdpbdriver.f pdpbinfo.f pdpblaschk.f pdpbmv1.f pdbmatgen.f ${dmatgen})
+add_executable(xcpbllt pcpbdriver.f pcpbinfo.f pcpblaschk.f pcpbmv1.f pcbmatgen.f ${cmatgen})
+add_executable(xzpbllt pzpbdriver.f pzpbinfo.f pzpblaschk.f pzpbmv1.f pzbmatgen.f ${zmatgen})
+
+add_executable(xsptllt psptdriver.f psptinfo.f psptlaschk.f pspbmv1.f psbmatgen.f ${smatgen})
+add_executable(xdptllt pdptdriver.f pdptinfo.f pdptlaschk.f pdpbmv1.f pdbmatgen.f ${dmatgen})
+add_executable(xcptllt pcptdriver.f pcptinfo.f pcptlaschk.f pcpbmv1.f pcbmatgen.f ${cmatgen})
+add_executable(xzptllt pzptdriver.f pzptinfo.f pzptlaschk.f pzpbmv1.f pzbmatgen.f ${zmatgen})
+
+add_executable(xsinv psinvdriver.f psinvinfo.f psinvchk.f ${smatgen})
+add_executable(xdinv pdinvdriver.f pdinvinfo.f pdinvchk.f ${dmatgen})
+add_executable(xcinv pcinvdriver.f pcinvinfo.f pcinvchk.f ${cmatgen})
+add_executable(xzinv pzinvdriver.f pzinvinfo.f pzinvchk.f ${zmatgen})
+
+add_executable(xsqr psqrdriver.f psqrinfo.f psgeqrrv.f psgeqlrv.f psgelqrv.f psgerqrv.f pstzrzrv.f pslafchk.f ${smatgen})
+add_executable(xdqr pdqrdriver.f pdqrinfo.f pdgeqrrv.f pdgeqlrv.f pdgelqrv.f pdgerqrv.f pdtzrzrv.f pdlafchk.f ${dmatgen})
+add_executable(xcqr pcqrdriver.f pcqrinfo.f pcgeqrrv.f pcgeqlrv.f pcgelqrv.f pcgerqrv.f pctzrzrv.f pclafchk.f ${cmatgen})
+add_executable(xzqr pzqrdriver.f pzqrinfo.f pzgeqrrv.f pzgeqlrv.f pzgelqrv.f pzgerqrv.f pztzrzrv.f pzlafchk.f ${zmatgen})
+
+add_executable(xsls pslsdriver.f pslsinfo.f psqrt13.f psqrt14.f psqrt16.f psqrt17.f ${smatgen})
+add_executable(xdls pdlsdriver.f pdlsinfo.f pdqrt13.f pdqrt14.f pdqrt16.f pdqrt17.f ${dmatgen})
+add_executable(xcls pclsdriver.f pclsinfo.f pcqrt13.f pcqrt14.f pcqrt16.f pcqrt17.f ${cmatgen})
+add_executable(xzls pzlsdriver.f pzlsinfo.f pzqrt13.f pzqrt14.f pzqrt16.f pzqrt17.f ${zmatgen})
+
+
+target_link_libraries(xslu scalapack ${LAPACK_LIBRARIES} ${BLAS_LIBRARIES})
+target_link_libraries(xdlu scalapack ${LAPACK_LIBRARIES} ${BLAS_LIBRARIES})
+target_link_libraries(xclu scalapack ${LAPACK_LIBRARIES} ${BLAS_LIBRARIES})
+target_link_libraries(xzlu scalapack ${LAPACK_LIBRARIES} ${BLAS_LIBRARIES})
+
+target_link_libraries(xsdblu scalapack ${LAPACK_LIBRARIES} ${BLAS_LIBRARIES})
+target_link_libraries(xddblu scalapack ${LAPACK_LIBRARIES} ${BLAS_LIBRARIES})
+target_link_libraries(xcdblu scalapack ${LAPACK_LIBRARIES} ${BLAS_LIBRARIES})
+target_link_libraries(xzdblu scalapack ${LAPACK_LIBRARIES} ${BLAS_LIBRARIES})
+
+target_link_libraries(xsdtlu scalapack ${LAPACK_LIBRARIES} ${BLAS_LIBRARIES})
+target_link_libraries(xddtlu scalapack ${LAPACK_LIBRARIES} ${BLAS_LIBRARIES})
+target_link_libraries(xcdtlu scalapack ${LAPACK_LIBRARIES} ${BLAS_LIBRARIES})
+target_link_libraries(xzdtlu scalapack ${LAPACK_LIBRARIES} ${BLAS_LIBRARIES})
+
+target_link_libraries(xsgblu scalapack ${LAPACK_LIBRARIES} ${BLAS_LIBRARIES})
+target_link_libraries(xdgblu scalapack ${LAPACK_LIBRARIES} ${BLAS_LIBRARIES})
+target_link_libraries(xcgblu scalapack ${LAPACK_LIBRARIES} ${BLAS_LIBRARIES})
+target_link_libraries(xzgblu scalapack ${LAPACK_LIBRARIES} ${BLAS_LIBRARIES})
+
+target_link_libraries(xsllt scalapack ${LAPACK_LIBRARIES} ${BLAS_LIBRARIES})
+target_link_libraries(xdllt scalapack ${LAPACK_LIBRARIES} ${BLAS_LIBRARIES})
+target_link_libraries(xcllt scalapack ${LAPACK_LIBRARIES} ${BLAS_LIBRARIES})
+target_link_libraries(xzllt scalapack ${LAPACK_LIBRARIES} ${BLAS_LIBRARIES})
+
+target_link_libraries(xspbllt scalapack ${LAPACK_LIBRARIES} ${BLAS_LIBRARIES})
+target_link_libraries(xdpbllt scalapack ${LAPACK_LIBRARIES} ${BLAS_LIBRARIES})
+target_link_libraries(xcpbllt scalapack ${LAPACK_LIBRARIES} ${BLAS_LIBRARIES})
+target_link_libraries(xzpbllt scalapack ${LAPACK_LIBRARIES} ${BLAS_LIBRARIES})
+
+target_link_libraries(xsptllt scalapack ${LAPACK_LIBRARIES} ${BLAS_LIBRARIES})
+target_link_libraries(xdptllt scalapack ${LAPACK_LIBRARIES} ${BLAS_LIBRARIES})
+target_link_libraries(xcptllt scalapack ${LAPACK_LIBRARIES} ${BLAS_LIBRARIES})
+target_link_libraries(xzptllt scalapack ${LAPACK_LIBRARIES} ${BLAS_LIBRARIES})
+
+target_link_libraries(xsinv scalapack ${LAPACK_LIBRARIES} ${BLAS_LIBRARIES})
+target_link_libraries(xdinv scalapack ${LAPACK_LIBRARIES} ${BLAS_LIBRARIES})
+target_link_libraries(xcinv scalapack ${LAPACK_LIBRARIES} ${BLAS_LIBRARIES})
+target_link_libraries(xzinv scalapack ${LAPACK_LIBRARIES} ${BLAS_LIBRARIES})
+
+target_link_libraries(xsqr scalapack ${LAPACK_LIBRARIES} ${BLAS_LIBRARIES})
+target_link_libraries(xdqr scalapack ${LAPACK_LIBRARIES} ${BLAS_LIBRARIES})
+target_link_libraries(xcqr scalapack ${LAPACK_LIBRARIES} ${BLAS_LIBRARIES})
+target_link_libraries(xzqr scalapack ${LAPACK_LIBRARIES} ${BLAS_LIBRARIES})
+
+target_link_libraries(xsls scalapack ${LAPACK_LIBRARIES} ${BLAS_LIBRARIES})
+target_link_libraries(xdls scalapack ${LAPACK_LIBRARIES} ${BLAS_LIBRARIES})
+target_link_libraries(xcls scalapack ${LAPACK_LIBRARIES} ${BLAS_LIBRARIES})
+target_link_libraries(xzls scalapack ${LAPACK_LIBRARIES} ${BLAS_LIBRARIES})
diff --git a/TESTING/LIN/Makefile b/TESTING/LIN/Makefile
index 192797d..3fac023 100644
--- a/TESTING/LIN/Makefile
+++ b/TESTING/LIN/Makefile
@@ -16,55 +16,55 @@
include ../../SLmake.inc
-sluexe = $(TESTINGdir)/xslu
-dluexe = $(TESTINGdir)/xdlu
-cluexe = $(TESTINGdir)/xclu
-zluexe = $(TESTINGdir)/xzlu
-
-sdbluexe = $(TESTINGdir)/xsdblu
-ddbluexe = $(TESTINGdir)/xddblu
-cdbluexe = $(TESTINGdir)/xcdblu
-zdbluexe = $(TESTINGdir)/xzdblu
-
-sdtluexe = $(TESTINGdir)/xsdtlu
-ddtluexe = $(TESTINGdir)/xddtlu
-cdtluexe = $(TESTINGdir)/xcdtlu
-zdtluexe = $(TESTINGdir)/xzdtlu
-
-sgbluexe = $(TESTINGdir)/xsgblu
-dgbluexe = $(TESTINGdir)/xdgblu
-cgbluexe = $(TESTINGdir)/xcgblu
-zgbluexe = $(TESTINGdir)/xzgblu
-
-slltexe = $(TESTINGdir)/xsllt
-dlltexe = $(TESTINGdir)/xdllt
-clltexe = $(TESTINGdir)/xcllt
-zlltexe = $(TESTINGdir)/xzllt
-
-spblltexe = $(TESTINGdir)/xspbllt
-dpblltexe = $(TESTINGdir)/xdpbllt
-cpblltexe = $(TESTINGdir)/xcpbllt
-zpblltexe = $(TESTINGdir)/xzpbllt
-
-sptlltexe = $(TESTINGdir)/xsptllt
-dptlltexe = $(TESTINGdir)/xdptllt
-cptlltexe = $(TESTINGdir)/xcptllt
-zptlltexe = $(TESTINGdir)/xzptllt
-
-sinvexe = $(TESTINGdir)/xsinv
-dinvexe = $(TESTINGdir)/xdinv
-cinvexe = $(TESTINGdir)/xcinv
-zinvexe = $(TESTINGdir)/xzinv
-
-sqrexe = $(TESTINGdir)/xsqr
-dqrexe = $(TESTINGdir)/xdqr
-cqrexe = $(TESTINGdir)/xcqr
-zqrexe = $(TESTINGdir)/xzqr
-
-slsexe = $(TESTINGdir)/xsls
-dlsexe = $(TESTINGdir)/xdls
-clsexe = $(TESTINGdir)/xcls
-zlsexe = $(TESTINGdir)/xzls
+sluexe = ../xslu
+dluexe = ../xdlu
+cluexe = ../xclu
+zluexe = ../xzlu
+
+sdbluexe = ../xsdblu
+ddbluexe = ../xddblu
+cdbluexe = ../xcdblu
+zdbluexe = ../xzdblu
+
+sdtluexe = ../xsdtlu
+ddtluexe = ../xddtlu
+cdtluexe = ../xcdtlu
+zdtluexe = ../xzdtlu
+
+sgbluexe = ../xsgblu
+dgbluexe = ../xdgblu
+cgbluexe = ../xcgblu
+zgbluexe = ../xzgblu
+
+slltexe = ../xsllt
+dlltexe = ../xdllt
+clltexe = ../xcllt
+zlltexe = ../xzllt
+
+spblltexe = ../xspbllt
+dpblltexe = ../xdpbllt
+cpblltexe = ../xcpbllt
+zpblltexe = ../xzpbllt
+
+sptlltexe = ../xsptllt
+dptlltexe = ../xdptllt
+cptlltexe = ../xcptllt
+zptlltexe = ../xzptllt
+
+sinvexe = ../xsinv
+dinvexe = ../xdinv
+cinvexe = ../xcinv
+zinvexe = ../xzinv
+
+sqrexe = ../xsqr
+dqrexe = ../xdqr
+cqrexe = ../xcqr
+zqrexe = ../xzqr
+
+slsexe = ../xsls
+dlsexe = ../xdls
+clsexe = ../xcls
+zlsexe = ../xzls
smatgen = psmatgen.o pmatgeninc.o
dmatgen = pdmatgen.o pmatgeninc.o
@@ -149,298 +149,217 @@ complex: $(cluexe) $(cdbluexe) $(cdtluexe) $(cgbluexe) $(clltexe) \
complex16: $(zluexe) $(zdbluexe) $(zdtluexe) $(zgbluexe) $(zlltexe) \
$(zpblltexe) $(zptlltexe) $(zinvexe) $(zqrexe) $(zlsexe)
-$(TESTINGdir)/LU.dat: ../LU.dat
- cp ../LU.dat $(TESTINGdir)
-
-$(sluexe): $(SCALAPACKLIB) $(slu)
- $(F77LOADER) $(F77LOADFLAGS) -o $(sluexe) $(slu) $(LIBS)
- $(MAKE) $(TESTINGdir)/LU.dat
-$(dluexe): $(SCALAPACKLIB) $(dlu)
- $(F77LOADER) $(F77LOADFLAGS) -o $(dluexe) $(dlu) $(LIBS)
- $(MAKE) $(TESTINGdir)/LU.dat
-$(cluexe): $(SCALAPACKLIB) $(clu)
- $(F77LOADER) $(F77LOADFLAGS) -o $(cluexe) $(clu) $(LIBS)
- $(MAKE) $(TESTINGdir)/LU.dat
-$(zluexe): $(SCALAPACKLIB) $(zlu)
- $(F77LOADER) $(F77LOADFLAGS) -o $(zluexe) $(zlu) $(LIBS)
- $(MAKE) $(TESTINGdir)/LU.dat
-
-$(TESTINGdir)/BLU.dat: ../BLU.dat
- cp ../BLU.dat $(TESTINGdir)
-
-$(sdbluexe): $(SCALAPACKLIB) $(sdblu)
- $(F77LOADER) $(F77LOADFLAGS) -o $(sdbluexe) $(sdblu) $(LIBS)
- $(MAKE) $(TESTINGdir)/BLU.dat
-$(ddbluexe): $(SCALAPACKLIB) $(ddblu)
- $(F77LOADER) $(F77LOADFLAGS) -o $(ddbluexe) $(ddblu) $(LIBS)
- $(MAKE) $(TESTINGdir)/BLU.dat
-$(cdbluexe): $(SCALAPACKLIB) $(cdblu)
- $(F77LOADER) $(F77LOADFLAGS) -o $(cdbluexe) $(cdblu) $(LIBS)
- $(MAKE) $(TESTINGdir)/BLU.dat
-$(zdbluexe): $(SCALAPACKLIB) $(zdblu)
- $(F77LOADER) $(F77LOADFLAGS) -o $(zdbluexe) $(zdblu) $(LIBS)
- $(MAKE) $(TESTINGdir)/BLU.dat
-
-$(sdtluexe): $(SCALAPACKLIB) $(sdtlu)
- $(F77LOADER) $(F77LOADFLAGS) -o $(sdtluexe) $(sdtlu) $(LIBS)
- $(MAKE) $(TESTINGdir)/BLU.dat
-$(ddtluexe): $(SCALAPACKLIB) $(ddtlu)
- $(F77LOADER) $(F77LOADFLAGS) -o $(ddtluexe) $(ddtlu) $(LIBS)
- $(MAKE) $(TESTINGdir)/BLU.dat
-$(cdtluexe): $(SCALAPACKLIB) $(cdtlu)
- $(F77LOADER) $(F77LOADFLAGS) -o $(cdtluexe) $(cdtlu) $(LIBS)
- $(MAKE) $(TESTINGdir)/BLU.dat
-$(zdtluexe): $(SCALAPACKLIB) $(zdtlu)
- $(F77LOADER) $(F77LOADFLAGS) -o $(zdtluexe) $(zdtlu) $(LIBS)
- $(MAKE) $(TESTINGdir)/BLU.dat
-
-$(sgbluexe): $(SCALAPACKLIB) $(sgblu)
- $(F77LOADER) $(F77LOADFLAGS) -o $(sgbluexe) $(sgblu) $(LIBS)
- $(MAKE) $(TESTINGdir)/BLU.dat
-$(dgbluexe): $(SCALAPACKLIB) $(dgblu)
- $(F77LOADER) $(F77LOADFLAGS) -o $(dgbluexe) $(dgblu) $(LIBS)
- $(MAKE) $(TESTINGdir)/BLU.dat
-$(cgbluexe): $(SCALAPACKLIB) $(cgblu)
- $(F77LOADER) $(F77LOADFLAGS) -o $(cgbluexe) $(cgblu) $(LIBS)
- $(MAKE) $(TESTINGdir)/BLU.dat
-$(zgbluexe): $(SCALAPACKLIB) $(zgblu)
- $(F77LOADER) $(F77LOADFLAGS) -o $(zgbluexe) $(zgblu) $(LIBS)
- $(MAKE) $(TESTINGdir)/BLU.dat
-
-
-$(TESTINGdir)/LLT.dat: ../LLT.dat
- cp ../LLT.dat $(TESTINGdir)
-
-$(slltexe): $(SCALAPACKLIB) $(sllt)
- $(F77LOADER) $(F77LOADFLAGS) -o $(slltexe) $(sllt) $(LIBS)
- $(MAKE) $(TESTINGdir)/LLT.dat
-$(dlltexe): $(SCALAPACKLIB) $(dllt)
- $(F77LOADER) $(F77LOADFLAGS) -o $(dlltexe) $(dllt) $(LIBS)
- $(MAKE) $(TESTINGdir)/LLT.dat
-$(clltexe): $(SCALAPACKLIB) $(cllt)
- $(F77LOADER) $(F77LOADFLAGS) -o $(clltexe) $(cllt) $(LIBS)
- $(MAKE) $(TESTINGdir)/LLT.dat
-$(zlltexe): $(SCALAPACKLIB) $(zllt)
- $(F77LOADER) $(F77LOADFLAGS) -o $(zlltexe) $(zllt) $(LIBS)
- $(MAKE) $(TESTINGdir)/LLT.dat
-
-$(TESTINGdir)/BLLT.dat: ../BLLT.dat
- cp ../BLLT.dat $(TESTINGdir)
-
-$(spblltexe): $(SCALAPACKLIB) $(spbllt)
- $(F77LOADER) $(F77LOADFLAGS) -o $(spblltexe) $(spbllt) $(LIBS)
- $(MAKE) $(TESTINGdir)/BLLT.dat
-$(dpblltexe): $(SCALAPACKLIB) $(dpbllt)
- $(F77LOADER) $(F77LOADFLAGS) -o $(dpblltexe) $(dpbllt) $(LIBS)
- $(MAKE) $(TESTINGdir)/BLLT.dat
-$(cpblltexe): $(SCALAPACKLIB) $(cpbllt)
- $(F77LOADER) $(F77LOADFLAGS) -o $(cpblltexe) $(cpbllt) $(LIBS)
- $(MAKE) $(TESTINGdir)/BLLT.dat
-$(zpblltexe): $(SCALAPACKLIB) $(zpbllt)
- $(F77LOADER) $(F77LOADFLAGS) -o $(zpblltexe) $(zpbllt) $(LIBS)
- $(MAKE) $(TESTINGdir)/BLLT.dat
-
-$(sptlltexe): $(SCALAPACKLIB) $(sptllt)
- $(F77LOADER) $(F77LOADFLAGS) -o $(sptlltexe) $(sptllt) $(LIBS)
- $(MAKE) $(TESTINGdir)/BLLT.dat
-$(dptlltexe): $(SCALAPACKLIB) $(dptllt)
- $(F77LOADER) $(F77LOADFLAGS) -o $(dptlltexe) $(dptllt) $(LIBS)
- $(MAKE) $(TESTINGdir)/BLLT.dat
-$(cptlltexe): $(SCALAPACKLIB) $(cptllt)
- $(F77LOADER) $(F77LOADFLAGS) -o $(cptlltexe) $(cptllt) $(LIBS)
- $(MAKE) $(TESTINGdir)/BLLT.dat
-$(zptlltexe): $(SCALAPACKLIB) $(zptllt)
- $(F77LOADER) $(F77LOADFLAGS) -o $(zptlltexe) $(zptllt) $(LIBS)
- $(MAKE) $(TESTINGdir)/BLLT.dat
-
-$(TESTINGdir)/INV.dat: ../INV.dat
- cp ../INV.dat $(TESTINGdir)
-
-$(sinvexe): $(SCALAPACKLIB) $(sinv)
- $(F77LOADER) $(F77LOADFLAGS) -o $(sinvexe) $(sinv) $(LIBS)
- $(MAKE) $(TESTINGdir)/INV.dat
-$(dinvexe): $(SCALAPACKLIB) $(dinv)
- $(F77LOADER) $(F77LOADFLAGS) -o $(dinvexe) $(dinv) $(LIBS)
- $(MAKE) $(TESTINGdir)/INV.dat
-$(cinvexe): $(SCALAPACKLIB) $(cinv)
- $(F77LOADER) $(F77LOADFLAGS) -o $(cinvexe) $(cinv) $(LIBS)
- $(MAKE) $(TESTINGdir)/INV.dat
-$(zinvexe): $(SCALAPACKLIB) $(zinv)
- $(F77LOADER) $(F77LOADFLAGS) -o $(zinvexe) $(zinv) $(LIBS)
- $(MAKE) $(TESTINGdir)/INV.dat
-
-$(TESTINGdir)/QR.dat: ../QR.dat
- cp ../QR.dat $(TESTINGdir)
-
-$(sqrexe): $(SCALAPACKLIB) $(sqr)
- $(F77LOADER) $(F77LOADFLAGS) -o $(sqrexe) $(sqr) $(LIBS)
- $(MAKE) $(TESTINGdir)/QR.dat
-$(dqrexe): $(SCALAPACKLIB) $(dqr)
- $(F77LOADER) $(F77LOADFLAGS) -o $(dqrexe) $(dqr) $(LIBS)
- $(MAKE) $(TESTINGdir)/QR.dat
-$(cqrexe): $(SCALAPACKLIB) $(cqr)
- $(F77LOADER) $(F77LOADFLAGS) -o $(cqrexe) $(cqr) $(LIBS)
- $(MAKE) $(TESTINGdir)/QR.dat
-$(zqrexe): $(SCALAPACKLIB) $(zqr)
- $(F77LOADER) $(F77LOADFLAGS) -o $(zqrexe) $(zqr) $(LIBS)
- $(MAKE) $(TESTINGdir)/QR.dat
-
-$(TESTINGdir)/LS.dat: ../LS.dat
- cp ../LS.dat $(TESTINGdir)
-
-$(slsexe): $(SCALAPACKLIB) $(sls)
- $(F77LOADER) $(F77LOADFLAGS) -o $(slsexe) $(sls) $(LIBS)
- $(MAKE) $(TESTINGdir)/LS.dat
-$(dlsexe): $(SCALAPACKLIB) $(dls)
- $(F77LOADER) $(F77LOADFLAGS) -o $(dlsexe) $(dls) $(LIBS)
- $(MAKE) $(TESTINGdir)/LS.dat
-$(clsexe): $(SCALAPACKLIB) $(cls)
- $(F77LOADER) $(F77LOADFLAGS) -o $(clsexe) $(cls) $(LIBS)
- $(MAKE) $(TESTINGdir)/LS.dat
-$(zlsexe): $(SCALAPACKLIB) $(zls)
- $(F77LOADER) $(F77LOADFLAGS) -o $(zlsexe) $(zls) $(LIBS)
- $(MAKE) $(TESTINGdir)/LS.dat
-
-$(slu): $(FRC)
-$(dlu): $(FRC)
-$(clu): $(FRC)
-$(zlu): $(FRC)
-
-$(sdblu): $(FRC)
-$(ddblu): $(FRC)
-$(cdblu): $(FRC)
-$(zdblu): $(FRC)
-
-$(sdtlu): $(FRC)
-$(ddtlu): $(FRC)
-$(cdtlu): $(FRC)
-$(zdtlu): $(FRC)
-
-
-$(sllt): $(FRC)
-$(dllt): $(FRC)
-$(cllt): $(FRC)
-$(zllt): $(FRC)
-
-$(spbllt): $(FRC)
-$(dpbllt): $(FRC)
-$(cpbllt): $(FRC)
-$(zpbllt): $(FRC)
-
-$(sptllt): $(FRC)
-$(dptllt): $(FRC)
-$(cptllt): $(FRC)
-$(zptllt): $(FRC)
-
-$(sinv): $(FRC)
-$(dinv): $(FRC)
-$(cinv): $(FRC)
-$(zinv): $(FRC)
-
-$(sqr): $(FRC)
-$(dqr): $(FRC)
-$(cqr): $(FRC)
-$(zqr): $(FRC)
-
-$(sls): $(FRC)
-$(dls): $(FRC)
-$(cls): $(FRC)
-$(zls): $(FRC)
-
-FRC:
- @FRC=$(FRC)
+$(sluexe): ../../$(SCALAPACKLIB) $(slu)
+ $(FCLOADER) $(FCLOADFLAGS) -o $(sluexe) $(slu) ../../$(SCALAPACKLIB) $(LIBS)
+
+$(dluexe): ../../$(SCALAPACKLIB) $(dlu)
+ $(FCLOADER) $(FCLOADFLAGS) -o $(dluexe) $(dlu) ../../$(SCALAPACKLIB) $(LIBS)
+
+$(cluexe): ../../$(SCALAPACKLIB) $(clu)
+ $(FCLOADER) $(FCLOADFLAGS) -o $(cluexe) $(clu) ../../$(SCALAPACKLIB) $(LIBS)
+
+$(zluexe): ../../$(SCALAPACKLIB) $(zlu)
+ $(FCLOADER) $(FCLOADFLAGS) -o $(zluexe) $(zlu) ../../$(SCALAPACKLIB) $(LIBS)
+
+$(sdbluexe): ../../$(SCALAPACKLIB) $(sdblu)
+ $(FCLOADER) $(FCLOADFLAGS) -o $(sdbluexe) $(sdblu) ../../$(SCALAPACKLIB) $(LIBS)
+
+$(ddbluexe): ../../$(SCALAPACKLIB) $(ddblu)
+ $(FCLOADER) $(FCLOADFLAGS) -o $(ddbluexe) $(ddblu) ../../$(SCALAPACKLIB) $(LIBS)
+
+$(cdbluexe): ../../$(SCALAPACKLIB) $(cdblu)
+ $(FCLOADER) $(FCLOADFLAGS) -o $(cdbluexe) $(cdblu) ../../$(SCALAPACKLIB) $(LIBS)
+
+$(zdbluexe): ../../$(SCALAPACKLIB) $(zdblu)
+ $(FCLOADER) $(FCLOADFLAGS) -o $(zdbluexe) $(zdblu) ../../$(SCALAPACKLIB) $(LIBS)
+
+$(sdtluexe): ../../$(SCALAPACKLIB) $(sdtlu)
+ $(FCLOADER) $(FCLOADFLAGS) -o $(sdtluexe) $(sdtlu) ../../$(SCALAPACKLIB) $(LIBS)
+
+$(ddtluexe): ../../$(SCALAPACKLIB) $(ddtlu)
+ $(FCLOADER) $(FCLOADFLAGS) -o $(ddtluexe) $(ddtlu) ../../$(SCALAPACKLIB) $(LIBS)
+
+$(cdtluexe): ../../$(SCALAPACKLIB) $(cdtlu)
+ $(FCLOADER) $(FCLOADFLAGS) -o $(cdtluexe) $(cdtlu) ../../$(SCALAPACKLIB) $(LIBS)
+
+$(zdtluexe): ../../$(SCALAPACKLIB) $(zdtlu)
+ $(FCLOADER) $(FCLOADFLAGS) -o $(zdtluexe) $(zdtlu) ../../$(SCALAPACKLIB) $(LIBS)
+
+$(sgbluexe): ../../$(SCALAPACKLIB) $(sgblu)
+ $(FCLOADER) $(FCLOADFLAGS) -o $(sgbluexe) $(sgblu) ../../$(SCALAPACKLIB) $(LIBS)
+
+$(dgbluexe): ../../$(SCALAPACKLIB) $(dgblu)
+ $(FCLOADER) $(FCLOADFLAGS) -o $(dgbluexe) $(dgblu) ../../$(SCALAPACKLIB) $(LIBS)
+
+$(cgbluexe): ../../$(SCALAPACKLIB) $(cgblu)
+ $(FCLOADER) $(FCLOADFLAGS) -o $(cgbluexe) $(cgblu) ../../$(SCALAPACKLIB) $(LIBS)
+
+$(zgbluexe): ../../$(SCALAPACKLIB) $(zgblu)
+ $(FCLOADER) $(FCLOADFLAGS) -o $(zgbluexe) $(zgblu) ../../$(SCALAPACKLIB) $(LIBS)
+
+$(slltexe): ../../$(SCALAPACKLIB) $(sllt)
+ $(FCLOADER) $(FCLOADFLAGS) -o $(slltexe) $(sllt) ../../$(SCALAPACKLIB) $(LIBS)
+
+$(dlltexe): ../../$(SCALAPACKLIB) $(dllt)
+ $(FCLOADER) $(FCLOADFLAGS) -o $(dlltexe) $(dllt) ../../$(SCALAPACKLIB) $(LIBS)
+
+$(clltexe): ../../$(SCALAPACKLIB) $(cllt)
+ $(FCLOADER) $(FCLOADFLAGS) -o $(clltexe) $(cllt) ../../$(SCALAPACKLIB) $(LIBS)
+
+$(zlltexe): ../../$(SCALAPACKLIB) $(zllt)
+ $(FCLOADER) $(FCLOADFLAGS) -o $(zlltexe) $(zllt) ../../$(SCALAPACKLIB) $(LIBS)
+
+$(spblltexe): ../../$(SCALAPACKLIB) $(spbllt)
+ $(FCLOADER) $(FCLOADFLAGS) -o $(spblltexe) $(spbllt) ../../$(SCALAPACKLIB) $(LIBS)
+
+$(dpblltexe): ../../$(SCALAPACKLIB) $(dpbllt)
+ $(FCLOADER) $(FCLOADFLAGS) -o $(dpblltexe) $(dpbllt) ../../$(SCALAPACKLIB) $(LIBS)
+
+$(cpblltexe): ../../$(SCALAPACKLIB) $(cpbllt)
+ $(FCLOADER) $(FCLOADFLAGS) -o $(cpblltexe) $(cpbllt) ../../$(SCALAPACKLIB) $(LIBS)
+
+$(zpblltexe): ../../$(SCALAPACKLIB) $(zpbllt)
+ $(FCLOADER) $(FCLOADFLAGS) -o $(zpblltexe) $(zpbllt) ../../$(SCALAPACKLIB) $(LIBS)
+
+$(sptlltexe): ../../$(SCALAPACKLIB) $(sptllt)
+ $(FCLOADER) $(FCLOADFLAGS) -o $(sptlltexe) $(sptllt) ../../$(SCALAPACKLIB) $(LIBS)
+
+$(dptlltexe): ../../$(SCALAPACKLIB) $(dptllt)
+ $(FCLOADER) $(FCLOADFLAGS) -o $(dptlltexe) $(dptllt) ../../$(SCALAPACKLIB) $(LIBS)
+
+$(cptlltexe): ../../$(SCALAPACKLIB) $(cptllt)
+ $(FCLOADER) $(FCLOADFLAGS) -o $(cptlltexe) $(cptllt) ../../$(SCALAPACKLIB) $(LIBS)
+
+$(zptlltexe): ../../$(SCALAPACKLIB) $(zptllt)
+ $(FCLOADER) $(FCLOADFLAGS) -o $(zptlltexe) $(zptllt) ../../$(SCALAPACKLIB) $(LIBS)
+
+$(sinvexe): ../../$(SCALAPACKLIB) $(sinv)
+ $(FCLOADER) $(FCLOADFLAGS) -o $(sinvexe) $(sinv) ../../$(SCALAPACKLIB) $(LIBS)
+
+$(dinvexe): ../../$(SCALAPACKLIB) $(dinv)
+ $(FCLOADER) $(FCLOADFLAGS) -o $(dinvexe) $(dinv) ../../$(SCALAPACKLIB) $(LIBS)
+
+$(cinvexe): ../../$(SCALAPACKLIB) $(cinv)
+ $(FCLOADER) $(FCLOADFLAGS) -o $(cinvexe) $(cinv) ../../$(SCALAPACKLIB) $(LIBS)
+
+$(zinvexe): ../../$(SCALAPACKLIB) $(zinv)
+ $(FCLOADER) $(FCLOADFLAGS) -o $(zinvexe) $(zinv) ../../$(SCALAPACKLIB) $(LIBS)
+
+$(sqrexe): ../../$(SCALAPACKLIB) $(sqr)
+ $(FCLOADER) $(FCLOADFLAGS) -o $(sqrexe) $(sqr) ../../$(SCALAPACKLIB) $(LIBS)
+
+$(dqrexe): ../../$(SCALAPACKLIB) $(dqr)
+ $(FCLOADER) $(FCLOADFLAGS) -o $(dqrexe) $(dqr) ../../$(SCALAPACKLIB) $(LIBS)
+
+$(cqrexe): ../../$(SCALAPACKLIB) $(cqr)
+ $(FCLOADER) $(FCLOADFLAGS) -o $(cqrexe) $(cqr) ../../$(SCALAPACKLIB) $(LIBS)
+
+$(zqrexe): ../../$(SCALAPACKLIB) $(zqr)
+ $(FCLOADER) $(FCLOADFLAGS) -o $(zqrexe) $(zqr) ../../$(SCALAPACKLIB) $(LIBS)
+
+$(slsexe): ../../$(SCALAPACKLIB) $(sls)
+ $(FCLOADER) $(FCLOADFLAGS) -o $(slsexe) $(sls) ../../$(SCALAPACKLIB) $(LIBS)
+
+$(dlsexe): ../../$(SCALAPACKLIB) $(dls)
+ $(FCLOADER) $(FCLOADFLAGS) -o $(dlsexe) $(dls) ../../$(SCALAPACKLIB) $(LIBS)
+
+$(clsexe): ../../$(SCALAPACKLIB) $(cls)
+ $(FCLOADER) $(FCLOADFLAGS) -o $(clsexe) $(cls) ../../$(SCALAPACKLIB) $(LIBS)
+
+$(zlsexe): ../../$(SCALAPACKLIB) $(zls)
+ $(FCLOADER) $(FCLOADFLAGS) -o $(zlsexe) $(zls) ../../$(SCALAPACKLIB) $(LIBS)
clean :
rm -f *.o
psludriver.o: psludriver.f
- $(F77) $(DRVOPTS) -c $<
+ $(FC) $(FCFLAGS) -c $<
pdludriver.o: pdludriver.f
- $(F77) $(DRVOPTS) -c $<
+ $(FC) $(FCFLAGS) -c $<
pcludriver.o: pcludriver.f
- $(F77) $(DRVOPTS) -c $<
+ $(FC) $(FCFLAGS) -c $<
pzludriver.o: pzludriver.f
- $(F77) $(DRVOPTS) -c $<
+ $(FC) $(FCFLAGS) -c $<
psdbdriver.o: psdbdriver.f
- $(F77) $(DRVOPTS) -c $<
+ $(FC) $(FCFLAGS) -c $<
pddbdriver.o: pddbdriver.f
- $(F77) $(DRVOPTS) -c $<
+ $(FC) $(FCFLAGS) -c $<
pcdbdriver.o: pcdbdriver.f
- $(F77) $(DRVOPTS) -c $<
+ $(FC) $(FCFLAGS) -c $<
pzdbdriver.o: pzdbdriver.f
- $(F77) $(DRVOPTS) -c $<
+ $(FC) $(FCFLAGS) -c $<
psdtdriver.o: psdtdriver.f
- $(F77) $(DRVOPTS) -c $<
+ $(FC) $(FCFLAGS) -c $<
pddtdriver.o: pddtdriver.f
- $(F77) $(DRVOPTS) -c $<
+ $(FC) $(FCFLAGS) -c $<
pcdtdriver.o: pcdtdriver.f
- $(F77) $(DRVOPTS) -c $<
+ $(FC) $(FCFLAGS) -c $<
pzdtdriver.o: pzdtdriver.f
- $(F77) $(DRVOPTS) -c $<
+ $(FC) $(FCFLAGS) -c $<
psgbdriver.o: psgbdriver.f
- $(F77) $(DRVOPTS) -c $<
+ $(FC) $(FCFLAGS) -c $<
pdgbdriver.o: pdgbdriver.f
- $(F77) $(DRVOPTS) -c $<
+ $(FC) $(FCFLAGS) -c $<
pcgbdriver.o: pcgbdriver.f
- $(F77) $(DRVOPTS) -c $<
+ $(FC) $(FCFLAGS) -c $<
pzgbdriver.o: pzgbdriver.f
- $(F77) $(DRVOPTS) -c $<
+ $(FC) $(FCFLAGS) -c $<
pslltdriver.o: pslltdriver.f
- $(F77) $(DRVOPTS) -c $<
+ $(FC) $(FCFLAGS) -c $<
pdlltdriver.o: pdlltdriver.f
- $(F77) $(DRVOPTS) -c $<
+ $(FC) $(FCFLAGS) -c $<
pclltdriver.o: pclltdriver.f
- $(F77) $(DRVOPTS) -c $<
+ $(FC) $(FCFLAGS) -c $<
pzlltdriver.o: pzlltdriver.f
- $(F77) $(DRVOPTS) -c $<
+ $(FC) $(FCFLAGS) -c $<
pspbdriver.o: pspbdriver.f
- $(F77) $(DRVOPTS) -c $<
+ $(FC) $(FCFLAGS) -c $<
pdpbdriver.o: pdpbdriver.f
- $(F77) $(DRVOPTS) -c $<
+ $(FC) $(FCFLAGS) -c $<
pcpbdriver.o: pcpbdriver.f
- $(F77) $(DRVOPTS) -c $<
+ $(FC) $(FCFLAGS) -c $<
pzpbdriver.o: pzpbdriver.f
- $(F77) $(DRVOPTS) -c $<
+ $(FC) $(FCFLAGS) -c $<
psptdriver.o: psptdriver.f
- $(F77) $(DRVOPTS) -c $<
+ $(FC) $(FCFLAGS) -c $<
pdptdriver.o: pdptdriver.f
- $(F77) $(DRVOPTS) -c $<
+ $(FC) $(FCFLAGS) -c $<
pcptdriver.o: pcptdriver.f
- $(F77) $(DRVOPTS) -c $<
+ $(FC) $(FCFLAGS) -c $<
pzptdriver.o: pzptdriver.f
- $(F77) $(DRVOPTS) -c $<
+ $(FC) $(FCFLAGS) -c $<
psinvdriver.o: psinvdriver.f
- $(F77) $(DRVOPTS) -c $<
+ $(FC) $(FCFLAGS) -c $<
pdinvdriver.o: pdinvdriver.f
- $(F77) $(DRVOPTS) -c $<
+ $(FC) $(FCFLAGS) -c $<
pcinvdriver.o: pcinvdriver.f
- $(F77) $(DRVOPTS) -c $<
+ $(FC) $(FCFLAGS) -c $<
pzinvdriver.o: pzinvdriver.f
- $(F77) $(DRVOPTS) -c $<
+ $(FC) $(FCFLAGS) -c $<
psqrdriver.o: psqrdriver.f
- $(F77) $(DRVOPTS) -c $<
+ $(FC) $(FCFLAGS) -c $<
pdqrdriver.o: pdqrdriver.f
- $(F77) $(DRVOPTS) -c $<
+ $(FC) $(FCFLAGS) -c $<
pcqrdriver.o: pcqrdriver.f
- $(F77) $(DRVOPTS) -c $<
+ $(FC) $(FCFLAGS) -c $<
pzqrdriver.o: pzqrdriver.f
- $(F77) $(DRVOPTS) -c $<
+ $(FC) $(FCFLAGS) -c $<
pslsdriver.o: pslsdriver.f
- $(F77) $(DRVOPTS) -c $<
+ $(FC) $(FCFLAGS) -c $<
pdlsdriver.o: pdlsdriver.f
- $(F77) $(DRVOPTS) -c $<
+ $(FC) $(FCFLAGS) -c $<
pclsdriver.o: pclsdriver.f
- $(F77) $(DRVOPTS) -c $<
+ $(FC) $(FCFLAGS) -c $<
pzlsdriver.o: pzlsdriver.f
- $(F77) $(DRVOPTS) -c $<
+ $(FC) $(FCFLAGS) -c $<
-.f.o : ; $(F77) -c $(F77FLAGS) $*.f
+.f.o : ; $(FC) -c $(FCFLAGS) $*.f
diff --git a/TESTING/LIN/pcdbmv1.f b/TESTING/LIN/pcdbmv1.f
index aedc3ed..0cc192e 100644
--- a/TESTING/LIN/pcdbmv1.f
+++ b/TESTING/LIN/pcdbmv1.f
@@ -349,7 +349,7 @@
INTEGER PARAM_CHECK( 17, 3 )
* ..
* .. External Subroutines ..
- EXTERNAL BLACS_GRIDINFO, PXERBLA
+ EXTERNAL BLACS_GRIDINFO, PXERBLA, RESHAPE
* ..
* .. External Functions ..
LOGICAL LSAME
diff --git a/TESTING/LIN/pcgbmv1.f b/TESTING/LIN/pcgbmv1.f
index aedc3ed..0cc192e 100644
--- a/TESTING/LIN/pcgbmv1.f
+++ b/TESTING/LIN/pcgbmv1.f
@@ -349,7 +349,7 @@
INTEGER PARAM_CHECK( 17, 3 )
* ..
* .. External Subroutines ..
- EXTERNAL BLACS_GRIDINFO, PXERBLA
+ EXTERNAL BLACS_GRIDINFO, PXERBLA, RESHAPE
* ..
* .. External Functions ..
LOGICAL LSAME
diff --git a/TESTING/LIN/pcludriver.f b/TESTING/LIN/pcludriver.f
index 99b5106..eda1ea4 100644
--- a/TESTING/LIN/pcludriver.f
+++ b/TESTING/LIN/pcludriver.f
@@ -76,7 +76,7 @@
REAL ZERO
COMPLEX PADVAL
PARAMETER ( CPLXSZ = 8, INTGSZ = 4, REALSZ = 4,
- $ TOTMEM = 2000000,
+ $ TOTMEM = 4000000,
$ MEMSIZ = TOTMEM / CPLXSZ, NTESTS = 20,
$ PADVAL = ( -9923.0E+0, -9923.0E+0 ),
$ ZERO = 0.0E+0 )
diff --git a/TESTING/LIN/pcpbmv1.f b/TESTING/LIN/pcpbmv1.f
index 49106d1..3a5fa35 100644
--- a/TESTING/LIN/pcpbmv1.f
+++ b/TESTING/LIN/pcpbmv1.f
@@ -345,7 +345,7 @@
INTEGER PARAM_CHECK( 16, 3 )
* ..
* .. External Subroutines ..
- EXTERNAL BLACS_GRIDINFO, PXERBLA
+ EXTERNAL BLACS_GRIDINFO, PXERBLA, RESHAPE
* ..
* .. External Functions ..
LOGICAL LSAME
diff --git a/TESTING/LIN/pcqrt16.f b/TESTING/LIN/pcqrt16.f
index ddd4685..b7d120c 100644
--- a/TESTING/LIN/pcqrt16.f
+++ b/TESTING/LIN/pcqrt16.f
@@ -255,6 +255,7 @@
*
TEMP( 1 ) = BNORM
TEMP( 2 ) = XNORM
+ IDUMM = 0
CALL SGAMX2D( ICTXT, 'All', ' ', 2, 1, TEMP, 2, IDUMM, IDUMM,
$ -1, -1, IDUMM )
BNORM = TEMP( 1 )
diff --git a/TESTING/LIN/pddbmv1.f b/TESTING/LIN/pddbmv1.f
index d206fb0..ad7377c 100644
--- a/TESTING/LIN/pddbmv1.f
+++ b/TESTING/LIN/pddbmv1.f
@@ -346,7 +346,7 @@
INTEGER PARAM_CHECK( 17, 3 )
* ..
* .. External Subroutines ..
- EXTERNAL BLACS_GRIDINFO, PXERBLA
+ EXTERNAL BLACS_GRIDINFO, PXERBLA, RESHAPE
* ..
* .. External Functions ..
LOGICAL LSAME
diff --git a/TESTING/LIN/pdgbmv1.f b/TESTING/LIN/pdgbmv1.f
index d206fb0..ad7377c 100644
--- a/TESTING/LIN/pdgbmv1.f
+++ b/TESTING/LIN/pdgbmv1.f
@@ -346,7 +346,7 @@
INTEGER PARAM_CHECK( 17, 3 )
* ..
* .. External Subroutines ..
- EXTERNAL BLACS_GRIDINFO, PXERBLA
+ EXTERNAL BLACS_GRIDINFO, PXERBLA, RESHAPE
* ..
* .. External Functions ..
LOGICAL LSAME
diff --git a/TESTING/LIN/pdludriver.f b/TESTING/LIN/pdludriver.f
index 6bb4082..5d016ef 100644
--- a/TESTING/LIN/pdludriver.f
+++ b/TESTING/LIN/pdludriver.f
@@ -73,7 +73,7 @@
$ RSRC_ = 7, CSRC_ = 8, LLD_ = 9 )
INTEGER DBLESZ, INTGSZ, MEMSIZ, NTESTS, TOTMEM
DOUBLE PRECISION PADVAL, ZERO
- PARAMETER ( DBLESZ = 8, INTGSZ = 4, TOTMEM = 2000000,
+ PARAMETER ( DBLESZ = 8, INTGSZ = 4, TOTMEM = 4000000,
$ MEMSIZ = TOTMEM / DBLESZ, NTESTS = 20,
$ PADVAL = -9923.0D+0, ZERO = 0.0D+0 )
* ..
diff --git a/TESTING/LIN/pdpbmv1.f b/TESTING/LIN/pdpbmv1.f
index 9c53e49..9824dd6 100644
--- a/TESTING/LIN/pdpbmv1.f
+++ b/TESTING/LIN/pdpbmv1.f
@@ -342,7 +342,7 @@
INTEGER PARAM_CHECK( 16, 3 )
* ..
* .. External Subroutines ..
- EXTERNAL BLACS_GRIDINFO, PXERBLA
+ EXTERNAL BLACS_GRIDINFO, PXERBLA, RESHAPE
* ..
* .. External Functions ..
LOGICAL LSAME
diff --git a/TESTING/LIN/pdqrt16.f b/TESTING/LIN/pdqrt16.f
index 74a0042..fd688d0 100644
--- a/TESTING/LIN/pdqrt16.f
+++ b/TESTING/LIN/pdqrt16.f
@@ -251,6 +251,7 @@
*
TEMP( 1 ) = BNORM
TEMP( 2 ) = XNORM
+ IDUMM = 0
CALL DGAMX2D( ICTXT, 'All', ' ', 2, 1, TEMP, 2, IDUMM, IDUMM,
$ -1, -1, IDUMM )
BNORM = TEMP( 1 )
diff --git a/TESTING/LIN/psdbmv1.f b/TESTING/LIN/psdbmv1.f
index 30d2883..b8d35eb 100644
--- a/TESTING/LIN/psdbmv1.f
+++ b/TESTING/LIN/psdbmv1.f
@@ -346,7 +346,7 @@
INTEGER PARAM_CHECK( 17, 3 )
* ..
* .. External Subroutines ..
- EXTERNAL BLACS_GRIDINFO, PXERBLA
+ EXTERNAL BLACS_GRIDINFO, PXERBLA, RESHAPE
* ..
* .. External Functions ..
LOGICAL LSAME
diff --git a/TESTING/LIN/psgbmv1.f b/TESTING/LIN/psgbmv1.f
index 30d2883..b8d35eb 100644
--- a/TESTING/LIN/psgbmv1.f
+++ b/TESTING/LIN/psgbmv1.f
@@ -346,7 +346,7 @@
INTEGER PARAM_CHECK( 17, 3 )
* ..
* .. External Subroutines ..
- EXTERNAL BLACS_GRIDINFO, PXERBLA
+ EXTERNAL BLACS_GRIDINFO, PXERBLA, RESHAPE
* ..
* .. External Functions ..
LOGICAL LSAME
diff --git a/TESTING/LIN/pspbmv1.f b/TESTING/LIN/pspbmv1.f
index 917d55b..44a5c2a 100644
--- a/TESTING/LIN/pspbmv1.f
+++ b/TESTING/LIN/pspbmv1.f
@@ -342,7 +342,7 @@
INTEGER PARAM_CHECK( 16, 3 )
* ..
* .. External Subroutines ..
- EXTERNAL BLACS_GRIDINFO, PXERBLA
+ EXTERNAL BLACS_GRIDINFO, PXERBLA, RESHAPE
* ..
* .. External Functions ..
LOGICAL LSAME
diff --git a/TESTING/LIN/psqrt16.f b/TESTING/LIN/psqrt16.f
index c6cd4ae..9b2dac5 100644
--- a/TESTING/LIN/psqrt16.f
+++ b/TESTING/LIN/psqrt16.f
@@ -251,6 +251,7 @@
*
TEMP( 1 ) = BNORM
TEMP( 2 ) = XNORM
+ IDUMM = 0
CALL SGAMX2D( ICTXT, 'All', ' ', 2, 1, TEMP, 2, IDUMM, IDUMM,
$ -1, -1, IDUMM )
BNORM = TEMP( 1 )
diff --git a/TESTING/LIN/pzdbmv1.f b/TESTING/LIN/pzdbmv1.f
index 3fafaaa..d05b70d 100644
--- a/TESTING/LIN/pzdbmv1.f
+++ b/TESTING/LIN/pzdbmv1.f
@@ -349,7 +349,7 @@
INTEGER PARAM_CHECK( 17, 3 )
* ..
* .. External Subroutines ..
- EXTERNAL BLACS_GRIDINFO, PXERBLA
+ EXTERNAL BLACS_GRIDINFO, PXERBLA, RESHAPE
* ..
* .. External Functions ..
LOGICAL LSAME
diff --git a/TESTING/LIN/pzgbmv1.f b/TESTING/LIN/pzgbmv1.f
index 3fafaaa..d05b70d 100644
--- a/TESTING/LIN/pzgbmv1.f
+++ b/TESTING/LIN/pzgbmv1.f
@@ -349,7 +349,7 @@
INTEGER PARAM_CHECK( 17, 3 )
* ..
* .. External Subroutines ..
- EXTERNAL BLACS_GRIDINFO, PXERBLA
+ EXTERNAL BLACS_GRIDINFO, PXERBLA, RESHAPE
* ..
* .. External Functions ..
LOGICAL LSAME
diff --git a/TESTING/LIN/pzludriver.f b/TESTING/LIN/pzludriver.f
index 65773ea..2df8fe2 100644
--- a/TESTING/LIN/pzludriver.f
+++ b/TESTING/LIN/pzludriver.f
@@ -75,7 +75,7 @@
INTEGER INTGSZ, DBLESZ, MEMSIZ, NTESTS, TOTMEM, ZPLXSZ
DOUBLE PRECISION ZERO
COMPLEX*16 PADVAL
- PARAMETER ( INTGSZ = 4, DBLESZ = 8, TOTMEM = 2000000,
+ PARAMETER ( INTGSZ = 4, DBLESZ = 8, TOTMEM = 8000000,
$ ZPLXSZ = 16, MEMSIZ = TOTMEM / ZPLXSZ,
$ NTESTS = 20,
$ PADVAL = ( -9923.0D+0, -9923.0D+0 ),
diff --git a/TESTING/LIN/pzpbmv1.f b/TESTING/LIN/pzpbmv1.f
index 2e6f681..39be4af 100644
--- a/TESTING/LIN/pzpbmv1.f
+++ b/TESTING/LIN/pzpbmv1.f
@@ -345,7 +345,7 @@
INTEGER PARAM_CHECK( 16, 3 )
* ..
* .. External Subroutines ..
- EXTERNAL BLACS_GRIDINFO, PXERBLA
+ EXTERNAL BLACS_GRIDINFO, PXERBLA, RESHAPE
* ..
* .. External Functions ..
LOGICAL LSAME
diff --git a/TESTING/LIN/pzqrt16.f b/TESTING/LIN/pzqrt16.f
index 66e1e48..88fad1e 100644
--- a/TESTING/LIN/pzqrt16.f
+++ b/TESTING/LIN/pzqrt16.f
@@ -255,6 +255,7 @@
*
TEMP( 1 ) = BNORM
TEMP( 2 ) = XNORM
+ IDUMM = 0
CALL DGAMX2D( ICTXT, 'All', ' ', 2, 1, TEMP, 2, IDUMM, IDUMM,
$ -1, -1, IDUMM )
BNORM = TEMP( 1 )
diff --git a/TESTING/QR.dat b/TESTING/QR.dat
index b2249db..b39c988 100644
--- a/TESTING/QR.dat
+++ b/TESTING/QR.dat
@@ -13,4 +13,4 @@
4 number of process grids (ordered pairs P & Q)
1 2 1 4 2 3 8 values of P
1 2 4 1 3 2 1 values of Q
-3.0 threshold
+5.0 threshold
diff --git a/TESTING/SEPR.dat b/TESTING/SEPR.dat
new file mode 100644
index 0000000..eba0634
--- /dev/null
+++ b/TESTING/SEPR.dat
@@ -0,0 +1,161 @@
+
+
+'ScaLAPACK Symmetric Eigensolver Test File'
+' '
+'sepr.out' output file name (if any)
+6 device out (13 & 14 reserved for internal testing)
+4 maximum number of processes
+'Y' Switch set to 'Y'
+' '
+'TEST 1 - test tiny matrices - different process configurations'
+3 number of matrices
+0 1 2 Matrix sizes
+1 number of uplo choices
+'L' uplo choices
+1 number of processor configurations (P, Q, NB)
+1 values of P (NPROW)
+2 values of Q (NPCOL)
+1 values of NB
+1 number of matrix types
+8 matrix types (see pdseprtst.f)
+'N' perform subset tests?
+80.0 Threshold (* 5 for generalized tests)
+-1 Absolute Tolerance
+' '
+'TEST 2 - test tiny matrices - all requests'
+2 number of matrices
+0 1 Matrix sizes
+1 number of uplo choices
+'L' uplo choices
+1 number of processor configurations (P, Q, NB)
+1 values of P (NPROW)
+2 values of Q (NPCOL)
+1 values of NB
+1 number of matrix types
+8 matrix types (see pdseprtst.f)
+'Y' perform subset tests?
+80.0 Threshold (* 5 for generalized tests)
+-1 Absolute Tolerance
+' '
+'TEST 3 - test a small matrix - all types'
+1 number of matrices
+5 Matrix sizes
+1 number of uplo choices
+'L' uplo choices
+3 number of processor configurations (P, Q, NB)
+1 1 1 values of P (NPROW)
+1 2 2 values of Q (NPCOL)
+1 1 2 values of NB
+22 number of matrix types
+1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22
+'N' perform subset tests?
+250.0 Threshold
+-1 Absolute Tolerance
+' '
+'TEST 4 - test a small matrix - all requests'
+1 number of matrices
+4 Matrix sizes
+1 number of uplo choices
+'L' uplo choices
+3 number of processor configurations (P, Q, NB)
+1 1 1 values of P (NPROW)
+1 2 2 values of Q (NPCOL)
+1 1 2 values of NB
+2 number of matrix types
+10 22 matrix types
+'Y' perform subset tests?
+250.0 Threshold
+-1 Absolute Tolerance
+' '
+'TEST 5 - test a small matrix - all processor configurations'
+1 number of matrices
+6 matrix size
+2 number of uplo choices
+'L' 'U' uplo choices
+13 number of processor configurations (P, Q, NB)
+1 1 2 1 2 1 3 1 3 1 2 2 2 values of P (NPROW)
+1 1 1 2 1 2 1 3 1 3 2 2 2 values of Q (NPCOL)
+1 3 1 1 2 2 1 1 2 2 1 2 3 values of NB
+1 number of matrix types
+8 matrix types (see pdseprtst.f)
+'N' perform subset tests?
+100.0 Threshold (* 5 for generalized tests)
+-1 Absolute Tolerance
+' '
+'TEST 6 - test a medium matrix - hard matrix types'
+1 number of matrices
+21 Matrix sizes
+1 number of uplo choices
+'U' uplo choices
+1 number of processor configurations (P, Q, NB)
+2 values of P (NPROW)
+2 values of Q (NPCOL)
+8 values of NB
+4 number of matrix types
+9 10 21 22
+'N' perform subset tests?
+100.0 Threshold (* 5 for generalized tests)
+-1 Absolute Tolerance
+' '
+'TEST 7 - test a medium matrix - all processor configurations'
+1 number of matrices
+27
+1 number of uplo choices
+'U' uplo choices
+13 number of processor configurations (P, Q, NB)
+1 1 2 1 2 1 3 1 3 1 2 2 2 values of P (NPROW)
+1 1 1 2 1 2 1 3 1 3 2 2 2 values of Q (NPCOL)
+1 3 1 1 2 2 1 1 2 2 1 2 3 values of NB
+1 number of matrix types
+10 matrix types (see pdseprtst.f)
+'N' perform subset tests?
+50.0 Threshold (* 5 for generalized tests)
+-1 Absolute Tolerance
+' '
+'TEST 8 - test a medium matrix - L and U'
+1 number of matrices
+24 Matrix sizes
+2 number of uplo choices
+'L' 'U' uplo choices
+4 number of processor configurations (P, Q, NB)
+1 1 3 1 values of P (NPROW)
+1 2 1 4 values of Q (NPCOL)
+1 3 1 1 values of NB
+1 number of matrix types
+22 matrix types (see pdseprtst.f)
+'N' perform subset tests?
+20.0 Threshold (* 5 for generalized tests)
+-1 Absolute Tolerance
+' '
+'TEST 9 - test one larger matrix'
+1 number of matrices
+100 Matrix sizes
+1 number of uplo choices
+'U' uplo choices
+1 number of processor configurations (P, Q, NB)
+2 values of P (NPROW)
+2 values of Q (NPCOL)
+8 values of NB
+1 number of matrix types
+8 matrix types (see pdseprtst.f)
+'Y' perform subset tests?
+150.0 Threshold (* 5 for generalized tests)
+-1 Absolute Tolerance
+' '
+'TEST 10 - test one large matrix'
+1 number of matrices
+500 Matrix sizes
+1 number of uplo choices
+'U' uplo choices
+7 number of processor configurations (P, Q, NB)
+1 2 1 2 2 1 4 values of P (NPROW)
+1 1 2 2 2 4 1 values of Q (NPCOL)
+1 1 1 1 2 4 4 values of NB
+1 number of matrix types
+8 matrix types (see pdseprtst.f)
+'Y' perform subset tests?
+250.0 Threshold (* 5 for generalized tests)
+-1 Absolute Tolerance
+' '
+'End of tests'
+-1
diff --git a/TOOLS/CMakeLists.txt b/TOOLS/CMakeLists.txt
new file mode 100644
index 0000000..59ff4ec
--- /dev/null
+++ b/TOOLS/CMakeLists.txt
@@ -0,0 +1,44 @@
+add_subdirectory(LAPACK)
+
+set (ATOOLS
+ iceil.f ilacpy.f ilcm.f indxg2p.f indxg2l.f
+ indxl2g.f infog1l.f infog2l.f npreroc.f numroc.f
+ chk1mat.f pchkxmat.f sltimer.f desc_convert.f
+ descinit.f descset.f
+ SL_init.f)
+
+set (ITOOLS
+ picol2row.f pirow2col.f pilaprnt.f pitreecomb.f pifillpad.f
+ pichekpad.f pielset.f pielset2.f pielget.f)
+
+set (STOOLS
+ dsnrm2.f dsasum.f slatcpy.f ssdot.f smatadd.f
+ psmatadd.f pscol2row.f psrow2col.f pslaprnt.f pstreecomb.f
+ psfillpad.f pschekpad.f pselset.f pselset2.f pselget.f
+ pslaread.f pslawrite.f)
+
+set (DTOOLS
+ dddot.f dlatcpy.f dmatadd.f pdmatadd.f pdcol2row.f
+ pdrow2col.f pdlaprnt.f pdtreecomb.f pdfillpad.f pdchekpad.f
+ pdelset.f pdelset2.f pdelget.f
+ pdlaread.f pdlawrite.f)
+
+set (CTOOLS
+ dscnrm2.f dscasum.f ccdotu.f ccdotc.f clatcpy.f
+ cmatadd.f pcmatadd.f pccol2row.f pcrow2col.f pclaprnt.f
+ pctreecomb.f pcfillpad.f pcchekpad.f pcelset.f pcelset2.f
+ pcelget.f
+ pclaread.f pclawrite.f)
+
+set (ZTOOLS
+ zzdotu.f zzdotc.f zlatcpy.f zmatadd.f pzmatadd.f
+ pzcol2row.f pzrow2col.f pzlaprnt.f pztreecomb.f pzfillpad.f
+ pzchekpad.f pzelset.f pzelset2.f pzelget.f
+ pzlaread.f pzlawrite.f)
+
+set(tools
+ ${ATOOLS} ${ITOOLS} ${STOOLS} ${DTOOLS} ${CTOOLS} ${ZTOOLS})
+
+set(tools-C
+ reshape.c SL_gridreshape.c )
+
diff --git a/TOOLS/LAPACK/CMakeLists.txt b/TOOLS/LAPACK/CMakeLists.txt
new file mode 100644
index 0000000..cd6944d
--- /dev/null
+++ b/TOOLS/LAPACK/CMakeLists.txt
@@ -0,0 +1,16 @@
+set (ALLAUX icopy.f)
+
+set (SCATGEN slatm1.f slaran.f slarnd.f)
+
+set (SMATGEN slatms.f slagge.f slagsy.f slarot.f)
+
+set (CMATGEN clarnv.f clatm1.f clatms.f clagge.f claghe.f clagsy.f clarot.f clarnd.f)
+
+set (DZATGEN dlatm1.f dlaran.f dlarnd.f)
+
+set (DMATGEN dlatms.f dlagge.f dlagsy.f dlarot.f)
+
+set (ZMATGEN zlarnv.f zlatm1.f zlatms.f zlagge.f zlaghe.f zlagsy.f zlarot.f zlarnd.f)
+
+set (extra_lapack
+ ${ALLAUX} ${SCATGEN} ${SMATGEN} ${CMATGEN} ${DZATGEN} ${DMATGEN} ${ZMATGEN})
diff --git a/TOOLS/LAPACK/Makefile b/TOOLS/LAPACK/Makefile
index 859abae..32a2696 100644
--- a/TOOLS/LAPACK/Makefile
+++ b/TOOLS/LAPACK/Makefile
@@ -35,47 +35,33 @@ ZMATGEN = zlarnv.o zlatm1.o zlatms.o zlagge.o zlaghe.o zlagsy.o zlarot.o \
all : single complex double complex16
single: $(ALLAUX) $(SMATGEN) $(SCATGEN)
- $(ARCH) $(ARCHFLAGS) $(SCALAPACKLIB) $(SLASRC) $(ALLAUX) $(SCLAUX) \
+ $(ARCH) $(ARCHFLAGS) ../../$(SCALAPACKLIB) $(SLASRC) $(ALLAUX) $(SCLAUX) \
$(SMATGEN) $(SCATGEN)
- $(RANLIB) $(SCALAPACKLIB)
+ $(RANLIB) ../../$(SCALAPACKLIB)
complex: $(ALLAUX) $(CMATGEN) $(SCATGEN)
- $(ARCH) $(ARCHFLAGS) $(SCALAPACKLIB) $(CLASRC) $(ALLAUX) $(SCLAUX) \
+ $(ARCH) $(ARCHFLAGS) ../../$(SCALAPACKLIB) $(CLASRC) $(ALLAUX) $(SCLAUX) \
$(CMATGEN) $(SCATGEN)
- $(RANLIB) $(SCALAPACKLIB)
+ $(RANLIB) ../../$(SCALAPACKLIB)
double: $(ALLAUX) $(DMATGEN) $(DZATGEN)
- $(ARCH) $(ARCHFLAGS) $(SCALAPACKLIB) $(DLASRC) $(ALLAUX) $(DZLAUX) \
+ $(ARCH) $(ARCHFLAGS) ../../$(SCALAPACKLIB) $(DLASRC) $(ALLAUX) $(DZLAUX) \
$(DMATGEN) $(DZATGEN)
- $(RANLIB) $(SCALAPACKLIB)
+ $(RANLIB) ../../$(SCALAPACKLIB)
complex16: $(ALLAUX) $(ZMATGEN) $(DZATGEN)
- $(ARCH) $(ARCHFLAGS) $(SCALAPACKLIB) $(ZLASRC) $(ALLAUX) $(DZLAUX) \
+ $(ARCH) $(ARCHFLAGS) ../../$(SCALAPACKLIB) $(ZLASRC) $(ALLAUX) $(DZLAUX) \
$(ZMATGEN) $(DZATGEN)
- $(RANLIB) $(SCALAPACKLIB)
-
-$(ALLAUX): $(FRC)
-$(SCLAUX): $(FRC)
-$(DZLAUX): $(FRC)
-
-$(SCATGEN): $(FRC)
-$(SMATGEN): $(FRC)
-$(CMATGEN): $(FRC)
-$(DZATGEN): $(FRC)
-$(DMATGEN): $(FRC)
-$(ZMATGEN): $(FRC)
-
-FRC:
- @FRC=$(FRC)
+ $(RANLIB) ../../$(SCALAPACKLIB)
clean :
rm -f *.o
slamch.o:
- $(F77) -c $(NOOPT) slamch.f
+ $(FC) -c $(NOOPT) slamch.f
dlamch.o:
- $(F77) -c $(NOOPT) dlamch.f
+ $(FC) -c $(NOOPT) dlamch.f
-.f.o : ; $(F77) -c $(F77FLAGS) $*.f
+.f.o : ; $(FC) -c $(FCFLAGS) $*.f
diff --git a/TOOLS/LAPACK/clarnd.f b/TOOLS/LAPACK/clarnd.f
index ac8117b..ecc969a 100644
--- a/TOOLS/LAPACK/clarnd.f
+++ b/TOOLS/LAPACK/clarnd.f
@@ -92,6 +92,8 @@
* uniform distribution on the unit circle abs(z) = 1
*
CLARND = EXP( CMPLX( ZERO, TWOPI*T2 ) )
+ ELSE
+ CLARND = CMPLX(ZERO,ZERO)
END IF
RETURN
*
diff --git a/TOOLS/LAPACK/clatms.f b/TOOLS/LAPACK/clatms.f
index 0d4361c..9402c11 100644
--- a/TOOLS/LAPACK/clatms.f
+++ b/TOOLS/LAPACK/clatms.f
@@ -376,6 +376,9 @@
UUB = MIN( KU, N-1 )
MR = MIN( M, N+LLB )
NC = MIN( N, M+UUB )
+ IROW = 1
+ ICOL = 1
+ CSYM = .FALSE.
*
IF( IPACK.EQ.5 .OR. IPACK.EQ.6 ) THEN
MINLDA = UUB + 1
diff --git a/TOOLS/LAPACK/dlarnd.f b/TOOLS/LAPACK/dlarnd.f
index a84ec8a..18c2229 100644
--- a/TOOLS/LAPACK/dlarnd.f
+++ b/TOOLS/LAPACK/dlarnd.f
@@ -79,6 +79,8 @@
*
T2 = DLARAN( ISEED )
DLARND = SQRT( -TWO*LOG( T1 ) )*COS( TWOPI*T2 )
+ ELSE
+ DLARND = ONE
END IF
RETURN
*
diff --git a/TOOLS/LAPACK/dlarot.f b/TOOLS/LAPACK/dlarot.f
index 8984229..9774fd1 100644
--- a/TOOLS/LAPACK/dlarot.f
+++ b/TOOLS/LAPACK/dlarot.f
@@ -239,6 +239,8 @@
NT = NT + 1
XT( NT ) = XRIGHT
YT( NT ) = A( IYT )
+ ELSE
+ IYT = 1
END IF
*
* Check for errors
diff --git a/TOOLS/LAPACK/dlatms.f b/TOOLS/LAPACK/dlatms.f
index 9949681..8f6aa43 100644
--- a/TOOLS/LAPACK/dlatms.f
+++ b/TOOLS/LAPACK/dlatms.f
@@ -356,6 +356,8 @@
UUB = MIN( KU, N-1 )
MR = MIN( M, N+LLB )
NC = MIN( N, M+UUB )
+ IROW = 1
+ ICOL = 1
*
IF( IPACK.EQ.5 .OR. IPACK.EQ.6 ) THEN
MINLDA = UUB + 1
diff --git a/TOOLS/LAPACK/icmax1.f b/TOOLS/LAPACK/icmax1.f
deleted file mode 100644
index c96f977..0000000
--- a/TOOLS/LAPACK/icmax1.f
+++ /dev/null
@@ -1,96 +0,0 @@
- INTEGER FUNCTION ICMAX1( N, CX, INCX )
-*
-* -- LAPACK auxiliary routine (version 3.0) --
-* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
-* Courant Institute, Argonne National Lab, and Rice University
-* June 30, 1999
-*
-* .. Scalar Arguments ..
- INTEGER INCX, N
-* ..
-* .. Array Arguments ..
- COMPLEX CX( * )
-* ..
-*
-* Purpose
-* =======
-*
-* ICMAX1 finds the index of the element whose real part has maximum
-* absolute value.
-*
-* Based on ICAMAX from Level 1 BLAS.
-* The change is to use the 'genuine' absolute value.
-*
-* Contributed by Nick Higham for use with CLACON.
-*
-* Arguments
-* =========
-*
-* N (input) INTEGER
-* The number of elements in the vector CX.
-*
-* CX (input) COMPLEX array, dimension (N)
-* The vector whose elements will be summed.
-*
-* INCX (input) INTEGER
-* The spacing between successive values of CX. INCX >= 1.
-*
-* =====================================================================
-*
-* .. Local Scalars ..
- INTEGER I, IX
- REAL SMAX
- COMPLEX ZDUM
-* ..
-* .. Intrinsic Functions ..
- INTRINSIC ABS, REAL
-* ..
-* .. Statement Functions ..
- REAL CABS1
-* ..
-* .. Statement Function definitions ..
-*
-* NEXT LINE IS THE ONLY MODIFICATION.
- CABS1( ZDUM ) = ABS( ZDUM )
-* ..
-* .. Executable Statements ..
-*
- ICMAX1 = 0
- IF( N.LT.1 )
- $ RETURN
- ICMAX1 = 1
- IF( N.EQ.1 )
- $ RETURN
- IF( INCX.EQ.1 )
- $ GO TO 30
-*
-* CODE FOR INCREMENT NOT EQUAL TO 1
-*
- IX = 1
- SMAX = CABS1( CX( 1 ) )
- IX = IX + INCX
- DO 20 I = 2, N
- IF( CABS1( CX( IX ) ).LE.SMAX )
- $ GO TO 10
- ICMAX1 = I
- SMAX = CABS1( CX( IX ) )
- 10 CONTINUE
- IX = IX + INCX
- 20 CONTINUE
- RETURN
-*
-* CODE FOR INCREMENT EQUAL TO 1
-*
- 30 CONTINUE
- SMAX = CABS1( CX( 1 ) )
- DO 40 I = 2, N
- IF( CABS1( CX( I ) ).LE.SMAX )
- $ GO TO 40
- ICMAX1 = I
- SMAX = CABS1( CX( I ) )
- 40 CONTINUE
- RETURN
-*
-* End of ICMAX1
-*
- END
diff --git a/TOOLS/LAPACK/izmax1.f b/TOOLS/LAPACK/izmax1.f
deleted file mode 100644
index a3488ea..0000000
--- a/TOOLS/LAPACK/izmax1.f
+++ /dev/null
@@ -1,96 +0,0 @@
- INTEGER FUNCTION IZMAX1( N, CX, INCX )
-*
-* -- LAPACK auxiliary routine (version 3.0) --
-* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
-* Courant Institute, Argonne National Lab, and Rice University
-* June 30, 1999
-*
-* .. Scalar Arguments ..
- INTEGER INCX, N
-* ..
-* .. Array Arguments ..
- COMPLEX*16 CX( * )
-* ..
-*
-* Purpose
-* =======
-*
-* IZMAX1 finds the index of the element whose real part has maximum
-* absolute value.
-*
-* Based on IZAMAX from Level 1 BLAS.
-* The change is to use the 'genuine' absolute value.
-*
-* Contributed by Nick Higham for use with ZLACON.
-*
-* Arguments
-* =========
-*
-* N (input) INTEGER
-* The number of elements in the vector CX.
-*
-* CX (input) COMPLEX*16 array, dimension (N)
-* The vector whose elements will be summed.
-*
-* INCX (input) INTEGER
-* The spacing between successive values of CX. INCX >= 1.
-*
-* =====================================================================
-*
-* .. Local Scalars ..
- INTEGER I, IX
- DOUBLE PRECISION SMAX
- COMPLEX*16 ZDUM
-* ..
-* .. Intrinsic Functions ..
- INTRINSIC ABS, DBLE
-* ..
-* .. Statement Functions ..
- DOUBLE PRECISION CABS1
-* ..
-* .. Statement Function definitions ..
-*
-* NEXT LINE IS THE ONLY MODIFICATION.
- CABS1( ZDUM ) = ABS( ZDUM )
-* ..
-* .. Executable Statements ..
-*
- IZMAX1 = 0
- IF( N.LT.1 )
- $ RETURN
- IZMAX1 = 1
- IF( N.EQ.1 )
- $ RETURN
- IF( INCX.EQ.1 )
- $ GO TO 30
-*
-* CODE FOR INCREMENT NOT EQUAL TO 1
-*
- IX = 1
- SMAX = CABS1( CX( 1 ) )
- IX = IX + INCX
- DO 20 I = 2, N
- IF( CABS1( CX( IX ) ).LE.SMAX )
- $ GO TO 10
- IZMAX1 = I
- SMAX = CABS1( CX( IX ) )
- 10 CONTINUE
- IX = IX + INCX
- 20 CONTINUE
- RETURN
-*
-* CODE FOR INCREMENT EQUAL TO 1
-*
- 30 CONTINUE
- SMAX = CABS1( CX( 1 ) )
- DO 40 I = 2, N
- IF( CABS1( CX( I ) ).LE.SMAX )
- $ GO TO 40
- IZMAX1 = I
- SMAX = CABS1( CX( I ) )
- 40 CONTINUE
- RETURN
-*
-* End of IZMAX1
-*
- END
diff --git a/TOOLS/LAPACK/slarnd.f b/TOOLS/LAPACK/slarnd.f
index 9386d6d..483b709 100644
--- a/TOOLS/LAPACK/slarnd.f
+++ b/TOOLS/LAPACK/slarnd.f
@@ -79,6 +79,8 @@
*
T2 = SLARAN( ISEED )
SLARND = SQRT( -TWO*LOG( T1 ) )*COS( TWOPI*T2 )
+ ELSE
+ SLARND = ONE
END IF
RETURN
*
diff --git a/TOOLS/LAPACK/slarot.f b/TOOLS/LAPACK/slarot.f
index 694e9bb..ee6a732 100644
--- a/TOOLS/LAPACK/slarot.f
+++ b/TOOLS/LAPACK/slarot.f
@@ -239,6 +239,8 @@
NT = NT + 1
XT( NT ) = XRIGHT
YT( NT ) = A( IYT )
+ ELSE
+ IYT = 1
END IF
*
* Check for errors
diff --git a/TOOLS/LAPACK/slatms.f b/TOOLS/LAPACK/slatms.f
index 3f70d13..a3f30af 100644
--- a/TOOLS/LAPACK/slatms.f
+++ b/TOOLS/LAPACK/slatms.f
@@ -356,6 +356,8 @@
UUB = MIN( KU, N-1 )
MR = MIN( M, N+LLB )
NC = MIN( N, M+UUB )
+ IROW = 1
+ ICOL = 1
*
IF( IPACK.EQ.5 .OR. IPACK.EQ.6 ) THEN
MINLDA = UUB + 1
diff --git a/TOOLS/LAPACK/zlarnd.f b/TOOLS/LAPACK/zlarnd.f
index b5b413f..d80dac7 100644
--- a/TOOLS/LAPACK/zlarnd.f
+++ b/TOOLS/LAPACK/zlarnd.f
@@ -92,6 +92,8 @@
* uniform distribution on the unit circle abs(z) = 1
*
ZLARND = EXP( DCMPLX( ZERO, TWOPI*T2 ) )
+ ELSE
+ ZLARND = DCMPLX(ZERO,ZERO)
END IF
RETURN
*
diff --git a/TOOLS/LAPACK/zlatms.f b/TOOLS/LAPACK/zlatms.f
index 7ab7046..e244bdb 100644
--- a/TOOLS/LAPACK/zlatms.f
+++ b/TOOLS/LAPACK/zlatms.f
@@ -376,6 +376,9 @@
UUB = MIN( KU, N-1 )
MR = MIN( M, N+LLB )
NC = MIN( N, M+UUB )
+ IROW = 1
+ ICOL = 1
+ ZSYM = .FALSE.
*
IF( IPACK.EQ.5 .OR. IPACK.EQ.6 ) THEN
MINLDA = UUB + 1
diff --git a/TOOLS/Makefile b/TOOLS/Makefile
index 9d2f64f..0ec6d58 100644
--- a/TOOLS/Makefile
+++ b/TOOLS/Makefile
@@ -49,51 +49,41 @@ ZTOOLS = zzdotu.o zzdotc.o zlatcpy.o zmatadd.o pzmatadd.o \
all: single double complex complex16
slapackaux:
- ( cd LAPACK; $(MAKE) single FRC=$(FRC) )
+ ( cd LAPACK; $(MAKE) single )
dlapackaux:
- ( cd LAPACK; $(MAKE) double FRC=$(FRC) )
+ ( cd LAPACK; $(MAKE) double )
clapackaux:
- ( cd LAPACK; $(MAKE) complex FRC=$(FRC) )
+ ( cd LAPACK; $(MAKE) complex )
zlapackaux:
- ( cd LAPACK; $(MAKE) complex16 FRC=$(FRC) )
+ ( cd LAPACK; $(MAKE) complex16 )
integer: $(ATOOLS) $(ITOOLS)
- $(ARCH) $(ARCHFLAGS) $(SCALAPACKLIB) $(ATOOLS) $(ITOOLS)
- $(RANLIB) $(SCALAPACKLIB)
+ $(ARCH) $(ARCHFLAGS) ../$(SCALAPACKLIB) $(ATOOLS) $(ITOOLS)
+ $(RANLIB) ../$(SCALAPACKLIB)
single: slapackaux integer $(STOOLS)
- $(ARCH) $(ARCHFLAGS) $(SCALAPACKLIB) $(STOOLS)
- $(RANLIB) $(SCALAPACKLIB)
+ $(ARCH) $(ARCHFLAGS) ../$(SCALAPACKLIB) $(STOOLS)
+ $(RANLIB) ../$(SCALAPACKLIB)
double: dlapackaux integer $(DTOOLS)
- $(ARCH) $(ARCHFLAGS) $(SCALAPACKLIB) $(DTOOLS)
- $(RANLIB) $(SCALAPACKLIB)
+ $(ARCH) $(ARCHFLAGS) ../$(SCALAPACKLIB) $(DTOOLS)
+ $(RANLIB) ../$(SCALAPACKLIB)
complex: clapackaux integer $(CTOOLS)
- $(ARCH) $(ARCHFLAGS) $(SCALAPACKLIB) $(CTOOLS)
- $(RANLIB) $(SCALAPACKLIB)
+ $(ARCH) $(ARCHFLAGS) ../$(SCALAPACKLIB) $(CTOOLS)
+ $(RANLIB) ../$(SCALAPACKLIB)
complex16: zlapackaux integer $(ZTOOLS)
- $(ARCH) $(ARCHFLAGS) $(SCALAPACKLIB) $(ZTOOLS)
- $(RANLIB) $(SCALAPACKLIB)
-
-$(ATOOLS): $(FRC)
-$(ITOOLS): $(FRC)
-$(STOOLS): $(FRC)
-$(DTOOLS): $(FRC)
-$(CTOOLS): $(FRC)
-$(ZTOOLS): $(FRC)
-
-FRC:
- @FRC=$(FRC)
+ $(ARCH) $(ARCHFLAGS) ../$(SCALAPACKLIB) $(ZTOOLS)
+ $(RANLIB) ../$(SCALAPACKLIB)
clean :
rm -f *.o
( cd LAPACK; $(MAKE) clean )
-.f.o : ; $(F77) -c $(F77FLAGS) $*.f
+.f.o : ; $(FC) -c $(FCFLAGS) $*.f
-.c.o : ; $(CC) -c $(CCFLAGS) $(CDEFS) $*.c
+.c.o : ; $(CC) -c $(CDEFS) $(CCFLAGS) $*.c
diff --git a/TOOLS/desc_convert.f b/TOOLS/desc_convert.f
index 37e9ce5..404975b 100644
--- a/TOOLS/desc_convert.f
+++ b/TOOLS/desc_convert.f
@@ -48,6 +48,16 @@
*
DESC_TYPE_IN = DESC_IN( 1 )
*
+* .. Initialize Variables ..
+*
+ RSRC = 0
+ NB = 0
+ N = 0
+ MB = 0
+ M = 0
+ LLDA = 0
+ CSRC = 0
+*
IF( DESC_TYPE_IN .EQ. BLOCK_CYCLIC_2D ) THEN
ICTXT = DESC_IN( CTXT_ )
RSRC = DESC_IN( RSRC_ )
diff --git a/TOOLS/pccol2row.f b/TOOLS/pccol2row.f
index c347c0b..214a9ca 100644
--- a/TOOLS/pccol2row.f
+++ b/TOOLS/pccol2row.f
@@ -107,8 +107,10 @@
* ..
* .. Executable Statements ..
*
-* Get grid parameters.
+ ICPY = 0
*
+* Get grid parameters.
+*
CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL )
*
* If we are not in special case for NPROW = NPCOL where there
diff --git a/TOOLS/pcrow2col.f b/TOOLS/pcrow2col.f
index fd1b0f5..99142b6 100644
--- a/TOOLS/pcrow2col.f
+++ b/TOOLS/pcrow2col.f
@@ -106,6 +106,8 @@
* ..
* .. Executable Statements ..
*
+ ICPY = 0
+*
CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL )
*
* If we are not in special case for NPROW = NPCOL where there is no
diff --git a/TOOLS/pctreecomb.f b/TOOLS/pctreecomb.f
index b79300f..d2a8a7b 100644
--- a/TOOLS/pctreecomb.f
+++ b/TOOLS/pctreecomb.f
@@ -78,6 +78,8 @@
* ..
* .. Executable Statements ..
*
+ DEST = 0
+*
* See if everyone wants the answer (need to broadcast the answer)
*
BCAST = ( ( RDEST0.EQ.-1 ).OR.( CDEST0.EQ.-1 ) )
diff --git a/TOOLS/pdcol2row.f b/TOOLS/pdcol2row.f
index 681a67f..05cf717 100644
--- a/TOOLS/pdcol2row.f
+++ b/TOOLS/pdcol2row.f
@@ -107,6 +107,10 @@
* ..
* .. Executable Statements ..
*
+* .. Initialize Variables ..
+*
+ ICPY = 0
+*
* Get grid parameters.
*
CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL )
diff --git a/TOOLS/pdrow2col.f b/TOOLS/pdrow2col.f
index 3885d98..1e06564 100644
--- a/TOOLS/pdrow2col.f
+++ b/TOOLS/pdrow2col.f
@@ -106,6 +106,11 @@
* ..
* .. Executable Statements ..
*
+*
+* .. Initialize Variables ..
+*
+ ICPY = 0
+*
CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL )
*
* If we are not in special case for NPROW = NPCOL where there is no
diff --git a/TOOLS/pdtreecomb.f b/TOOLS/pdtreecomb.f
index 794eb86..6dbb364 100644
--- a/TOOLS/pdtreecomb.f
+++ b/TOOLS/pdtreecomb.f
@@ -78,6 +78,8 @@
* ..
* .. Executable Statements ..
*
+ DEST = 0
+*
* See if everyone wants the answer (need to broadcast the answer)
*
BCAST = ( ( RDEST0.EQ.-1 ).OR.( CDEST0.EQ.-1 ) )
diff --git a/TOOLS/picol2row.f b/TOOLS/picol2row.f
index 767a533..e0d4a94 100644
--- a/TOOLS/picol2row.f
+++ b/TOOLS/picol2row.f
@@ -107,6 +107,10 @@
* ..
* .. Executable Statements ..
*
+* .. Initialize Variables ..
+*
+ ICPY = 0
+*
* Get grid parameters.
*
CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL )
diff --git a/TOOLS/pirow2col.f b/TOOLS/pirow2col.f
index 5b18690..ea0c5bc 100644
--- a/TOOLS/pirow2col.f
+++ b/TOOLS/pirow2col.f
@@ -106,6 +106,11 @@
* ..
* .. Executable Statements ..
*
+*
+* .. Initialize Variables ..
+*
+ ICPY = 0
+*
CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL )
*
* If we are not in special case for NPROW = NPCOL where there is no
diff --git a/TOOLS/pitreecomb.f b/TOOLS/pitreecomb.f
index 62807d4..fe031d0 100644
--- a/TOOLS/pitreecomb.f
+++ b/TOOLS/pitreecomb.f
@@ -78,6 +78,8 @@
* ..
* .. Executable Statements ..
*
+ DEST = 0
+*
* See if everyone wants the answer (need to broadcast the answer)
*
BCAST = ( ( RDEST0.EQ.-1 ).OR.( CDEST0.EQ.-1 ) )
diff --git a/TOOLS/pscol2row.f b/TOOLS/pscol2row.f
index c639b84..9533153 100644
--- a/TOOLS/pscol2row.f
+++ b/TOOLS/pscol2row.f
@@ -107,6 +107,11 @@
* ..
* .. Executable Statements ..
*
+*
+* .. Initialize Variables ..
+*
+ ICPY = 0
+*
* Get grid parameters.
*
CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL )
diff --git a/TOOLS/pslawrite.f b/TOOLS/pslawrite.f
index 469a924..2daafb9 100644
--- a/TOOLS/pslawrite.f
+++ b/TOOLS/pslawrite.f
@@ -213,7 +213,7 @@
CLOSE( NOUT )
END IF
*
- 9999 FORMAT( E15.9 )
+ 9999 FORMAT( E15.8 )
*
RETURN
*
diff --git a/TOOLS/psrow2col.f b/TOOLS/psrow2col.f
index 9c7dee9..125cfd5 100644
--- a/TOOLS/psrow2col.f
+++ b/TOOLS/psrow2col.f
@@ -106,6 +106,11 @@
* ..
* .. Executable Statements ..
*
+*
+* .. Initialize Variables ..
+*
+ ICPY = 0
+*
CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL )
*
* If we are not in special case for NPROW = NPCOL where there is no
diff --git a/TOOLS/pstreecomb.f b/TOOLS/pstreecomb.f
index f32bfed..c1be7a4 100644
--- a/TOOLS/pstreecomb.f
+++ b/TOOLS/pstreecomb.f
@@ -78,6 +78,7 @@
* ..
* .. Executable Statements ..
*
+ DEST = 0
* See if everyone wants the answer (need to broadcast the answer)
*
BCAST = ( ( RDEST0.EQ.-1 ).OR.( CDEST0.EQ.-1 ) )
diff --git a/TOOLS/pzcol2row.f b/TOOLS/pzcol2row.f
index 83f74b0..8ef0c2b 100644
--- a/TOOLS/pzcol2row.f
+++ b/TOOLS/pzcol2row.f
@@ -107,6 +107,8 @@
* ..
* .. Executable Statements ..
*
+ ICPY = 0
+*
* Get grid parameters.
*
CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL )
diff --git a/TOOLS/pzlawrite.f b/TOOLS/pzlawrite.f
index 9a769dd..2b3dc51 100644
--- a/TOOLS/pzlawrite.f
+++ b/TOOLS/pzlawrite.f
@@ -223,7 +223,7 @@
CLOSE( NOUT )
END IF
*
- 9999 FORMAT( E15.9,E15.9 )
+ 9999 FORMAT( E15.8,E15.8 )
*
RETURN
*
diff --git a/TOOLS/pzrow2col.f b/TOOLS/pzrow2col.f
index 2ce3ff3..4c06a6d 100644
--- a/TOOLS/pzrow2col.f
+++ b/TOOLS/pzrow2col.f
@@ -106,6 +106,8 @@
* ..
* .. Executable Statements ..
*
+ ICPY = 0
+*
CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL )
*
* If we are not in special case for NPROW = NPCOL where there is no
diff --git a/TOOLS/pztreecomb.f b/TOOLS/pztreecomb.f
index 1ccf2ae..d8315d0 100644
--- a/TOOLS/pztreecomb.f
+++ b/TOOLS/pztreecomb.f
@@ -78,6 +78,8 @@
* ..
* .. Executable Statements ..
*
+ DEST = 0
+*
* See if everyone wants the answer (need to broadcast the answer)
*
BCAST = ( ( RDEST0.EQ.-1 ).OR.( CDEST0.EQ.-1 ) )
diff --git a/scalapack.pc.in b/scalapack.pc.in
new file mode 100644
index 0000000..5fab645
--- /dev/null
+++ b/scalapack.pc.in
@@ -0,0 +1,9 @@
+prefix=@prefix@
+libdir=@libdir@
+
+Name: scalapack
+Description: SCALAPACK reference implementation
+Version: @SCALAPACK_VERSION@
+URL: http://www.netlib.org/scalapack/
+Libs: -L${libdir} -lscalapack
+Requires: mpi lapack blas
diff --git a/scalapack_build.cmake b/scalapack_build.cmake
new file mode 100644
index 0000000..ba30a87
--- /dev/null
+++ b/scalapack_build.cmake
@@ -0,0 +1,224 @@
+cmake_minimum_required(VERSION 2.8)
+###################################################################
+# The values in this section must always be provided
+###################################################################
+if(UNIX)
+ if(NOT compiler)
+ set(compiler gcc)
+ endif(NOT compiler)
+ if(NOT c_compiler)
+ set(c_compiler gcc)
+ endif(NOT c_compiler)
+ if(NOT full_compiler)
+ set(full_compiler g++)
+ endif(NOT full_compiler)
+endif(UNIX)
+
+if(EXISTS "/proc/cpuinfo")
+ set(parallel 1)
+ file(STRINGS "/proc/cpuinfo" CPUINFO)
+ foreach(line ${CPUINFO})
+ if("${line}" MATCHES processor)
+ math(EXPR parallel "${parallel} + 1")
+ endif()
+ endforeach(line)
+endif()
+
+if(WIN32)
+ set(VSLOCATIONS
+ "[HKEY_LOCAL_MACHINE\\SOFTWARE\\Microsoft\\VisualStudio\\6.0\\Setup;VsCommonDir]/MSDev98/Bin"
+ "[HKEY_LOCAL_MACHINE\\SOFTWARE\\Microsoft\\VisualStudio\\7.0\\Setup\\VS;EnvironmentDirectory]"
+ "[HKEY_LOCAL_MACHINE\\SOFTWARE\\Microsoft\\VisualStudio\\7.1\\Setup\\VS;EnvironmentDirectory]"
+ "[HKEY_LOCAL_MACHINE\\SOFTWARE\\Microsoft\\VisualStudio\\8.0;InstallDir]"
+ "[HKEY_LOCAL_MACHINE\\SOFTWARE\\Microsoft\\VisualStudio\\8.0\\Setup;Dbghelp_path]"
+ "[HKEY_LOCAL_MACHINE\\SOFTWARE\\Microsoft\\VisualStudio\\9.0\\Setup\\VS;EnvironmentDirectory]"
+ )
+ set(GENERATORS
+ "Visual Studio 6"
+ "Visual Studio 7"
+ "Visual Studio 7 .NET 2003"
+ "Visual Studio 8 2005"
+ "Visual Studio 8 2005"
+ "Visual Studio 9 2008"
+ )
+ set(vstype 0)
+ foreach(p ${VSLOCATIONS})
+ get_filename_component(VSPATH ${p} PATH)
+ if(NOT "${VSPATH}" STREQUAL "/" AND EXISTS "${VSPATH}")
+ message(" found VS install = ${VSPATH}")
+ set(genIndex ${vstype})
+ endif()
+ math(EXPR vstype "${vstype} +1")
+ endforeach()
+ if(NOT DEFINED genIndex)
+ message(FATAL_ERROR "Could not find installed visual stuido")
+ endif()
+ list(GET GENERATORS ${genIndex} GENERATOR)
+ set(CTEST_CMAKE_GENERATOR "${GENERATOR}")
+ message("${CTEST_CMAKE_GENERATOR} - found")
+ set(compiler cl)
+endif(WIN32)
+
+find_program(HOSTNAME NAMES hostname)
+find_program(UNAME NAMES uname)
+
+# Get the build name and hostname
+exec_program(${HOSTNAME} ARGS OUTPUT_VARIABLE hostname)
+string(REGEX REPLACE "[/\\\\+<> #]" "-" hostname "${hostname}")
+
+message("HOSTNAME: ${hostname}")
+# default to parallel 1
+if(NOT DEFINED parallel)
+ set(parallel 1)
+endif(NOT DEFINED parallel)
+
+# find SVN
+find_program(SVN svn PATHS $ENV{HOME}/bin /vol/local/bin)
+if(NOT SVN)
+ message(FATAL_ERROR "SVN not found")
+endif()
+
+set(CTEST_UPDATE_COMMAND ${SVN})
+macro(getuname name flag)
+ exec_program("${UNAME}" ARGS "${flag}" OUTPUT_VARIABLE "${name}")
+ string(REGEX REPLACE "[/\\\\+<> #]" "-" "${name}" "${${name}}")
+ string(REGEX REPLACE "^(......|.....|....|...|..|.).*" "\\1" "${name}" "${${name}}")
+endmacro(getuname)
+
+getuname(osname -s)
+getuname(osver -v)
+getuname(osrel -r)
+getuname(cpu -m)
+if("${osname}" MATCHES Darwin)
+ find_program(SW_VER sw_vers)
+ execute_process(COMMAND "${SW_VER}" -productVersion OUTPUT_VARIABLE osver)
+ string(REPLACE "\n" "" osver "${osver}")
+ set(osname "MacOSX")
+ set(osrel "")
+ if("${cpu}" MATCHES "Power")
+ set(cpu "ppc")
+ endif("${cpu}" MATCHES "Power")
+endif("${osname}" MATCHES Darwin)
+
+if(NOT compiler)
+ message(FATAL_ERROR "compiler must be set")
+endif(NOT compiler)
+
+
+set(BUILDNAME "${osname}${osver}${osrel}${cpu}-${compiler}")
+message("BUILDNAME: ${BUILDNAME}")
+
+# this is the cvs module name that should be checked out
+set (CTEST_MODULE_NAME scalapack)
+set (CTEST_DIR_NAME "${CTEST_MODULE_NAME}SVN")
+
+# Settings:
+message("NOSPACES = ${NOSPACES}")
+if(NOSPACES)
+ set(CTEST_DASHBOARD_ROOT "$ENV{HOME}/Dashboards/MyTests-${BUILDNAME}")
+else(NOSPACES)
+ set(CTEST_DASHBOARD_ROOT "$ENV{HOME}/Dashboards/My Tests-${BUILDNAME}")
+endif(NOSPACES)
+set(CTEST_SITE "${hostname}")
+set(CTEST_BUILD_NAME "${BUILDNAME}")
+set(CTEST_TEST_TIMEOUT "600")
+
+# CVS command and the checkout command
+if(NOT EXISTS "${CTEST_DASHBOARD_ROOT}/${CTEST_DIR_NAME}")
+ set(CTEST_CHECKOUT_COMMAND
+ "\"${CTEST_UPDATE_COMMAND}\" co https://icl.cs.utk.edu/svn/scalapack-dev/scalapack/trunk ${CTEST_DIR_NAME}")
+endif(NOT EXISTS "${CTEST_DASHBOARD_ROOT}/${CTEST_DIR_NAME}")
+
+# Set the generator and build configuration
+if(NOT DEFINED CTEST_CMAKE_GENERATOR)
+ set(CTEST_CMAKE_GENERATOR "Unix Makefiles")
+endif(NOT DEFINED CTEST_CMAKE_GENERATOR)
+set(CTEST_PROJECT_NAME "ScaLAPACK")
+set(CTEST_BUILD_CONFIGURATION "Release")
+
+# Extra special variables
+set(ENV{DISPLAY} "")
+if(CTEST_CMAKE_GENERATOR MATCHES Makefiles)
+ set(ENV{CC} "${c_compiler}")
+ set(ENV{FC} "${f_compiler}")
+ set(ENV{CXX} "${full_compiler}")
+endif(CTEST_CMAKE_GENERATOR MATCHES Makefiles)
+
+#----------------------------------------------------------------------------------
+# Should not need to edit under this line
+#----------------------------------------------------------------------------------
+
+# if you do not want to use the default location for a
+# dashboard then set this variable to the directory
+# the dashboard should be in
+make_directory("${CTEST_DASHBOARD_ROOT}")
+# these are the the name of the source and binary directory on disk.
+# They will be appended to DASHBOARD_ROOT
+set(CTEST_SOURCE_DIRECTORY "${CTEST_DASHBOARD_ROOT}/${CTEST_DIR_NAME}")
+set(CTEST_BINARY_DIRECTORY "${CTEST_SOURCE_DIRECTORY}-${CTEST_BUILD_NAME}")
+set(CTEST_NOTES_FILES "${CTEST_NOTES_FILES}"
+ "${CMAKE_CURRENT_LIST_FILE}"
+ )
+
+# check for parallel
+if(parallel GREATER 1)
+ if(NOT CTEST_BUILD_COMMAND)
+ set(CTEST_BUILD_COMMAND "make -j${parallel} -i")
+ endif(NOT CTEST_BUILD_COMMAND)
+
+ message("Use parallel build")
+ message("CTEST_BUILD_COMMAND: ${CTEST_BUILD_COMMAND}")
+ message("CTEST_CONFIGURE_COMMAND: ${CTEST_CONFIGURE_COMMAND}")
+endif(parallel GREATER 1)
+
+###################################################################
+# Values for the cmake build
+###################################################################
+
+set( CACHE_CONTENTS "
+SITE:STRING=${hostname}
+BUILDNAME:STRING=${BUILDNAME}
+DART_ROOT:PATH=
+SVNCOMMAND:FILEPATH=${CTEST_UPDATE_COMMAND}
+DROP_METHOD:STRING=https
+DART_TESTING_TIMEOUT:STRING=${CTEST_TEST_TIMEOUT}
+# Specific Fortran Compiler (uncomment and add flags directly after = )
+#CMAKE_Fortran_COMPILER:STRING=
+# Specific Fortran Compiler Flags (uncomment and add flags directly after = )
+#CMAKE_Fortran_FLAGS:STRING=
+# Use Reference BLAS and LAPACK by default
+USE_OPTIMIZED_LAPACK_BLAS:OPTION=OFF
+" )
+
+##########################################################################
+# wipe the binary dir
+message("Remove binary directory...")
+ctest_empty_binary_directory("${CTEST_BINARY_DIRECTORY}")
+
+message("CTest Directory: ${CTEST_DASHBOARD_ROOT}")
+message("Initial checkout: ${CTEST_CVS_CHECKOUT}")
+message("Initial cmake: ${CTEST_CMAKE_COMMAND}")
+message("CTest command: ${CTEST_COMMAND}")
+
+# this is the initial cache to use for the binary tree, be careful to escape
+# any quotes inside of this string if you use it
+file(WRITE "${CTEST_BINARY_DIRECTORY}/CMakeCache.txt" "${CACHE_CONTENTS}")
+
+message("Start dashboard...")
+ctest_start(Nightly)
+#ctest_start(Experimental)
+message(" Update")
+ctest_update(SOURCE "${CTEST_SOURCE_DIRECTORY}" RETURN_VALUE res)
+message(" Configure")
+ctest_configure(BUILD "${CTEST_BINARY_DIRECTORY}" RETURN_VALUE res)
+message("read custom files after configure")
+ctest_read_custom_files("${CTEST_BINARY_DIRECTORY}")
+message(" Build")
+ctest_build(BUILD "${CTEST_BINARY_DIRECTORY}" RETURN_VALUE res)
+message(" Test")
+ctest_test(BUILD "${CTEST_BINARY_DIRECTORY}" RETURN_VALUE res)
+message(" Submit")
+ctest_submit(RETURN_VALUE res)
+message(" All done")
+
+
--
Alioth's /usr/local/bin/git-commit-notice on /srv/git.debian.org/git/debian-science/packages/scalapack.git
More information about the debian-science-commits
mailing list