[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Getfem-commits] (no subject)
|
From: |
Konstantinos Poulios |
|
Subject: |
[Getfem-commits] (no subject) |
|
Date: |
Thu, 19 Oct 2023 17:36:19 -0400 (EDT) |
branch: remove-local-superlu
commit bb74a09af4be3a0ee58796ffbb32c3feca1844b7
Author: Konstantinos Poulios <logari81@gmail.com>
AuthorDate: Thu Oct 19 23:36:02 2023 +0200
Remove local SuperLU copy
- switch to SuperLU version 5.0 or later
- provide similar configure options for SuperLU and MUMPS
- fix obsolete autoconf macros
- remove redundant autotools files
---
Makefile.am | 2 +-
configure.ac | 289 +-
contrib/continuum_mechanics/Makefile.am | 2 -
m4/ax_boost_base.m4 | 272 -
m4/ax_boost_system.m4 | 120 -
m4/ax_boost_thread.m4 | 149 -
m4/ax_prefix_config_h.m4 | 2 +-
m4/scilab.m4 | 6 +-
src/getfem_superlu.cc | 7 +-
src/gmm/gmm_superlu_interface.h | 7 +-
superlu/BLAS.c | 43902 ------------------------------
superlu/BLAS/License.txt | 14 -
superlu/BLAS/caxpy.f | 102 -
superlu/BLAS/ccopy.f | 94 -
superlu/BLAS/cdotc.f | 103 -
superlu/BLAS/cdotu.f | 100 -
superlu/BLAS/cgbmv.f | 390 -
superlu/BLAS/cgemm.f | 483 -
superlu/BLAS/cgemv.f | 350 -
superlu/BLAS/cgerc.f | 227 -
superlu/BLAS/cgeru.f | 227 -
superlu/BLAS/chbmv.f | 380 -
superlu/BLAS/chemm.f | 371 -
superlu/BLAS/chemv.f | 337 -
superlu/BLAS/cher.f | 278 -
superlu/BLAS/cher2.f | 317 -
superlu/BLAS/cher2k.f | 442 -
superlu/BLAS/cherk.f | 396 -
superlu/BLAS/chpmv.f | 338 -
superlu/BLAS/chpr.f | 279 -
superlu/BLAS/chpr2.f | 318 -
superlu/BLAS/crotg.f | 74 -
superlu/BLAS/cscal.f | 91 -
superlu/BLAS/csrot.f | 153 -
superlu/BLAS/csscal.f | 94 -
superlu/BLAS/cswap.f | 98 -
superlu/BLAS/csymm.f | 369 -
superlu/BLAS/csyr2k.f | 396 -
superlu/BLAS/csyrk.f | 363 -
superlu/BLAS/ctbmv.f | 429 -
superlu/BLAS/ctbsv.f | 432 -
superlu/BLAS/ctpmv.f | 388 -
superlu/BLAS/ctpsv.f | 390 -
superlu/BLAS/ctrmm.f | 452 -
superlu/BLAS/ctrmv.f | 373 -
superlu/BLAS/ctrsm.f | 477 -
superlu/BLAS/ctrsv.f | 375 -
superlu/BLAS/dasum.f | 111 -
superlu/BLAS/daxpy.f | 115 -
superlu/BLAS/dcabs1.f | 58 -
superlu/BLAS/dcopy.f | 115 -
superlu/BLAS/ddot.f | 117 -
superlu/BLAS/dgbmv.f | 370 -
superlu/BLAS/dgemm.f | 384 -
superlu/BLAS/dgemv.f | 330 -
superlu/BLAS/dger.f | 227 -
superlu/BLAS/dnrm2.f | 112 -
superlu/BLAS/drot.f | 101 -
superlu/BLAS/drotg.f | 86 -
superlu/BLAS/drotm.f | 202 -
superlu/BLAS/drotmg.f | 251 -
superlu/BLAS/dsbmv.f | 375 -
superlu/BLAS/dscal.f | 110 -
superlu/BLAS/dsdot.f | 172 -
superlu/BLAS/dspmv.f | 331 -
superlu/BLAS/dspr.f | 261 -
superlu/BLAS/dspr2.f | 296 -
superlu/BLAS/dswap.f | 122 -
superlu/BLAS/dsymm.f | 367 -
superlu/BLAS/dsymv.f | 333 -
superlu/BLAS/dsyr.f | 263 -
superlu/BLAS/dsyr2.f | 298 -
superlu/BLAS/dsyr2k.f | 399 -
superlu/BLAS/dsyrk.f | 364 -
superlu/BLAS/dtbmv.f | 398 -
superlu/BLAS/dtbsv.f | 401 -
superlu/BLAS/dtpmv.f | 352 -
superlu/BLAS/dtpsv.f | 354 -
superlu/BLAS/dtrmm.f | 415 -
superlu/BLAS/dtrmv.f | 342 -
superlu/BLAS/dtrsm.f | 443 -
superlu/BLAS/dtrsv.f | 338 -
superlu/BLAS/dzasum.f | 98 -
superlu/BLAS/dznrm2.f | 119 -
superlu/BLAS/icamax.f | 107 -
superlu/BLAS/idamax.f | 106 -
superlu/BLAS/isamax.f | 106 -
superlu/BLAS/izamax.f | 107 -
superlu/BLAS/lsame.f | 125 -
superlu/BLAS/sasum.f | 112 -
superlu/BLAS/saxpy.f | 115 -
superlu/BLAS/scabs1.f | 57 -
superlu/BLAS/scasum.f | 97 -
superlu/BLAS/scnrm2.f | 119 -
superlu/BLAS/scopy.f | 115 -
superlu/BLAS/sdot.f | 117 -
superlu/BLAS/sdsdot.f | 255 -
superlu/BLAS/sgbmv.f | 370 -
superlu/BLAS/sgemm.f | 384 -
superlu/BLAS/sgemv.f | 330 -
superlu/BLAS/sger.f | 227 -
superlu/BLAS/snrm2.f | 112 -
superlu/BLAS/srot.f | 101 -
superlu/BLAS/srotg.f | 86 -
superlu/BLAS/srotm.f | 203 -
superlu/BLAS/srotmg.f | 251 -
superlu/BLAS/ssbmv.f | 375 -
superlu/BLAS/sscal.f | 110 -
superlu/BLAS/sspmv.f | 331 -
superlu/BLAS/sspr.f | 261 -
superlu/BLAS/sspr2.f | 296 -
superlu/BLAS/sswap.f | 122 -
superlu/BLAS/ssymm.f | 367 -
superlu/BLAS/ssymv.f | 333 -
superlu/BLAS/ssyr.f | 263 -
superlu/BLAS/ssyr2.f | 298 -
superlu/BLAS/ssyr2k.f | 399 -
superlu/BLAS/ssyrk.f | 364 -
superlu/BLAS/stbmv.f | 398 -
superlu/BLAS/stbsv.f | 401 -
superlu/BLAS/stpmv.f | 352 -
superlu/BLAS/stpsv.f | 354 -
superlu/BLAS/strmm.f | 415 -
superlu/BLAS/strmv.f | 342 -
superlu/BLAS/strsm.f | 443 -
superlu/BLAS/strsv.f | 344 -
superlu/BLAS/xerbla.f | 89 -
superlu/BLAS/xerbla_array.f | 119 -
superlu/BLAS/zaxpy.f | 102 -
superlu/BLAS/zcopy.f | 94 -
superlu/BLAS/zdotc.f | 103 -
superlu/BLAS/zdotu.f | 100 -
superlu/BLAS/zdrot.f | 153 -
superlu/BLAS/zdscal.f | 94 -
superlu/BLAS/zgbmv.f | 390 -
superlu/BLAS/zgemm.f | 483 -
superlu/BLAS/zgemv.f | 350 -
superlu/BLAS/zgerc.f | 227 -
superlu/BLAS/zgeru.f | 227 -
superlu/BLAS/zhbmv.f | 380 -
superlu/BLAS/zhemm.f | 371 -
superlu/BLAS/zhemv.f | 337 -
superlu/BLAS/zher.f | 278 -
superlu/BLAS/zher2.f | 317 -
superlu/BLAS/zher2k.f | 443 -
superlu/BLAS/zherk.f | 396 -
superlu/BLAS/zhpmv.f | 338 -
superlu/BLAS/zhpr.f | 279 -
superlu/BLAS/zhpr2.f | 318 -
superlu/BLAS/zrotg.f | 75 -
superlu/BLAS/zscal.f | 91 -
superlu/BLAS/zswap.f | 98 -
superlu/BLAS/zsymm.f | 369 -
superlu/BLAS/zsyr2k.f | 396 -
superlu/BLAS/zsyrk.f | 363 -
superlu/BLAS/ztbmv.f | 429 -
superlu/BLAS/ztbsv.f | 432 -
superlu/BLAS/ztpmv.f | 388 -
superlu/BLAS/ztpsv.f | 390 -
superlu/BLAS/ztrmm.f | 452 -
superlu/BLAS/ztrmv.f | 373 -
superlu/BLAS/ztrsm.f | 477 -
superlu/BLAS/ztrsv.f | 375 -
superlu/BLAS_f2c.h | 236 -
superlu/License.txt | 30 -
superlu/Makefile.am | 329 -
superlu/ccolumn_bmod.c | 362 -
superlu/ccolumn_dfs.c | 266 -
superlu/ccopy_to_ucol.c | 112 -
superlu/cgscon.c | 155 -
superlu/cgsequ.c | 205 -
superlu/cgsrfs.c | 457 -
superlu/cgssv.c | 231 -
superlu/cgssvx.c | 627 -
superlu/cgstrf.c | 444 -
superlu/cgstrs.c | 344 -
superlu/clacon.c | 236 -
superlu/clangs.c | 132 -
superlu/claqgs.c | 160 -
superlu/cmemory.c | 691 -
superlu/cmyblas2.c | 204 -
superlu/colamd.c | 3412 ---
superlu/colamd.h | 246 -
superlu/cpanel_bmod.c | 478 -
superlu/cpanel_dfs.c | 256 -
superlu/cpivotL.c | 171 -
superlu/cpivotgrowth.c | 130 -
superlu/cpruneL.c | 156 -
superlu/creadhb.c | 288 -
superlu/csnode_bmod.c | 117 -
superlu/csnode_dfs.c | 113 -
superlu/csp_blas2.c | 577 -
superlu/csp_blas3.c | 141 -
superlu/cutil.c | 482 -
superlu/dcolumn_bmod.c | 354 -
superlu/dcolumn_dfs.c | 267 -
superlu/dcomplex.c | 116 -
superlu/dcopy_to_ucol.c | 112 -
superlu/dgscon.c | 156 -
superlu/dgsequ.c | 206 -
superlu/dgsrfs.c | 447 -
superlu/dgssv.c | 231 -
superlu/dgssvx.c | 626 -
superlu/dgstrf.c | 441 -
superlu/dgstrs.c | 330 -
superlu/dgstrsL.c | 230 -
superlu/dlacon.c | 250 -
superlu/dlamch.c | 1004 -
superlu/dlangs.c | 132 -
superlu/dlaqgs.c | 158 -
superlu/dmemory.c | 690 -
superlu/dmyblas2.c | 246 -
superlu/dpanel_bmod.c | 449 -
superlu/dpanel_dfs.c | 256 -
superlu/dpivotL.c | 170 -
superlu/dpivotgrowth.c | 129 -
superlu/dpruneL.c | 156 -
superlu/dreadhb.c | 277 -
superlu/dsnode_bmod.c | 114 -
superlu/dsnode_dfs.c | 113 -
superlu/dsp_blas2.c | 498 -
superlu/dsp_blas3.c | 141 -
superlu/dutil.c | 479 -
superlu/dzsum1.c | 102 -
superlu/f2c_lite.c | 391 -
superlu/get_perm_c.c | 472 -
superlu/heap_relax_snode.c | 113 -
superlu/icmax1.c | 124 -
superlu/izmax1.c | 117 -
superlu/lsame.c | 111 -
superlu/memory.c | 230 -
superlu/mmd.c | 1021 -
superlu/relax_snode.c | 80 -
superlu/scolumn_bmod.c | 360 -
superlu/scolumn_dfs.c | 278 -
superlu/scomplex.c | 127 -
superlu/scopy_to_ucol.c | 112 -
superlu/scsum1.c | 111 -
superlu/sgscon.c | 155 -
superlu/sgsequ.c | 205 -
superlu/sgsrfs.c | 446 -
superlu/sgssv.c | 230 -
superlu/sgssvx.c | 623 -
superlu/sgstrf.c | 431 -
superlu/sgstrs.c | 331 -
superlu/slacon.c | 249 -
superlu/slamch.c | 1023 -
superlu/slangs.c | 131 -
superlu/slaqgs.c | 157 -
superlu/slu_Cnames.h | 356 -
superlu/slu_cdefs.h | 246 -
superlu/slu_dcomplex.h | 93 -
superlu/slu_ddefs.h | 243 -
superlu/slu_scomplex.h | 93 -
superlu/slu_sdefs.h | 243 -
superlu/slu_util.h | 287 -
superlu/slu_zdefs.h | 246 -
superlu/smemory.c | 689 -
superlu/smyblas2.c | 245 -
superlu/sp_coletree.c | 354 -
superlu/sp_ienv.c | 86 -
superlu/sp_preorder.c | 224 -
superlu/spanel_bmod.c | 462 -
superlu/spanel_dfs.c | 256 -
superlu/spivotL.c | 182 -
superlu/spivotgrowth.c | 129 -
superlu/spruneL.c | 156 -
superlu/sreadhb.c | 276 -
superlu/ssnode_bmod.c | 115 -
superlu/ssnode_dfs.c | 113 -
superlu/ssp_blas2.c | 481 -
superlu/ssp_blas3.c | 140 -
superlu/superlu_timer.c | 76 -
superlu/supermatrix.h | 165 -
superlu/sutil.c | 478 -
superlu/util.c | 405 -
superlu/xerbla.c | 83 -
superlu/zcolumn_bmod.c | 363 -
superlu/zcolumn_dfs.c | 266 -
superlu/zcopy_to_ucol.c | 112 -
superlu/zgscon.c | 152 -
superlu/zgsequ.c | 205 -
superlu/zgsrfs.c | 456 -
superlu/zgssv.c | 230 -
superlu/zgssvx.c | 623 -
superlu/zgstrf.c | 432 -
superlu/zgstrs.c | 344 -
superlu/zlacon.c | 236 -
superlu/zlangs.c | 131 -
superlu/zlaqgs.c | 159 -
superlu/zmemory.c | 689 -
superlu/zmyblas2.c | 203 -
superlu/zpanel_bmod.c | 477 -
superlu/zpanel_dfs.c | 256 -
superlu/zpivotL.c | 171 -
superlu/zpivotgrowth.c | 129 -
superlu/zpruneL.c | 156 -
superlu/zreadhb.c | 286 -
superlu/zsnode_bmod.c | 129 -
superlu/zsnode_dfs.c | 113 -
superlu/zsp_blas2.c | 576 -
superlu/zsp_blas3.c | 140 -
superlu/zutil.c | 482 -
303 files changed, 160 insertions(+), 128228 deletions(-)
diff --git a/Makefile.am b/Makefile.am
index 95b0d912..34b1bb34 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -18,7 +18,7 @@
ACLOCAL_AMFLAGS = -I m4
-SUBDIRS = m4 cubature @SUPERLU_SRC@ src tests interface contrib bin doc
+SUBDIRS = m4 cubature src tests interface contrib bin doc
EXTRA_DIST = GNU_LGPL_V3 GNU_GPL_V3 GNU_GCC_RUNTIME_EXCEPTION GNU_FDL_V3
diff --git a/configure.ac b/configure.ac
index 018bfd86..16a854de 100644
--- a/configure.ac
+++ b/configure.ac
@@ -37,7 +37,7 @@ AC_DEFINE_UNQUOTED([PATCH_VERSION],$PATCH_VERSION,[Patch
version number])
AC_CONFIG_SRCDIR([install-sh])
AC_CONFIG_MACRO_DIR([m4])
-AC_CONFIG_HEADER(config.h)
+AC_CONFIG_HEADERS(config.h)
AX_PREFIX_CONFIG_H(src/getfem/getfem_arch_config.h,GETFEM)
AX_PREFIX_CONFIG_H(src/gmm/gmm_arch_config.h,GMM)
AC_PREREQ(2.61)
@@ -58,7 +58,7 @@ dnl set the optimization level
dnl --------------------------
AC_ARG_WITH(optimization,
- AC_HELP_STRING([--with-optimization=FLAG],[Set the optimization
level (-O3 by default)]),
+ AS_HELP_STRING([--with-optimization=FLAG],[Set the optimization
level (-O3 by default)]),
[with_optimization=$withval],
[with_optimization='-O3']
)
@@ -763,84 +763,85 @@ dnl ---------------------------END OF
OPENMP-----------------------
dnl ------------------------------SuperLU config-------------------------
+require_superlu="auto"
AC_ARG_ENABLE(superlu,
- [AS_HELP_STRING([--enable-superlu],[turn on/off SuperLU support])],
- [case "${enableval}" in
- yes) usesuperlu=YES ;;
- no) usesuperlu=NO ;;
- *) AC_MSG_ERROR([bad value ${enableval} for --enable-superlu]) ;;
- esac],[usesuperlu=YES])
-
-SUPERLU_CPPFLAGS=""
-SUPERLU_SRC=""
-SUPERLU_LIBS=""
-SUPERLU_MAKEFILE=""
-
-if test x$usesuperlu = xYES; then
- echo "Building with SuperLU support (use --enable-superlu=no to disable it)"
- if test x"$FC" = "x"; then
- sgemm="sgemm_"
- else
- AC_FC_FUNC(sgemm)
- echo "FC=$FC"
- fi
- case $sgemm in
- sgemm)
- F77_CALL_C="NOCHANGE";
- ;;
- sgemm_)
- F77_CALL_C="ADD_";
- ;;
- SGEMM)
- F77_CALL_C="UPCASE";
- ;;
- sgemm__)
- F77_CALL_C="ADD__";
- ;;
- *)
- AC_MSG_ERROR(["superlu won't handle this calling convention: sgemm
-> $sgemm"])
- ;;
- esac
- SUPERLU_CPPFLAGS="$CPPFLAGS -DUSE_VENDOR_BLAS -DF77_CALL_C=$F77_CALL_C"
- SUPERLU_SRC="superlu"
- case $host in
- *apple*)
- SUPERLU_LIBS="../$SUPERLU_SRC/libsuperlu.la"
- ;;
- *mingw*)
- SUPERLU_LIBS="../$SUPERLU_SRC/.libs/libsuperlu.a"
- ;;
- *)
- SUPERLU_LIBS="`readlink -f .`/$SUPERLU_SRC/libsuperlu.la"
- ;;
- esac
- SUPERLU_MAKEFILE="$SUPERLU_SRC/Makefile"
-else
- echo "Building without SuperLU support (use --enable-superlu=yes to enable
it)"
- AC_CHECK_LIB([superlu], [dCreate_CompCol_Matrix],[],
- [AC_MSG_ERROR([SuperLU library not found])])
+ [AS_HELP_STRING([--enable-superlu], [Enable SuperLU support])],
+ [require_superlu=$enableval],
+ [require_superlu="auto"])
+
+SUPERLU_LIBS="-lsuperlu"
+# the user can override these defaults using --with-superlu=
+AC_ARG_WITH(superlu,
+ [AS_HELP_STRING([--with-superlu=<lib>],[use SuperLU library <lib>])],
+ [case $with_superlu in
+ yes | "")
+ if test "x$require_superlu" = "xno"; then
+ AC_MSG_ERROR([Contradicting arguments between --enable-superlu and
--with-superlu.])
+ elif test "x$require_superlu" = "xauto"; then
+ require_superlu="yes"
+ fi;;
+ no)
+ if test "x$require_superlu" = "xyes"; then
+ AC_MSG_ERROR([Contradicting arguments between --enable-superlu and
--with-superlu.])
+ elif test "x$require_superlu" = "xauto"; then
+ require_superlu="no"
+ fi;;
+ -* | */* | *.a | *.so | *.so.* | *.o| builtin)
SUPERLU_LIBS="$with_superlu";;
+ *) SUPERLU_LIBS=`echo $with_superlu | sed -e 's/^/-l/g;s/ \+/ -l/g'`;;
+ esac]
+)
- AC_CHECK_HEADERS(
- [superlu/colamd.h superlu/slu_Cnames.h \
- superlu/slu_cdefs.h superlu/slu_ddefs.h superlu/slu_sdefs.h
superlu/slu_zdefs.h \
- superlu/slu_dcomplex.h superlu/slu_scomplex.h],
- [usesuperlu="YES"],
- [
- if test "x$usesuperlu" = "xYES"; then
- AC_MSG_ERROR([header files of superlu not found. Use
--enable-superlu=yes flag]);
- fi;
- ])
+SUPERLUINC=""
+AC_ARG_WITH(superlu-include-dir,
+ [AS_HELP_STRING([--with-superlu-include-dir],[directory in which the
superlu/sl*.h headers can be found])],
+ [ if test x$require_superlu = xno; then
+ AC_MSG_ERROR([Inconsistent options for --enable-superlu, --with-superlu
and --with-superlu-include-dir.]);
+ else
+ require_superlu="yes"
+ case $withval in
+ -I* ) SUPERLUINC="$withval";;
+ * ) SUPERLUINC="-I$withval";;
+ esac
+ fi;],
+)
+CPPFLAGS="$CPPFLAGS $SUPERLUINC"
- SUPERLU_LIBS="-lsuperlu"
- LIBS="$SUPERLU_LIBS $LIBS"
+if test "x$require_superlu" = "xno"; then
+ echo "Building with SuperLU explicitly disabled";
+else
+ AC_CHECK_HEADERS(
+ [superlu/slu_Cnames.h superlu/slu_cdefs.h superlu/slu_ddefs.h
superlu/slu_sdefs.h superlu/slu_zdefs.h \
+ superlu/slu_dcomplex.h superlu/slu_scomplex.h],
+ [found_superlu="yes"],
+ [ if test "x$require_superlu" = "xyes"; then
+ AC_MSG_ERROR([Header files of SuperLU not found.]);
+ else
+ found_superlu="no"
+ fi;
+ ])
+ if test x$found_superlu = xyes; then
+ save_LIBS="$LIBS";
+ AC_CHECK_LIB([superlu], [dCreate_CompCol_Matrix],[],
+ [if test "x$require_superlu" = "xyes"; then
+ AC_MSG_ERROR([SuperLU library not found]);
+ else
+ found_superlu="no"
+ fi;])
+ if test "x$found_superlu" = "xyes"; then
+ echo "Building with SuperLU (use --enable-superlu=no to disable it)"
+ LIBS="$SUPERLU_LIBS $save_LIBS"
+ else
+ SUPERLU_LIBS=""
+ LIBS="$save_LIBS"
+ fi
+ fi
fi
-AC_SUBST([SUPERLU_CPPFLAGS])
-AC_SUBST([SUPERLU_SRC])
+AM_CONDITIONAL(SUPERLU, test x$found_superlu = xyes)
AC_SUBST([SUPERLU_LIBS])
-AM_CONDITIONAL(USEBLASLITE, test x$HAVE_VENDOR_BLAS = x0)
-echo "Configuration of SuperLU done"
-
+if test "x$found_superlu" = "xyes"; then
+ echo "Configuration of SuperLU done"
+fi
dnl ----------------EXPERIMENTAL PARTS OF THE LIBRARY--------------------
EXPER=""
@@ -931,6 +932,40 @@ echo "Configuration of qhull done"
dnl -----------------------------END OF QHULL TEST---------------------------
dnl ------------------------------MUMPS TEST------------------------------
+require_mumps="auto"
+AC_ARG_ENABLE(mumps,
+ [AS_HELP_STRING([--enable-mumps], [Enable MUMPS support])],
+ [require_mumps=$enableval],
+ [require_mumps="auto"])
+
+MUMPS_LIBS=""
+# the user can override these defaults using --with-mumps=
+if test $paralevel -le 1; then # default to the typical naming of the
sequential libraries
+ MUMPS_LIBS="-lsmumps_seq -ldmumps_seq -lcmumps_seq -lzmumps_seq"
+else # default to the common name for the parallel libraries (the user can
override this using --with-mumps=)
+ MUMPS_LIBS="-lsmumps -ldmumps -lcmumps -lzmumps"
+fi
+
+AC_ARG_WITH(mumps,
+ [AS_HELP_STRING([--with-mumps=<lib>],[use MUMPS library <lib>])],
+ [case $with_mumps in
+ yes | "")
+ if test "x$require_mumps" = "xno"; then
+ AC_MSG_ERROR([Contradicting arguments between --enable-mumps and
--with-mumps.])
+ elif test "x$require_mumps" = "xauto"; then
+ require_mumps="yes"
+ fi;;
+ no)
+ if test "x$require_mumps" = "xyes"; then
+ AC_MSG_ERROR([Contradicting arguments between --enable-(par-)mumps and
--with-mumps.])
+ elif test "x$require_mumps" = "xauto"; then
+ require_mumps="no"
+ fi;;
+ -* | */* | *.a | *.so | *.so.* | *.o| builtin) MUMPS_LIBS="$with_mumps";;
+ *) MUMPS_LIBS=`echo $with_mumps | sed -e 's/^/-l/g;s/ \+/ -l/g'`;;
+ esac]
+)
+
MUMPSINC=""
AC_ARG_WITH(mumps-include-dir,
[AS_HELP_STRING([--with-mumps-include-dir],[directory in which the dmumps.h
header can be found])],
@@ -938,95 +973,50 @@ AC_ARG_WITH(mumps-include-dir,
-I* ) MUMPSINC="$withval";;
* ) MUMPSINC="-I$withval";;
esac],
- [MUMPSINC="-I$GFPREFIX/include"]
)
CPPFLAGS="$CPPFLAGS $MUMPSINC"
-MUMPS_LIBS=""
-case $host in
- *mingw*)
- MUMPS_SEQ_LIBS="-lsmumps -ldmumps -lcmumps -lzmumps -lmumps_common
-lmpiseq -lpord"
- ;;
- *apple*)
- MUMPS_SEQ_LIBS="-lsmumps -ldmumps -lcmumps -lzmumps -lmumps_common
-lmpiseq -lpord -lgomp"
- ;;
- *)
- MUMPS_SEQ_LIBS="-lsmumps_seq -ldmumps_seq -lcmumps_seq -lzmumps_seq"
- ;;
-esac
-acx_mumps_ok="no"
-usemumps="no"
-AC_ARG_ENABLE(mumps,
- [AS_HELP_STRING([--enable-mumps],[enable the use of the (sequential) MUMPS
library. A direct solver for large sparse linear systems.])],
- [case $enableval in
- yes | "") usemumps="yes"; acx_mumps_ok="yes"; MUMPS_LIBS="$MUMPS_SEQ_LIBS";;
- no) usemumps="no";;
- esac],
- [usemumps="test"; acx_mumps_ok="test"; MUMPS_LIBS="$MUMPS_SEQ_LIBS"]
-)
-
-AC_ARG_ENABLE(par-mumps,
- [AS_HELP_STRING([--enable-par-mumps],[enable the use of the parrallel MUMPS
library. A direct solver for large sparse linear systems.])],
- [case $enableval in
- yes | "") usemumps="yes"; MUMPS_LIBS="-lsmumps -ldmumps -lcmumps -lzmumps";;
- no) usemumps="no";;
- esac],
- [if test $paralevel -ge 1; then
- usemumps="test"; acx_mumps_ok="test"; MUMPS_LIBS="-lsmumps -ldmumps
-lcmumps -lzmumps"
- fi;]
-)
-
-AC_ARG_WITH(mumps,
- [AS_HELP_STRING([--with-mumps=<lib>],[use MUMPS library <lib>])],
- [case $with_mumps in
- yes | "") usemumps="yes";;
- no) acx_mumps_ok="no" ;;
- -* | */* | *.a | *.so | *.so.* | *.o| builtin) MUMPS_LIBS="$with_mumps";
acx_mumps_ok="yes" ;;
- *) MUMPS_LIBS=`echo $with_mumps | sed -e 's/^/-l/g;s/ \+/ -l/g'` ;
usemumps="yes";;
- esac]
-)
-
save_LIBS="$LIBS";
-if test "x$usemumps" = "xno" -o "x$acx_mumps_ok" = "xno"; then
+if test "x$require_mumps" = "xno"; then
echo "Building with MUMPS explicitly disabled";
else
AC_SEARCH_LIBS(smumps_c, [`echo $MUMPS_LIBS | sed -e 's/^-l//g;s/ -l/ /g'`],
- [usemumps="yes"],
- [if test "x$acx_mumps_ok" = "xyes"; then
+ [found_mumps="yes"],
+ [if test "x$require_mumps" = "xyes"; then
AC_MSG_ERROR([The function smumps_c couldn't be found in the provided
MUMPS libraries.]);
fi;
- usemumps="no"]
+ found_mumps="no"]
)
AC_SEARCH_LIBS(dmumps_c, [`echo $MUMPS_LIBS | sed -e 's/^-l//g;s/ -l/ /g'`],
- [usemumps="yes"],
- [if test "x$acx_mumps_ok" = "xyes"; then
+ [found_mumps="yes"],
+ [if test "x$require_mumps" = "xyes"; then
AC_MSG_ERROR([The function dmumps_c couldn't be found in the provided
MUMPS libraries.]);
fi;
- usemumps="no"]
+ found_mumps="no"]
)
AC_SEARCH_LIBS(cmumps_c, [`echo $MUMPS_LIBS | sed -e 's/^-l//g;s/ -l/ /g'`],
- [usemumps="yes"],
- [if test "x$acx_mumps_ok" = "xyes"; then
+ [found_mumps="yes"],
+ [if test "x$require_mumps" = "xyes"; then
AC_MSG_ERROR([The function cmumps_c couldn't be found in the provided
MUMPS libraries.]);
fi;
- usemumps="no"]
+ found_mumps="no"]
)
AC_SEARCH_LIBS(zmumps_c, [`echo $MUMPS_LIBS | sed -e 's/^-l//g;s/ -l/ /g'`],
- [usemumps="yes"],
- [if test "x$acx_mumps_ok" = "xyes"; then
+ [found_mumps="yes"],
+ [if test "x$require_mumps" = "xyes"; then
AC_MSG_ERROR([The function zmumps_c couldn't be found in the provided
MUMPS libraries.]);
fi;
- usemumps="no"]
+ found_mumps="no"]
)
AC_CHECK_HEADERS([smumps_c.h dmumps_c.h cmumps_c.h zmumps_c.h],
- [usemumps="yes"],
- [if test "x$acx_mumps_ok" = "xyes"; then
+ [found_mumps="yes"],
+ [if test "x$require_mumps" = "xyes"; then
AC_MSG_ERROR([header file dmumps_c.h not found.]);
fi;
- usemumps="no"]
+ found_mumps="no"]
)
- if test "x$usemumps" = "xyes"; then
+ if test "x$found_mumps" = "xyes"; then
echo "Building with MUMPS (use --enable-mumps=no to disable it)"
LIBS="$MUMPS_LIBS $save_LIBS"
else
@@ -1035,9 +1025,11 @@ else
fi;
fi;
-AM_CONDITIONAL(MUMPS, test x$usemumps = xyes)
+AM_CONDITIONAL(MUMPS, test x$found_mumps = xyes)
AC_SUBST([MUMPS_LIBS])
-echo "Configuration of MUMPS done"
+if test "x$found_mumps" = "xyes"; then
+ echo "Configuration of MUMPS done"
+fi
dnl ---------------------------END OF MUMPS TEST--------------------------
dnl ---------------------------METIS--------------------------
@@ -1091,7 +1083,7 @@ AC_SUBST([METIS_LIBS])
dnl ---------------------------END OF METIS--------------------------
-AC_CHECK_HEADERS(sys/times.h,[],[SUPERLU_CPPFLAGS="$SUPERLU_CPPFLAGS
-DNO_TIMER"])
+AC_CHECK_HEADERS(sys/times.h)
AC_CHECK_HEADERS(cxxabi.h)
dnl ---------------------------- CHECK FOR __PRETTY_FUNCTION__ MACRO --------
AC_CACHE_CHECK([for __PRETTY_FUNCTION__], ac_cv_have_pretty_function, [
@@ -1163,7 +1155,6 @@ AC_CONFIG_FILES(
\
Makefile \
m4/Makefile \
cubature/Makefile \
-$SUPERLU_MAKEFILE \
doc/Makefile \
doc/sphinx/Makefile \
src/Makefile \
@@ -1245,10 +1236,24 @@ else
echo "- Qhull not found. Mesh generation will be disabled."
fi;
-if test "x$usemumps" = "xyes"; then
+if test "x$found_superlu" = "xyes"; then
+ echo "- SuperLU found. A direct solver for large sparse linear systems."
+else
+ if test "x$require_superlu" = "xno"; then
+ echo "- Not using the SuperLU library for large sparse linear systems."
+ else
+ echo "- SuperLU not found. Not using the SuperLU library for large sparse
linear systems."
+ fi
+fi;
+
+if test "x$found_mumps" = "xyes"; then
echo "- Mumps found. A direct solver for large sparse linear systems."
else
- echo "- Mumps not found. Not using the MUMPS library for large sparse linear
systems."
+ if test "x$require_superlu" = "xno"; then
+ echo "- Not using the MUMPS library for large sparse linear systems."
+ else
+ echo "- Mumps not found. Not using the MUMPS library for large sparse
linear systems."
+ fi
fi;
if test x"$acx_lapack_ok" = xyes; then
diff --git a/contrib/continuum_mechanics/Makefile.am
b/contrib/continuum_mechanics/Makefile.am
index dc5d9fc1..879ec8a9 100644
--- a/contrib/continuum_mechanics/Makefile.am
+++ b/contrib/continuum_mechanics/Makefile.am
@@ -22,8 +22,6 @@ EXTRA_DIST = \
check_PROGRAMS =
-CLEANFILES =
-
if BUILDPYTHON
TESTS = plasticity_fin_strain_lin_hardening_plane_strain.py
diff --git a/m4/ax_boost_base.m4 b/m4/ax_boost_base.m4
deleted file mode 100644
index 8e6ee9a9..00000000
--- a/m4/ax_boost_base.m4
+++ /dev/null
@@ -1,272 +0,0 @@
-# ===========================================================================
-# http://www.gnu.org/software/autoconf-archive/ax_boost_base.html
-# ===========================================================================
-#
-# SYNOPSIS
-#
-# AX_BOOST_BASE([MINIMUM-VERSION], [ACTION-IF-FOUND], [ACTION-IF-NOT-FOUND])
-#
-# DESCRIPTION
-#
-# Test for the Boost C++ libraries of a particular version (or newer)
-#
-# If no path to the installed boost library is given the macro searchs
-# under /usr, /usr/local, /opt and /opt/local and evaluates the
-# $BOOST_ROOT environment variable. Further documentation is available at
-# <http://randspringer.de/boost/index.html>.
-#
-# This macro calls:
-#
-# AC_SUBST(BOOST_CPPFLAGS) / AC_SUBST(BOOST_LDFLAGS)
-#
-# And sets:
-#
-# HAVE_BOOST
-#
-# LICENSE
-#
-# Copyright (c) 2008 Thomas Porschberg <thomas@randspringer.de>
-# Copyright (c) 2009 Peter Adolphs
-#
-# Copying and distribution of this file, with or without modification, are
-# permitted in any medium without royalty provided the copyright notice
-# and this notice are preserved. This file is offered as-is, without any
-# warranty.
-
-#serial 23
-
-AC_DEFUN([AX_BOOST_BASE],
-[
-AC_ARG_WITH([boost],
- [AS_HELP_STRING([--with-boost@<:@=ARG@:>@],
- [use Boost library from a standard location (ARG=yes),
- from the specified location (ARG=<path>),
- or disable it (ARG=no)
- @<:@ARG=yes@:>@ ])],
- [
- if test "$withval" = "no"; then
- want_boost="no"
- elif test "$withval" = "yes"; then
- want_boost="yes"
- ac_boost_path=""
- else
- want_boost="yes"
- ac_boost_path="$withval"
- fi
- ],
- [want_boost="yes"])
-
-
-AC_ARG_WITH([boost-libdir],
- AS_HELP_STRING([--with-boost-libdir=LIB_DIR],
- [Force given directory for boost libraries. Note that this will
override library path detection, so use this parameter only if default library
detection fails and you know exactly where your boost libraries are located.]),
- [
- if test -d "$withval"
- then
- ac_boost_lib_path="$withval"
- else
- AC_MSG_ERROR(--with-boost-libdir expected directory name)
- fi
- ],
- [ac_boost_lib_path=""]
-)
-
-if test "x$want_boost" = "xyes"; then
- boost_lib_version_req=ifelse([$1], ,1.20.0,$1)
- boost_lib_version_req_shorten=`expr $boost_lib_version_req :
'\([[0-9]]*\.[[0-9]]*\)'`
- boost_lib_version_req_major=`expr $boost_lib_version_req : '\([[0-9]]*\)'`
- boost_lib_version_req_minor=`expr $boost_lib_version_req :
'[[0-9]]*\.\([[0-9]]*\)'`
- boost_lib_version_req_sub_minor=`expr $boost_lib_version_req :
'[[0-9]]*\.[[0-9]]*\.\([[0-9]]*\)'`
- if test "x$boost_lib_version_req_sub_minor" = "x" ; then
- boost_lib_version_req_sub_minor="0"
- fi
- WANT_BOOST_VERSION=`expr $boost_lib_version_req_major \* 100000 \+
$boost_lib_version_req_minor \* 100 \+ $boost_lib_version_req_sub_minor`
- AC_MSG_CHECKING(for boostlib >= $boost_lib_version_req)
- succeeded=no
-
- dnl On 64-bit systems check for system libraries in both lib64 and lib.
- dnl The former is specified by FHS, but e.g. Debian does not adhere to
- dnl this (as it rises problems for generic multi-arch support).
- dnl The last entry in the list is chosen by default when no libraries
- dnl are found, e.g. when only header-only libraries are installed!
- libsubdirs="lib"
- ax_arch=`uname -m`
- case $ax_arch in
- x86_64|ppc64|s390x|sparc64|aarch64)
- libsubdirs="lib64 lib lib64"
- ;;
- esac
-
- dnl allow for real multi-arch paths e.g. /usr/lib/x86_64-linux-gnu. Give
- dnl them priority over the other paths since, if libs are found there, they
- dnl are almost assuredly the ones desired.
- AC_REQUIRE([AC_CANONICAL_HOST])
- libsubdirs="lib/${host_cpu}-${host_os} $libsubdirs"
-
- case ${host_cpu} in
- i?86)
- libsubdirs="lib/i386-${host_os} $libsubdirs"
- ;;
- esac
-
- dnl first we check the system location for boost libraries
- dnl this location ist chosen if boost libraries are installed with the
--layout=system option
- dnl or if you install boost with RPM
- if test "$ac_boost_path" != ""; then
- BOOST_CPPFLAGS="-I$ac_boost_path/include"
- for ac_boost_path_tmp in $libsubdirs; do
- if test -d "$ac_boost_path"/"$ac_boost_path_tmp" ; then
- BOOST_LDFLAGS="-L$ac_boost_path/$ac_boost_path_tmp"
- break
- fi
- done
- elif test "$cross_compiling" != yes; then
- for ac_boost_path_tmp in /usr /usr/local /opt /opt/local ; do
- if test -d "$ac_boost_path_tmp/include/boost" && test -r
"$ac_boost_path_tmp/include/boost"; then
- for libsubdir in $libsubdirs ; do
- if ls "$ac_boost_path_tmp/$libsubdir/libboost_"*
>/dev/null 2>&1 ; then break; fi
- done
- BOOST_LDFLAGS="-L$ac_boost_path_tmp/$libsubdir"
- BOOST_CPPFLAGS="-I$ac_boost_path_tmp/include"
- break;
- fi
- done
- fi
-
- dnl overwrite ld flags if we have required special directory with
- dnl --with-boost-libdir parameter
- if test "$ac_boost_lib_path" != ""; then
- BOOST_LDFLAGS="-L$ac_boost_lib_path"
- fi
-
- CPPFLAGS_SAVED="$CPPFLAGS"
- CPPFLAGS="$CPPFLAGS $BOOST_CPPFLAGS"
- export CPPFLAGS
-
- LDFLAGS_SAVED="$LDFLAGS"
- LDFLAGS="$LDFLAGS $BOOST_LDFLAGS"
- export LDFLAGS
-
- AC_REQUIRE([AC_PROG_CXX])
- AC_LANG_PUSH(C++)
- AC_COMPILE_IFELSE([AC_LANG_PROGRAM([[
- @%:@include <boost/version.hpp>
- ]], [[
- #if BOOST_VERSION >= $WANT_BOOST_VERSION
- // Everything is okay
- #else
- # error Boost version is too old
- #endif
- ]])],[
- AC_MSG_RESULT(yes)
- succeeded=yes
- found_system=yes
- ],[
- ])
- AC_LANG_POP([C++])
-
-
-
- dnl if we found no boost with system layout we search for boost libraries
- dnl built and installed without the --layout=system option or for a
staged(not installed) version
- if test "x$succeeded" != "xyes"; then
- _version=0
- if test "$ac_boost_path" != ""; then
- if test -d "$ac_boost_path" && test -r "$ac_boost_path"; then
- for i in `ls -d $ac_boost_path/include/boost-* 2>/dev/null`; do
- _version_tmp=`echo $i | sed "s#$ac_boost_path##" | sed
's/\/include\/boost-//' | sed 's/_/./'`
- V_CHECK=`expr $_version_tmp \> $_version`
- if test "$V_CHECK" = "1" ; then
- _version=$_version_tmp
- fi
- VERSION_UNDERSCORE=`echo $_version | sed 's/\./_/'`
-
BOOST_CPPFLAGS="-I$ac_boost_path/include/boost-$VERSION_UNDERSCORE"
- done
- fi
- else
- if test "$cross_compiling" != yes; then
- for ac_boost_path in /usr /usr/local /opt /opt/local ; do
- if test -d "$ac_boost_path" && test -r "$ac_boost_path";
then
- for i in `ls -d $ac_boost_path/include/boost-*
2>/dev/null`; do
- _version_tmp=`echo $i | sed "s#$ac_boost_path##" |
sed 's/\/include\/boost-//' | sed 's/_/./'`
- V_CHECK=`expr $_version_tmp \> $_version`
- if test "$V_CHECK" = "1" ; then
- _version=$_version_tmp
- best_path=$ac_boost_path
- fi
- done
- fi
- done
-
- VERSION_UNDERSCORE=`echo $_version | sed 's/\./_/'`
- BOOST_CPPFLAGS="-I$best_path/include/boost-$VERSION_UNDERSCORE"
- if test "$ac_boost_lib_path" = ""; then
- for libsubdir in $libsubdirs ; do
- if ls "$best_path/$libsubdir/libboost_"* >/dev/null
2>&1 ; then break; fi
- done
- BOOST_LDFLAGS="-L$best_path/$libsubdir"
- fi
- fi
-
- if test "x$BOOST_ROOT" != "x"; then
- for libsubdir in $libsubdirs ; do
- if ls "$BOOST_ROOT/stage/$libsubdir/libboost_"* >/dev/null
2>&1 ; then break; fi
- done
- if test -d "$BOOST_ROOT" && test -r "$BOOST_ROOT" && test -d
"$BOOST_ROOT/stage/$libsubdir" && test -r "$BOOST_ROOT/stage/$libsubdir"; then
- version_dir=`expr //$BOOST_ROOT : '.*/\(.*\)'`
- stage_version=`echo $version_dir | sed 's/boost_//' | sed
's/_/./g'`
- stage_version_shorten=`expr $stage_version :
'\([[0-9]]*\.[[0-9]]*\)'`
- V_CHECK=`expr $stage_version_shorten \>\= $_version`
- if test "$V_CHECK" = "1" -a "$ac_boost_lib_path" = "" ;
then
- AC_MSG_NOTICE(We will use a staged boost library from
$BOOST_ROOT)
- BOOST_CPPFLAGS="-I$BOOST_ROOT"
- BOOST_LDFLAGS="-L$BOOST_ROOT/stage/$libsubdir"
- fi
- fi
- fi
- fi
-
- CPPFLAGS="$CPPFLAGS $BOOST_CPPFLAGS"
- export CPPFLAGS
- LDFLAGS="$LDFLAGS $BOOST_LDFLAGS"
- export LDFLAGS
-
- AC_LANG_PUSH(C++)
- AC_COMPILE_IFELSE([AC_LANG_PROGRAM([[
- @%:@include <boost/version.hpp>
- ]], [[
- #if BOOST_VERSION >= $WANT_BOOST_VERSION
- // Everything is okay
- #else
- # error Boost version is too old
- #endif
- ]])],[
- AC_MSG_RESULT(yes)
- succeeded=yes
- found_system=yes
- ],[
- ])
- AC_LANG_POP([C++])
- fi
-
- if test "$succeeded" != "yes" ; then
- if test "$_version" = "0" ; then
- AC_MSG_NOTICE([[We could not detect the boost libraries (version
$boost_lib_version_req_shorten or higher). If you have a staged boost library
(still not installed) please specify \$BOOST_ROOT in your environment and do
not give a PATH to --with-boost option. If you are sure you have boost
installed, then check your version number looking in <boost/version.hpp>. See
http://randspringer.de/boost for more documentation.]])
- else
- AC_MSG_NOTICE([Your boost libraries seems to old (version
$_version).])
- fi
- # execute ACTION-IF-NOT-FOUND (if present):
- ifelse([$3], , :, [$3])
- else
- AC_SUBST(BOOST_CPPFLAGS)
- AC_SUBST(BOOST_LDFLAGS)
- AC_DEFINE(HAVE_BOOST,,[define if the Boost library is available])
- # execute ACTION-IF-FOUND (if present):
- ifelse([$2], , :, [$2])
- fi
-
- CPPFLAGS="$CPPFLAGS_SAVED"
- LDFLAGS="$LDFLAGS_SAVED"
-fi
-
-])
diff --git a/m4/ax_boost_system.m4 b/m4/ax_boost_system.m4
deleted file mode 100644
index c4c45559..00000000
--- a/m4/ax_boost_system.m4
+++ /dev/null
@@ -1,120 +0,0 @@
-# ===========================================================================
-# http://www.gnu.org/software/autoconf-archive/ax_boost_system.html
-# ===========================================================================
-#
-# SYNOPSIS
-#
-# AX_BOOST_SYSTEM
-#
-# DESCRIPTION
-#
-# Test for System library from the Boost C++ libraries. The macro requires
-# a preceding call to AX_BOOST_BASE. Further documentation is available at
-# <http://randspringer.de/boost/index.html>.
-#
-# This macro calls:
-#
-# AC_SUBST(BOOST_SYSTEM_LIB)
-#
-# And sets:
-#
-# HAVE_BOOST_SYSTEM
-#
-# LICENSE
-#
-# Copyright (c) 2008 Thomas Porschberg <thomas@randspringer.de>
-# Copyright (c) 2008 Michael Tindal
-# Copyright (c) 2008 Daniel Casimiro <dan.casimiro@gmail.com>
-#
-# Copying and distribution of this file, with or without modification, are
-# permitted in any medium without royalty provided the copyright notice
-# and this notice are preserved. This file is offered as-is, without any
-# warranty.
-
-#serial 17
-
-AC_DEFUN([AX_BOOST_SYSTEM],
-[
- AC_ARG_WITH([boost-system],
- AS_HELP_STRING([--with-boost-system@<:@=special-lib@:>@],
- [use the System library from boost - it is possible to
specify a certain library for the linker
- e.g. --with-boost-system=boost_system-gcc-mt ]),
- [
- if test "$withval" = "no"; then
- want_boost="no"
- elif test "$withval" = "yes"; then
- want_boost="yes"
- ax_boost_user_system_lib=""
- else
- want_boost="yes"
- ax_boost_user_system_lib="$withval"
- fi
- ],
- [want_boost="yes"]
- )
-
- if test "x$want_boost" = "xyes"; then
- AC_REQUIRE([AC_PROG_CC])
- AC_REQUIRE([AC_CANONICAL_BUILD])
- CPPFLAGS_SAVED="$CPPFLAGS"
- CPPFLAGS="$CPPFLAGS $BOOST_CPPFLAGS"
- export CPPFLAGS
-
- LDFLAGS_SAVED="$LDFLAGS"
- LDFLAGS="$LDFLAGS $BOOST_LDFLAGS"
- export LDFLAGS
-
- AC_CACHE_CHECK(whether the Boost::System library is available,
- ax_cv_boost_system,
- [AC_LANG_PUSH([C++])
- CXXFLAGS_SAVE=$CXXFLAGS
-
- AC_COMPILE_IFELSE([AC_LANG_PROGRAM([[@%:@include
<boost/system/error_code.hpp>]],
- [[boost::system::system_category]])],
- ax_cv_boost_system=yes, ax_cv_boost_system=no)
- CXXFLAGS=$CXXFLAGS_SAVE
- AC_LANG_POP([C++])
- ])
- if test "x$ax_cv_boost_system" = "xyes"; then
- AC_SUBST(BOOST_CPPFLAGS)
-
- AC_DEFINE(HAVE_BOOST_SYSTEM,,[define if the
Boost::System library is available])
- BOOSTLIBDIR=`echo $BOOST_LDFLAGS | sed -e 's/@<:@^\/@:>@*//'`
-
- LDFLAGS_SAVE=$LDFLAGS
- if test "x$ax_boost_user_system_lib" = "x"; then
- for libextension in `ls -r $BOOSTLIBDIR/libboost_system*
2>/dev/null | sed 's,.*/lib,,' | sed 's,\..*,,'` ; do
- ax_lib=${libextension}
- AC_CHECK_LIB($ax_lib, exit,
- [BOOST_SYSTEM_LIB="-l$ax_lib";
AC_SUBST(BOOST_SYSTEM_LIB) link_system="yes"; break],
- [link_system="no"])
- done
- if test "x$link_system" != "xyes"; then
- for libextension in `ls -r $BOOSTLIBDIR/boost_system*
2>/dev/null | sed 's,.*/,,' | sed -e 's,\..*,,'` ; do
- ax_lib=${libextension}
- AC_CHECK_LIB($ax_lib, exit,
- [BOOST_SYSTEM_LIB="-l$ax_lib";
AC_SUBST(BOOST_SYSTEM_LIB) link_system="yes"; break],
- [link_system="no"])
- done
- fi
-
- else
- for ax_lib in $ax_boost_user_system_lib
boost_system-$ax_boost_user_system_lib; do
- AC_CHECK_LIB($ax_lib, exit,
- [BOOST_SYSTEM_LIB="-l$ax_lib";
AC_SUBST(BOOST_SYSTEM_LIB) link_system="yes"; break],
- [link_system="no"])
- done
-
- fi
- if test "x$ax_lib" = "x"; then
- AC_MSG_ERROR(Could not find a version of the library!)
- fi
- if test "x$link_system" = "xno"; then
- AC_MSG_ERROR(Could not link against $ax_lib !)
- fi
- fi
-
- CPPFLAGS="$CPPFLAGS_SAVED"
- LDFLAGS="$LDFLAGS_SAVED"
- fi
-])
diff --git a/m4/ax_boost_thread.m4 b/m4/ax_boost_thread.m4
deleted file mode 100644
index 79e12cdb..00000000
--- a/m4/ax_boost_thread.m4
+++ /dev/null
@@ -1,149 +0,0 @@
-# ===========================================================================
-# http://www.gnu.org/software/autoconf-archive/ax_boost_thread.html
-# ===========================================================================
-#
-# SYNOPSIS
-#
-# AX_BOOST_THREAD
-#
-# DESCRIPTION
-#
-# Test for Thread library from the Boost C++ libraries. The macro requires
-# a preceding call to AX_BOOST_BASE. Further documentation is available at
-# <http://randspringer.de/boost/index.html>.
-#
-# This macro calls:
-#
-# AC_SUBST(BOOST_THREAD_LIB)
-#
-# And sets:
-#
-# HAVE_BOOST_THREAD
-#
-# LICENSE
-#
-# Copyright (c) 2009 Thomas Porschberg <thomas@randspringer.de>
-# Copyright (c) 2009 Michael Tindal
-#
-# Copying and distribution of this file, with or without modification, are
-# permitted in any medium without royalty provided the copyright notice
-# and this notice are preserved. This file is offered as-is, without any
-# warranty.
-
-#serial 27
-
-AC_DEFUN([AX_BOOST_THREAD],
-[
- AC_ARG_WITH([boost-thread],
- AS_HELP_STRING([--with-boost-thread@<:@=special-lib@:>@],
- [use the Thread library from boost - it is possible to
specify a certain library for the linker
- e.g. --with-boost-thread=boost_thread-gcc-mt ]),
- [
- if test "$withval" = "no"; then
- want_boost="no"
- elif test "$withval" = "yes"; then
- want_boost="yes"
- ax_boost_user_thread_lib=""
- else
- want_boost="yes"
- ax_boost_user_thread_lib="$withval"
- fi
- ],
- [want_boost="yes"]
- )
-
- if test "x$want_boost" = "xyes"; then
- AC_REQUIRE([AC_PROG_CC])
- AC_REQUIRE([AC_CANONICAL_BUILD])
- CPPFLAGS_SAVED="$CPPFLAGS"
- CPPFLAGS="$CPPFLAGS $BOOST_CPPFLAGS"
- export CPPFLAGS
-
- LDFLAGS_SAVED="$LDFLAGS"
- LDFLAGS="$LDFLAGS $BOOST_LDFLAGS"
- export LDFLAGS
-
- AC_CACHE_CHECK(whether the Boost::Thread library is available,
- ax_cv_boost_thread,
- [AC_LANG_PUSH([C++])
- CXXFLAGS_SAVE=$CXXFLAGS
-
- if test "x$host_os" = "xsolaris" ; then
- CXXFLAGS="-pthreads $CXXFLAGS"
- elif test "x$host_os" = "xmingw32" ; then
- CXXFLAGS="-mthreads $CXXFLAGS"
- else
- CXXFLAGS="-pthread $CXXFLAGS"
- fi
- AC_COMPILE_IFELSE([AC_LANG_PROGRAM([[@%:@include
<boost/thread/thread.hpp>]],
- [[boost::thread_group thrds;
- return 0;]])],
- ax_cv_boost_thread=yes, ax_cv_boost_thread=no)
- CXXFLAGS=$CXXFLAGS_SAVE
- AC_LANG_POP([C++])
- ])
- if test "x$ax_cv_boost_thread" = "xyes"; then
- if test "x$host_os" = "xsolaris" ; then
- BOOST_CPPFLAGS="-pthreads $BOOST_CPPFLAGS"
- elif test "x$host_os" = "xmingw32" ; then
- BOOST_CPPFLAGS="-mthreads $BOOST_CPPFLAGS"
- else
- BOOST_CPPFLAGS="-pthread $BOOST_CPPFLAGS"
- fi
-
- AC_SUBST(BOOST_CPPFLAGS)
-
- AC_DEFINE(HAVE_BOOST_THREAD,,[define if the
Boost::Thread library is available])
- BOOSTLIBDIR=`echo $BOOST_LDFLAGS | sed -e 's/@<:@^\/@:>@*//'`
-
- LDFLAGS_SAVE=$LDFLAGS
- case "x$host_os" in
- *bsd* )
- LDFLAGS="-pthread $LDFLAGS"
- break;
- ;;
- esac
- if test "x$ax_boost_user_thread_lib" = "x"; then
- for libextension in `ls -r $BOOSTLIBDIR/libboost_thread*
2>/dev/null | sed 's,.*/lib,,' | sed 's,\..*,,'`; do
- ax_lib=${libextension}
- AC_CHECK_LIB($ax_lib, exit,
- [BOOST_THREAD_LIB="-l$ax_lib";
AC_SUBST(BOOST_THREAD_LIB) link_thread="yes"; break],
- [link_thread="no"])
- done
- if test "x$link_thread" != "xyes"; then
- for libextension in `ls -r $BOOSTLIBDIR/boost_thread*
2>/dev/null | sed 's,.*/,,' | sed 's,\..*,,'`; do
- ax_lib=${libextension}
- AC_CHECK_LIB($ax_lib, exit,
- [BOOST_THREAD_LIB="-l$ax_lib";
AC_SUBST(BOOST_THREAD_LIB) link_thread="yes"; break],
- [link_thread="no"])
- done
- fi
-
- else
- for ax_lib in $ax_boost_user_thread_lib
boost_thread-$ax_boost_user_thread_lib; do
- AC_CHECK_LIB($ax_lib, exit,
- [BOOST_THREAD_LIB="-l$ax_lib";
AC_SUBST(BOOST_THREAD_LIB) link_thread="yes"; break],
- [link_thread="no"])
- done
-
- fi
- if test "x$ax_lib" = "x"; then
- AC_MSG_ERROR(Could not find a version of the library!)
- fi
- if test "x$link_thread" = "xno"; then
- AC_MSG_ERROR(Could not link against $ax_lib !)
- else
- case "x$host_os" in
- *bsd* )
- BOOST_LDFLAGS="-pthread $BOOST_LDFLAGS"
- break;
- ;;
- esac
-
- fi
- fi
-
- CPPFLAGS="$CPPFLAGS_SAVED"
- LDFLAGS="$LDFLAGS_SAVED"
- fi
-])
diff --git a/m4/ax_prefix_config_h.m4 b/m4/ax_prefix_config_h.m4
index 2c662ef1..d4e97aec 100644
--- a/m4/ax_prefix_config_h.m4
+++ b/m4/ax_prefix_config_h.m4
@@ -83,7 +83,7 @@ dnl @version $Id$
dnl @author Guiodo Draheim <guidod@gmx.de>
dnl @License GPLV3
-AC_DEFUN([AX_PREFIX_CONFIG_H],[AC_REQUIRE([AC_CONFIG_HEADER])
+AC_DEFUN([AX_PREFIX_CONFIG_H],[AC_REQUIRE([AC_CONFIG_HEADERS])
AC_CONFIG_COMMANDS([ifelse($1,,$PACKAGE-config.h,$1)],[dnl
AS_VAR_PUSHDEF([_OUT],[ac_prefix_conf_OUT])dnl
AS_VAR_PUSHDEF([_DEF],[ac_prefix_conf_DEF])dnl
diff --git a/m4/scilab.m4 b/m4/scilab.m4
index 636989f4..32f75b31 100644
--- a/m4/scilab.m4
+++ b/m4/scilab.m4
@@ -27,19 +27,19 @@ AC_DEFUN([AC_CHECK_SCILAB],
esac],[usescilab=NO])
AC_ARG_WITH(scilab_prefix,
- AC_HELP_STRING([--with-scilab-prefix=DIR],[Set the path to
Scilab]),
+ AS_HELP_STRING([--with-scilab-prefix=DIR],[Set the path to
Scilab]),
[with_scilab_prefix=$withval],
[with_scilab_prefix='yes']
)
AC_ARG_WITH(scilab_version,
- AC_HELP_STRING([--with-scilab-version="major.minor.micro"],[Set
the required Scilab version]),
+ AS_HELP_STRING([--with-scilab-version="major.minor.micro"],[Set
the required Scilab version]),
[with_scilab_version=$withval],
[with_scilab_version='yes']
)
AC_ARG_WITH(scilab_toolbox_dir,
- AC_HELP_STRING([--with-scilab-toolbox-dir=DIR],[Set the path to
the toolbox installation directory]),
+ AS_HELP_STRING([--with-scilab-toolbox-dir=DIR],[Set the path to
the toolbox installation directory]),
[with_scilab_toolbox_dir=$withval],
[with_scilab_toolbox_dir='yes']
)
diff --git a/src/getfem_superlu.cc b/src/getfem_superlu.cc
index 4e7c3538..a29c0a70 100644
--- a/src/getfem_superlu.cc
+++ b/src/getfem_superlu.cc
@@ -121,11 +121,12 @@ namespace gmm {
FLOATTYPE *recip_pivot_growth,
\
FLOATTYPE *rcond, FLOATTYPE *ferr, FLOATTYPE
*berr, \
SuperLUStat_t *stats, int *info, KEYTYPE) {
\
- NAMESPACE::mem_usage_t mem_usage; \
+ mem_usage_t mem_usage;
\
+ GlobalLU_t Glu;
\
NAMESPACE::FNAME(options, A, perm_c, perm_r, etree, equed, R, C, L, \
U, work, lwork, B, X, recip_pivot_growth, rcond, \
- ferr, berr, &mem_usage, stats, info); \
- return mem_usage.for_lu; /* bytes used by the factor storage */ \
+ ferr, berr, &Glu, &mem_usage, stats, info); \
+ return mem_usage.for_lu; /* bytes used by the factor storage */ \
}
DECL_GSSVX(SuperLU_S,sgssvx,float,float)
diff --git a/src/gmm/gmm_superlu_interface.h b/src/gmm/gmm_superlu_interface.h
index 9605dc65..d76c97fc 100644
--- a/src/gmm/gmm_superlu_interface.h
+++ b/src/gmm/gmm_superlu_interface.h
@@ -141,11 +141,12 @@ namespace gmm {
FLOATTYPE *recip_pivot_growth,
\
FLOATTYPE *rcond, FLOATTYPE *ferr, FLOATTYPE
*berr, \
SuperLUStat_t *stats, int *info, KEYTYPE) {
\
- NAMESPACE::mem_usage_t mem_usage; \
+ mem_usage_t mem_usage;
\
+ GlobalLU_t Glu;
\
NAMESPACE::FNAME(options, A, perm_c, perm_r, etree, equed, R, C, L, \
U, work, lwork, B, X, recip_pivot_growth, rcond, \
- ferr, berr, &mem_usage, stats, info); \
- return mem_usage.for_lu; /* bytes used by the factor storage */ \
+ ferr, berr, &Glu, &mem_usage, stats, info); \
+ return mem_usage.for_lu; /* bytes used by the factor storage */ \
}
DECL_GSSVX(SuperLU_S,sgssvx,float,float)
diff --git a/superlu/BLAS.c b/superlu/BLAS.c
deleted file mode 100644
index 21df5005..00000000
--- a/superlu/BLAS.c
+++ /dev/null
@@ -1,43902 +0,0 @@
-/* BLAS.f -- translated by f2c
- You must link the resulting object file with the libraries:
- -lf2c -lm (in that order)
-
- the f2c-ed file has been slightly modified (removal of lsame_, added r_sign)
-
- Original fortran source files are distributed along with this package in
the sub-directory BLAS
-*/
-
-/*
-
- The reference BLAS is a freely-available software package. It is available
from netlib via anonymous ftp
- and the World Wide Web. Thus, it can be included in commercial software
packages (and has been). We only
- ask that proper credit be given to the authors.
-
- Like all software, it is copyrighted. It is not trademarked, but we do ask
the following:
-
- If you modify the source for these routines we ask that you change the name
of the routine and comment
- the changes made to the original.
-
- We will gladly answer any questions regarding the software. If a
modification is done, however, it is the
- responsibility of the person who modified the routine to provide support.
-
- see https://www.openhub.net/licenses/blas
-*/
-
-/* Copyright (C) 2004-2020 Julien Pommier
-
- This file is a part of GetFEM++
-
- GetFEM++ is free software; you can redistribute it and/or modify it
- under the terms of the GNU Lesser General Public License as published
- by the Free Software Foundation; either version 3 of the License, or
- (at your option) any later version along with the GCC Runtime Library
- Exception either version 3.1 or (at your option) any later version.
- This program is distributed in the hope that it will be useful, but
- WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public
- License and GCC Runtime Library Exception for more details.
- You should have received a copy of the GNU Lesser General Public License
- along with this program; if not, write to the Free Software Foundation,
- Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
-
-*/
-
-#include "BLAS_f2c.h"
-
-/* Table of constant values */
-
-static complex c_b21 = {1.f,0.f};
-static doublereal c_b876 = 1.;
-static real c_b1543 = 1.f;
-static integer c__1 = 1;
-static doublecomplex c_b2094 = {1.,0.};
-
-/* Subroutine */ int caxpy_(integer *n, complex *ca, complex *cx, integer *
- incx, complex *cy, integer *incy)
-{
- /* System generated locals */
- integer i__1, i__2, i__3, i__4;
- real r__1, r__2;
- complex q__1, q__2;
-
- /* Builtin functions */
- double r_imag(complex *);
-
- /* Local variables */
- static integer i__, ix, iy;
-
-
-/* constant times a vector plus a vector. */
-/* jack dongarra, linpack, 3/11/78. */
-/* modified 12/3/93, array(1) declarations changed to array(*) */
-
-
- /* Parameter adjustments */
- --cy;
- --cx;
-
- /* Function Body */
- if (*n <= 0) {
- return 0;
- }
- if ((r__1 = ca->r, dabs(r__1)) + (r__2 = r_imag(ca), dabs(r__2)) == 0.f) {
- return 0;
- }
- if (*incx == 1 && *incy == 1) {
- goto L20;
- }
-
-/* code for unequal increments or equal increments */
-/* not equal to 1 */
-
- ix = 1;
- iy = 1;
- if (*incx < 0) {
- ix = (-(*n) + 1) * *incx + 1;
- }
- if (*incy < 0) {
- iy = (-(*n) + 1) * *incy + 1;
- }
- i__1 = *n;
- for (i__ = 1; i__ <= i__1; ++i__) {
- i__2 = iy;
- i__3 = iy;
- i__4 = ix;
- q__2.r = ca->r * cx[i__4].r - ca->i * cx[i__4].i, q__2.i = ca->r * cx[
- i__4].i + ca->i * cx[i__4].r;
- q__1.r = cy[i__3].r + q__2.r, q__1.i = cy[i__3].i + q__2.i;
- cy[i__2].r = q__1.r, cy[i__2].i = q__1.i;
- ix += *incx;
- iy += *incy;
-/* L10: */
- }
- return 0;
-
-/* code for both increments equal to 1 */
-
-L20:
- i__1 = *n;
- for (i__ = 1; i__ <= i__1; ++i__) {
- i__2 = i__;
- i__3 = i__;
- i__4 = i__;
- q__2.r = ca->r * cx[i__4].r - ca->i * cx[i__4].i, q__2.i = ca->r * cx[
- i__4].i + ca->i * cx[i__4].r;
- q__1.r = cy[i__3].r + q__2.r, q__1.i = cy[i__3].i + q__2.i;
- cy[i__2].r = q__1.r, cy[i__2].i = q__1.i;
-/* L30: */
- }
- return 0;
-} /* caxpy_ */
-
-/* Subroutine */ int ccopy_(integer *n, complex *cx, integer *incx, complex *
- cy, integer *incy)
-{
- /* System generated locals */
- integer i__1, i__2, i__3;
-
- /* Local variables */
- static integer i__, ix, iy;
-
-
-/* copies a vector, x, to a vector, y. */
-/* jack dongarra, linpack, 3/11/78. */
-/* modified 12/3/93, array(1) declarations changed to array(*) */
-
-
- /* Parameter adjustments */
- --cy;
- --cx;
-
- /* Function Body */
- if (*n <= 0) {
- return 0;
- }
- if (*incx == 1 && *incy == 1) {
- goto L20;
- }
-
-/* code for unequal increments or equal increments */
-/* not equal to 1 */
-
- ix = 1;
- iy = 1;
- if (*incx < 0) {
- ix = (-(*n) + 1) * *incx + 1;
- }
- if (*incy < 0) {
- iy = (-(*n) + 1) * *incy + 1;
- }
- i__1 = *n;
- for (i__ = 1; i__ <= i__1; ++i__) {
- i__2 = iy;
- i__3 = ix;
- cy[i__2].r = cx[i__3].r, cy[i__2].i = cx[i__3].i;
- ix += *incx;
- iy += *incy;
-/* L10: */
- }
- return 0;
-
-/* code for both increments equal to 1 */
-
-L20:
- i__1 = *n;
- for (i__ = 1; i__ <= i__1; ++i__) {
- i__2 = i__;
- i__3 = i__;
- cy[i__2].r = cx[i__3].r, cy[i__2].i = cx[i__3].i;
-/* L30: */
- }
- return 0;
-} /* ccopy_ */
-
-/* Complex */ VOID cdotc_(complex * ret_val, integer *n, complex *cx, integer
- *incx, complex *cy, integer *incy)
-{
- /* System generated locals */
- integer i__1, i__2;
- complex q__1, q__2, q__3;
-
- /* Builtin functions */
- void r_cnjg(complex *, complex *);
-
- /* Local variables */
- static integer i__, ix, iy;
- static complex ctemp;
-
-
-/* forms the dot product of two vectors, conjugating the first */
-/* vector. */
-/* jack dongarra, linpack, 3/11/78. */
-/* modified 12/3/93, array(1) declarations changed to array(*) */
-
-
- /* Parameter adjustments */
- --cy;
- --cx;
-
- /* Function Body */
- ctemp.r = 0.f, ctemp.i = 0.f;
- ret_val->r = 0.f, ret_val->i = 0.f;
- if (*n <= 0) {
- return ;
- }
- if (*incx == 1 && *incy == 1) {
- goto L20;
- }
-
-/* code for unequal increments or equal increments */
-/* not equal to 1 */
-
- ix = 1;
- iy = 1;
- if (*incx < 0) {
- ix = (-(*n) + 1) * *incx + 1;
- }
- if (*incy < 0) {
- iy = (-(*n) + 1) * *incy + 1;
- }
- i__1 = *n;
- for (i__ = 1; i__ <= i__1; ++i__) {
- r_cnjg(&q__3, &cx[ix]);
- i__2 = iy;
- q__2.r = q__3.r * cy[i__2].r - q__3.i * cy[i__2].i, q__2.i = q__3.r *
- cy[i__2].i + q__3.i * cy[i__2].r;
- q__1.r = ctemp.r + q__2.r, q__1.i = ctemp.i + q__2.i;
- ctemp.r = q__1.r, ctemp.i = q__1.i;
- ix += *incx;
- iy += *incy;
-/* L10: */
- }
- ret_val->r = ctemp.r, ret_val->i = ctemp.i;
- return ;
-
-/* code for both increments equal to 1 */
-
-L20:
- i__1 = *n;
- for (i__ = 1; i__ <= i__1; ++i__) {
- r_cnjg(&q__3, &cx[i__]);
- i__2 = i__;
- q__2.r = q__3.r * cy[i__2].r - q__3.i * cy[i__2].i, q__2.i = q__3.r *
- cy[i__2].i + q__3.i * cy[i__2].r;
- q__1.r = ctemp.r + q__2.r, q__1.i = ctemp.i + q__2.i;
- ctemp.r = q__1.r, ctemp.i = q__1.i;
-/* L30: */
- }
- ret_val->r = ctemp.r, ret_val->i = ctemp.i;
- return ;
-} /* cdotc_ */
-
-/* Complex */ VOID cdotu_(complex * ret_val, integer *n, complex *cx, integer
- *incx, complex *cy, integer *incy)
-{
- /* System generated locals */
- integer i__1, i__2, i__3;
- complex q__1, q__2;
-
- /* Local variables */
- static integer i__, ix, iy;
- static complex ctemp;
-
-
-/* forms the dot product of two vectors. */
-/* jack dongarra, linpack, 3/11/78. */
-/* modified 12/3/93, array(1) declarations changed to array(*) */
-
-
- /* Parameter adjustments */
- --cy;
- --cx;
-
- /* Function Body */
- ctemp.r = 0.f, ctemp.i = 0.f;
- ret_val->r = 0.f, ret_val->i = 0.f;
- if (*n <= 0) {
- return ;
- }
- if (*incx == 1 && *incy == 1) {
- goto L20;
- }
-
-/* code for unequal increments or equal increments */
-/* not equal to 1 */
-
- ix = 1;
- iy = 1;
- if (*incx < 0) {
- ix = (-(*n) + 1) * *incx + 1;
- }
- if (*incy < 0) {
- iy = (-(*n) + 1) * *incy + 1;
- }
- i__1 = *n;
- for (i__ = 1; i__ <= i__1; ++i__) {
- i__2 = ix;
- i__3 = iy;
- q__2.r = cx[i__2].r * cy[i__3].r - cx[i__2].i * cy[i__3].i, q__2.i =
- cx[i__2].r * cy[i__3].i + cx[i__2].i * cy[i__3].r;
- q__1.r = ctemp.r + q__2.r, q__1.i = ctemp.i + q__2.i;
- ctemp.r = q__1.r, ctemp.i = q__1.i;
- ix += *incx;
- iy += *incy;
-/* L10: */
- }
- ret_val->r = ctemp.r, ret_val->i = ctemp.i;
- return ;
-
-/* code for both increments equal to 1 */
-
-L20:
- i__1 = *n;
- for (i__ = 1; i__ <= i__1; ++i__) {
- i__2 = i__;
- i__3 = i__;
- q__2.r = cx[i__2].r * cy[i__3].r - cx[i__2].i * cy[i__3].i, q__2.i =
- cx[i__2].r * cy[i__3].i + cx[i__2].i * cy[i__3].r;
- q__1.r = ctemp.r + q__2.r, q__1.i = ctemp.i + q__2.i;
- ctemp.r = q__1.r, ctemp.i = q__1.i;
-/* L30: */
- }
- ret_val->r = ctemp.r, ret_val->i = ctemp.i;
- return ;
-} /* cdotu_ */
-
-/* Subroutine */ int cgbmv_(char *trans, integer *m, integer *n, integer *kl,
- integer *ku, complex *alpha, complex *a, integer *lda, complex *x,
- integer *incx, complex *beta, complex *y, integer *incy, ftnlen
- trans_len)
-{
- /* System generated locals */
- integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5, i__6;
- complex q__1, q__2, q__3;
-
- /* Builtin functions */
- void r_cnjg(complex *, complex *);
-
- /* Local variables */
- static integer i__, j, k, ix, iy, jx, jy, kx, ky, kup1, info;
- static complex temp;
- static integer lenx, leny;
- extern logical lsame_(char *, char *, ftnlen, ftnlen);
- extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen);
- static logical noconj;
-
-/* .. Scalar Arguments .. */
-/* .. Array Arguments .. */
-/* .. */
-
-/* Purpose */
-/* ======= */
-
-/* CGBMV performs one of the matrix-vector operations */
-
-/* y := alpha*A*x + beta*y, or y := alpha*A'*x + beta*y, or */
-
-/* y := alpha*conjg( A' )*x + beta*y, */
-
-/* where alpha and beta are scalars, x and y are vectors and A is an */
-/* m by n band matrix, with kl sub-diagonals and ku super-diagonals. */
-
-/* Parameters */
-/* ========== */
-
-/* TRANS - CHARACTER*1. */
-/* On entry, TRANS specifies the operation to be performed as */
-/* follows: */
-
-/* TRANS = 'N' or 'n' y := alpha*A*x + beta*y. */
-
-/* TRANS = 'T' or 't' y := alpha*A'*x + beta*y. */
-
-/* TRANS = 'C' or 'c' y := alpha*conjg( A' )*x + beta*y. */
-
-/* Unchanged on exit. */
-
-/* M - INTEGER. */
-/* On entry, M specifies the number of rows of the matrix A. */
-/* M must be at least zero. */
-/* Unchanged on exit. */
-
-/* N - INTEGER. */
-/* On entry, N specifies the number of columns of the matrix A. */
-/* N must be at least zero. */
-/* Unchanged on exit. */
-
-/* KL - INTEGER. */
-/* On entry, KL specifies the number of sub-diagonals of the */
-/* matrix A. KL must satisfy 0 .le. KL. */
-/* Unchanged on exit. */
-
-/* KU - INTEGER. */
-/* On entry, KU specifies the number of super-diagonals of the */
-/* matrix A. KU must satisfy 0 .le. KU. */
-/* Unchanged on exit. */
-
-/* ALPHA - COMPLEX . */
-/* On entry, ALPHA specifies the scalar alpha. */
-/* Unchanged on exit. */
-
-/* A - COMPLEX array of DIMENSION ( LDA, n ). */
-/* Before entry, the leading ( kl + ku + 1 ) by n part of the */
-/* array A must contain the matrix of coefficients, supplied */
-/* column by column, with the leading diagonal of the matrix in */
-/* row ( ku + 1 ) of the array, the first super-diagonal */
-/* starting at position 2 in row ku, the first sub-diagonal */
-/* starting at position 1 in row ( ku + 2 ), and so on. */
-/* Elements in the array A that do not correspond to elements */
-/* in the band matrix (such as the top left ku by ku triangle) */
-/* are not referenced. */
-/* The following program segment will transfer a band matrix */
-/* from conventional full matrix storage to band storage: */
-
-/* DO 20, J = 1, N */
-/* K = KU + 1 - J */
-/* DO 10, I = MAX( 1, J - KU ), MIN( M, J + KL ) */
-/* A( K + I, J ) = matrix( I, J ) */
-/* 10 CONTINUE */
-/* 20 CONTINUE */
-
-/* Unchanged on exit. */
-
-/* LDA - INTEGER. */
-/* On entry, LDA specifies the first dimension of A as declared */
-/* in the calling (sub) program. LDA must be at least */
-/* ( kl + ku + 1 ). */
-/* Unchanged on exit. */
-
-/* X - COMPLEX array of DIMENSION at least */
-/* ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n' */
-/* and at least */
-/* ( 1 + ( m - 1 )*abs( INCX ) ) otherwise. */
-/* Before entry, the incremented array X must contain the */
-/* vector x. */
-/* Unchanged on exit. */
-
-/* INCX - INTEGER. */
-/* On entry, INCX specifies the increment for the elements of */
-/* X. INCX must not be zero. */
-/* Unchanged on exit. */
-
-/* BETA - COMPLEX . */
-/* On entry, BETA specifies the scalar beta. When BETA is */
-/* supplied as zero then Y need not be set on input. */
-/* Unchanged on exit. */
-
-/* Y - COMPLEX array of DIMENSION at least */
-/* ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n' */
-/* and at least */
-/* ( 1 + ( n - 1 )*abs( INCY ) ) otherwise. */
-/* Before entry, the incremented array Y must contain the */
-/* vector y. On exit, Y is overwritten by the updated vector y. */
-
-
-/* INCY - INTEGER. */
-/* On entry, INCY specifies the increment for the elements of */
-/* Y. INCY must not be zero. */
-/* Unchanged on exit. */
-
-
-/* Level 2 Blas routine. */
-
-/* -- Written on 22-October-1986. */
-/* Jack Dongarra, Argonne National Lab. */
-/* Jeremy Du Croz, Nag Central Office. */
-/* Sven Hammarling, Nag Central Office. */
-/* Richard Hanson, Sandia National Labs. */
-
-
-/* .. Parameters .. */
-/* .. Local Scalars .. */
-/* .. External Functions .. */
-/* .. External Subroutines .. */
-/* .. Intrinsic Functions .. */
-/* .. */
-/* .. Executable Statements .. */
-
-/* Test the input parameters. */
-
- /* Parameter adjustments */
- a_dim1 = *lda;
- a_offset = 1 + a_dim1 * 1;
- a -= a_offset;
- --x;
- --y;
-
- /* Function Body */
- info = 0;
- if (! lsame_(trans, "N", (ftnlen)1, (ftnlen)1) && ! lsame_(trans, "T", (
- ftnlen)1, (ftnlen)1) && ! lsame_(trans, "C", (ftnlen)1, (ftnlen)1)
- ) {
- info = 1;
- } else if (*m < 0) {
- info = 2;
- } else if (*n < 0) {
- info = 3;
- } else if (*kl < 0) {
- info = 4;
- } else if (*ku < 0) {
- info = 5;
- } else if (*lda < *kl + *ku + 1) {
- info = 8;
- } else if (*incx == 0) {
- info = 10;
- } else if (*incy == 0) {
- info = 13;
- }
- if (info != 0) {
- xerbla_("CGBMV ", &info, (ftnlen)6);
- return 0;
- }
-
-/* Quick return if possible. */
-
- if (*m == 0 || *n == 0 || alpha->r == 0.f && alpha->i == 0.f && (beta->r
- == 1.f && beta->i == 0.f)) {
- return 0;
- }
-
- noconj = lsame_(trans, "T", (ftnlen)1, (ftnlen)1);
-
-/* Set LENX and LENY, the lengths of the vectors x and y, and set */
-/* up the start points in X and Y. */
-
- if (lsame_(trans, "N", (ftnlen)1, (ftnlen)1)) {
- lenx = *n;
- leny = *m;
- } else {
- lenx = *m;
- leny = *n;
- }
- if (*incx > 0) {
- kx = 1;
- } else {
- kx = 1 - (lenx - 1) * *incx;
- }
- if (*incy > 0) {
- ky = 1;
- } else {
- ky = 1 - (leny - 1) * *incy;
- }
-
-/* Start the operations. In this version the elements of A are */
-/* accessed sequentially with one pass through the band part of A. */
-
-/* First form y := beta*y. */
-
- if (beta->r != 1.f || beta->i != 0.f) {
- if (*incy == 1) {
- if (beta->r == 0.f && beta->i == 0.f) {
- i__1 = leny;
- for (i__ = 1; i__ <= i__1; ++i__) {
- i__2 = i__;
- y[i__2].r = 0.f, y[i__2].i = 0.f;
-/* L10: */
- }
- } else {
- i__1 = leny;
- for (i__ = 1; i__ <= i__1; ++i__) {
- i__2 = i__;
- i__3 = i__;
- q__1.r = beta->r * y[i__3].r - beta->i * y[i__3].i,
- q__1.i = beta->r * y[i__3].i + beta->i * y[i__3]
- .r;
- y[i__2].r = q__1.r, y[i__2].i = q__1.i;
-/* L20: */
- }
- }
- } else {
- iy = ky;
- if (beta->r == 0.f && beta->i == 0.f) {
- i__1 = leny;
- for (i__ = 1; i__ <= i__1; ++i__) {
- i__2 = iy;
- y[i__2].r = 0.f, y[i__2].i = 0.f;
- iy += *incy;
-/* L30: */
- }
- } else {
- i__1 = leny;
- for (i__ = 1; i__ <= i__1; ++i__) {
- i__2 = iy;
- i__3 = iy;
- q__1.r = beta->r * y[i__3].r - beta->i * y[i__3].i,
- q__1.i = beta->r * y[i__3].i + beta->i * y[i__3]
- .r;
- y[i__2].r = q__1.r, y[i__2].i = q__1.i;
- iy += *incy;
-/* L40: */
- }
- }
- }
- }
- if (alpha->r == 0.f && alpha->i == 0.f) {
- return 0;
- }
- kup1 = *ku + 1;
- if (lsame_(trans, "N", (ftnlen)1, (ftnlen)1)) {
-
-/* Form y := alpha*A*x + y. */
-
- jx = kx;
- if (*incy == 1) {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- i__2 = jx;
- if (x[i__2].r != 0.f || x[i__2].i != 0.f) {
- i__2 = jx;
- q__1.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i,
- q__1.i = alpha->r * x[i__2].i + alpha->i * x[i__2]
- .r;
- temp.r = q__1.r, temp.i = q__1.i;
- k = kup1 - j;
-/* Computing MAX */
- i__2 = 1, i__3 = j - *ku;
-/* Computing MIN */
- i__5 = *m, i__6 = j + *kl;
- i__4 = min(i__5,i__6);
- for (i__ = max(i__2,i__3); i__ <= i__4; ++i__) {
- i__2 = i__;
- i__3 = i__;
- i__5 = k + i__ + j * a_dim1;
- q__2.r = temp.r * a[i__5].r - temp.i * a[i__5].i,
- q__2.i = temp.r * a[i__5].i + temp.i * a[i__5]
- .r;
- q__1.r = y[i__3].r + q__2.r, q__1.i = y[i__3].i +
- q__2.i;
- y[i__2].r = q__1.r, y[i__2].i = q__1.i;
-/* L50: */
- }
- }
- jx += *incx;
-/* L60: */
- }
- } else {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- i__4 = jx;
- if (x[i__4].r != 0.f || x[i__4].i != 0.f) {
- i__4 = jx;
- q__1.r = alpha->r * x[i__4].r - alpha->i * x[i__4].i,
- q__1.i = alpha->r * x[i__4].i + alpha->i * x[i__4]
- .r;
- temp.r = q__1.r, temp.i = q__1.i;
- iy = ky;
- k = kup1 - j;
-/* Computing MAX */
- i__4 = 1, i__2 = j - *ku;
-/* Computing MIN */
- i__5 = *m, i__6 = j + *kl;
- i__3 = min(i__5,i__6);
- for (i__ = max(i__4,i__2); i__ <= i__3; ++i__) {
- i__4 = iy;
- i__2 = iy;
- i__5 = k + i__ + j * a_dim1;
- q__2.r = temp.r * a[i__5].r - temp.i * a[i__5].i,
- q__2.i = temp.r * a[i__5].i + temp.i * a[i__5]
- .r;
- q__1.r = y[i__2].r + q__2.r, q__1.i = y[i__2].i +
- q__2.i;
- y[i__4].r = q__1.r, y[i__4].i = q__1.i;
- iy += *incy;
-/* L70: */
- }
- }
- jx += *incx;
- if (j > *ku) {
- ky += *incy;
- }
-/* L80: */
- }
- }
- } else {
-
-/* Form y := alpha*A'*x + y or y := alpha*conjg( A' )*x + y. */
-
- jy = ky;
- if (*incx == 1) {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- temp.r = 0.f, temp.i = 0.f;
- k = kup1 - j;
- if (noconj) {
-/* Computing MAX */
- i__3 = 1, i__4 = j - *ku;
-/* Computing MIN */
- i__5 = *m, i__6 = j + *kl;
- i__2 = min(i__5,i__6);
- for (i__ = max(i__3,i__4); i__ <= i__2; ++i__) {
- i__3 = k + i__ + j * a_dim1;
- i__4 = i__;
- q__2.r = a[i__3].r * x[i__4].r - a[i__3].i * x[i__4]
- .i, q__2.i = a[i__3].r * x[i__4].i + a[i__3]
- .i * x[i__4].r;
- q__1.r = temp.r + q__2.r, q__1.i = temp.i + q__2.i;
- temp.r = q__1.r, temp.i = q__1.i;
-/* L90: */
- }
- } else {
-/* Computing MAX */
- i__2 = 1, i__3 = j - *ku;
-/* Computing MIN */
- i__5 = *m, i__6 = j + *kl;
- i__4 = min(i__5,i__6);
- for (i__ = max(i__2,i__3); i__ <= i__4; ++i__) {
- r_cnjg(&q__3, &a[k + i__ + j * a_dim1]);
- i__2 = i__;
- q__2.r = q__3.r * x[i__2].r - q__3.i * x[i__2].i,
- q__2.i = q__3.r * x[i__2].i + q__3.i * x[i__2]
- .r;
- q__1.r = temp.r + q__2.r, q__1.i = temp.i + q__2.i;
- temp.r = q__1.r, temp.i = q__1.i;
-/* L100: */
- }
- }
- i__4 = jy;
- i__2 = jy;
- q__2.r = alpha->r * temp.r - alpha->i * temp.i, q__2.i =
- alpha->r * temp.i + alpha->i * temp.r;
- q__1.r = y[i__2].r + q__2.r, q__1.i = y[i__2].i + q__2.i;
- y[i__4].r = q__1.r, y[i__4].i = q__1.i;
- jy += *incy;
-/* L110: */
- }
- } else {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- temp.r = 0.f, temp.i = 0.f;
- ix = kx;
- k = kup1 - j;
- if (noconj) {
-/* Computing MAX */
- i__4 = 1, i__2 = j - *ku;
-/* Computing MIN */
- i__5 = *m, i__6 = j + *kl;
- i__3 = min(i__5,i__6);
- for (i__ = max(i__4,i__2); i__ <= i__3; ++i__) {
- i__4 = k + i__ + j * a_dim1;
- i__2 = ix;
- q__2.r = a[i__4].r * x[i__2].r - a[i__4].i * x[i__2]
- .i, q__2.i = a[i__4].r * x[i__2].i + a[i__4]
- .i * x[i__2].r;
- q__1.r = temp.r + q__2.r, q__1.i = temp.i + q__2.i;
- temp.r = q__1.r, temp.i = q__1.i;
- ix += *incx;
-/* L120: */
- }
- } else {
-/* Computing MAX */
- i__3 = 1, i__4 = j - *ku;
-/* Computing MIN */
- i__5 = *m, i__6 = j + *kl;
- i__2 = min(i__5,i__6);
- for (i__ = max(i__3,i__4); i__ <= i__2; ++i__) {
- r_cnjg(&q__3, &a[k + i__ + j * a_dim1]);
- i__3 = ix;
- q__2.r = q__3.r * x[i__3].r - q__3.i * x[i__3].i,
- q__2.i = q__3.r * x[i__3].i + q__3.i * x[i__3]
- .r;
- q__1.r = temp.r + q__2.r, q__1.i = temp.i + q__2.i;
- temp.r = q__1.r, temp.i = q__1.i;
- ix += *incx;
-/* L130: */
- }
- }
- i__2 = jy;
- i__3 = jy;
- q__2.r = alpha->r * temp.r - alpha->i * temp.i, q__2.i =
- alpha->r * temp.i + alpha->i * temp.r;
- q__1.r = y[i__3].r + q__2.r, q__1.i = y[i__3].i + q__2.i;
- y[i__2].r = q__1.r, y[i__2].i = q__1.i;
- jy += *incy;
- if (j > *ku) {
- kx += *incx;
- }
-/* L140: */
- }
- }
- }
-
- return 0;
-
-/* End of CGBMV . */
-
-} /* cgbmv_ */
-
-/* Subroutine */ int cgemm_(char *transa, char *transb, integer *m, integer *
- n, integer *k, complex *alpha, complex *a, integer *lda, complex *b,
- integer *ldb, complex *beta, complex *c__, integer *ldc, ftnlen
- transa_len, ftnlen transb_len)
-{
- /* System generated locals */
- integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2,
- i__3, i__4, i__5, i__6;
- complex q__1, q__2, q__3, q__4;
-
- /* Builtin functions */
- void r_cnjg(complex *, complex *);
-
- /* Local variables */
- static integer i__, j, l, info;
- static logical nota, notb;
- static complex temp;
- static logical conja, conjb;
- static integer ncola;
- extern logical lsame_(char *, char *, ftnlen, ftnlen);
- static integer nrowa, nrowb;
- extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen);
-
-/* .. Scalar Arguments .. */
-/* .. Array Arguments .. */
-/* .. */
-
-/* Purpose */
-/* ======= */
-
-/* CGEMM performs one of the matrix-matrix operations */
-
-/* C := alpha*op( A )*op( B ) + beta*C, */
-
-/* where op( X ) is one of */
-
-/* op( X ) = X or op( X ) = X' or op( X ) = conjg( X' ), */
-
-/* alpha and beta are scalars, and A, B and C are matrices, with op( A ) */
-/* an m by k matrix, op( B ) a k by n matrix and C an m by n matrix. */
-
-/* Parameters */
-/* ========== */
-
-/* TRANSA - CHARACTER*1. */
-/* On entry, TRANSA specifies the form of op( A ) to be used in */
-/* the matrix multiplication as follows: */
-
-/* TRANSA = 'N' or 'n', op( A ) = A. */
-
-/* TRANSA = 'T' or 't', op( A ) = A'. */
-
-/* TRANSA = 'C' or 'c', op( A ) = conjg( A' ). */
-
-/* Unchanged on exit. */
-
-/* TRANSB - CHARACTER*1. */
-/* On entry, TRANSB specifies the form of op( B ) to be used in */
-/* the matrix multiplication as follows: */
-
-/* TRANSB = 'N' or 'n', op( B ) = B. */
-
-/* TRANSB = 'T' or 't', op( B ) = B'. */
-
-/* TRANSB = 'C' or 'c', op( B ) = conjg( B' ). */
-
-/* Unchanged on exit. */
-
-/* M - INTEGER. */
-/* On entry, M specifies the number of rows of the matrix */
-/* op( A ) and of the matrix C. M must be at least zero. */
-/* Unchanged on exit. */
-
-/* N - INTEGER. */
-/* On entry, N specifies the number of columns of the matrix */
-/* op( B ) and the number of columns of the matrix C. N must be */
-/* at least zero. */
-/* Unchanged on exit. */
-
-/* K - INTEGER. */
-/* On entry, K specifies the number of columns of the matrix */
-/* op( A ) and the number of rows of the matrix op( B ). K must */
-/* be at least zero. */
-/* Unchanged on exit. */
-
-/* ALPHA - COMPLEX . */
-/* On entry, ALPHA specifies the scalar alpha. */
-/* Unchanged on exit. */
-
-/* A - COMPLEX array of DIMENSION ( LDA, ka ), where ka is */
-/* k when TRANSA = 'N' or 'n', and is m otherwise. */
-/* Before entry with TRANSA = 'N' or 'n', the leading m by k */
-/* part of the array A must contain the matrix A, otherwise */
-/* the leading k by m part of the array A must contain the */
-/* matrix A. */
-/* Unchanged on exit. */
-
-/* LDA - INTEGER. */
-/* On entry, LDA specifies the first dimension of A as declared */
-/* in the calling (sub) program. When TRANSA = 'N' or 'n' then */
-/* LDA must be at least max( 1, m ), otherwise LDA must be at */
-/* least max( 1, k ). */
-/* Unchanged on exit. */
-
-/* B - COMPLEX array of DIMENSION ( LDB, kb ), where kb is */
-/* n when TRANSB = 'N' or 'n', and is k otherwise. */
-/* Before entry with TRANSB = 'N' or 'n', the leading k by n */
-/* part of the array B must contain the matrix B, otherwise */
-/* the leading n by k part of the array B must contain the */
-/* matrix B. */
-/* Unchanged on exit. */
-
-/* LDB - INTEGER. */
-/* On entry, LDB specifies the first dimension of B as declared */
-/* in the calling (sub) program. When TRANSB = 'N' or 'n' then */
-/* LDB must be at least max( 1, k ), otherwise LDB must be at */
-/* least max( 1, n ). */
-/* Unchanged on exit. */
-
-/* BETA - COMPLEX . */
-/* On entry, BETA specifies the scalar beta. When BETA is */
-/* supplied as zero then C need not be set on input. */
-/* Unchanged on exit. */
-
-/* C - COMPLEX array of DIMENSION ( LDC, n ). */
-/* Before entry, the leading m by n part of the array C must */
-/* contain the matrix C, except when beta is zero, in which */
-/* case C need not be set on entry. */
-/* On exit, the array C is overwritten by the m by n matrix */
-/* ( alpha*op( A )*op( B ) + beta*C ). */
-
-/* LDC - INTEGER. */
-/* On entry, LDC specifies the first dimension of C as declared */
-/* in the calling (sub) program. LDC must be at least */
-/* max( 1, m ). */
-/* Unchanged on exit. */
-
-
-/* Level 3 Blas routine. */
-
-/* -- Written on 8-February-1989. */
-/* Jack Dongarra, Argonne National Laboratory. */
-/* Iain Duff, AERE Harwell. */
-/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */
-/* Sven Hammarling, Numerical Algorithms Group Ltd. */
-
-
-/* .. External Functions .. */
-/* .. External Subroutines .. */
-/* .. Intrinsic Functions .. */
-/* .. Local Scalars .. */
-/* .. Parameters .. */
-/* .. */
-/* .. Executable Statements .. */
-
-/* Set NOTA and NOTB as true if A and B respectively are not */
-/* conjugated or transposed, set CONJA and CONJB as true if A and */
-/* B respectively are to be transposed but not conjugated and set */
-/* NROWA, NCOLA and NROWB as the number of rows and columns of A */
-/* and the number of rows of B respectively. */
-
- /* Parameter adjustments */
- a_dim1 = *lda;
- a_offset = 1 + a_dim1 * 1;
- a -= a_offset;
- b_dim1 = *ldb;
- b_offset = 1 + b_dim1 * 1;
- b -= b_offset;
- c_dim1 = *ldc;
- c_offset = 1 + c_dim1 * 1;
- c__ -= c_offset;
-
- /* Function Body */
- nota = lsame_(transa, "N", (ftnlen)1, (ftnlen)1);
- notb = lsame_(transb, "N", (ftnlen)1, (ftnlen)1);
- conja = lsame_(transa, "C", (ftnlen)1, (ftnlen)1);
- conjb = lsame_(transb, "C", (ftnlen)1, (ftnlen)1);
- if (nota) {
- nrowa = *m;
- ncola = *k;
- } else {
- nrowa = *k;
- ncola = *m;
- }
- if (notb) {
- nrowb = *k;
- } else {
- nrowb = *n;
- }
-
-/* Test the input parameters. */
-
- info = 0;
- if (! nota && ! conja && ! lsame_(transa, "T", (ftnlen)1, (ftnlen)1)) {
- info = 1;
- } else if (! notb && ! conjb && ! lsame_(transb, "T", (ftnlen)1, (ftnlen)
- 1)) {
- info = 2;
- } else if (*m < 0) {
- info = 3;
- } else if (*n < 0) {
- info = 4;
- } else if (*k < 0) {
- info = 5;
- } else if (*lda < max(1,nrowa)) {
- info = 8;
- } else if (*ldb < max(1,nrowb)) {
- info = 10;
- } else if (*ldc < max(1,*m)) {
- info = 13;
- }
- if (info != 0) {
- xerbla_("CGEMM ", &info, (ftnlen)6);
- return 0;
- }
-
-/* Quick return if possible. */
-
- if (*m == 0 || *n == 0 || (alpha->r == 0.f && alpha->i == 0.f || *k == 0)
- && (beta->r == 1.f && beta->i == 0.f)) {
- return 0;
- }
-
-/* And when alpha.eq.zero. */
-
- if (alpha->r == 0.f && alpha->i == 0.f) {
- if (beta->r == 0.f && beta->i == 0.f) {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- i__2 = *m;
- for (i__ = 1; i__ <= i__2; ++i__) {
- i__3 = i__ + j * c_dim1;
- c__[i__3].r = 0.f, c__[i__3].i = 0.f;
-/* L10: */
- }
-/* L20: */
- }
- } else {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- i__2 = *m;
- for (i__ = 1; i__ <= i__2; ++i__) {
- i__3 = i__ + j * c_dim1;
- i__4 = i__ + j * c_dim1;
- q__1.r = beta->r * c__[i__4].r - beta->i * c__[i__4].i,
- q__1.i = beta->r * c__[i__4].i + beta->i * c__[
- i__4].r;
- c__[i__3].r = q__1.r, c__[i__3].i = q__1.i;
-/* L30: */
- }
-/* L40: */
- }
- }
- return 0;
- }
-
-/* Start the operations. */
-
- if (notb) {
- if (nota) {
-
-/* Form C := alpha*A*B + beta*C. */
-
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- if (beta->r == 0.f && beta->i == 0.f) {
- i__2 = *m;
- for (i__ = 1; i__ <= i__2; ++i__) {
- i__3 = i__ + j * c_dim1;
- c__[i__3].r = 0.f, c__[i__3].i = 0.f;
-/* L50: */
- }
- } else if (beta->r != 1.f || beta->i != 0.f) {
- i__2 = *m;
- for (i__ = 1; i__ <= i__2; ++i__) {
- i__3 = i__ + j * c_dim1;
- i__4 = i__ + j * c_dim1;
- q__1.r = beta->r * c__[i__4].r - beta->i * c__[i__4]
- .i, q__1.i = beta->r * c__[i__4].i + beta->i *
- c__[i__4].r;
- c__[i__3].r = q__1.r, c__[i__3].i = q__1.i;
-/* L60: */
- }
- }
- i__2 = *k;
- for (l = 1; l <= i__2; ++l) {
- i__3 = l + j * b_dim1;
- if (b[i__3].r != 0.f || b[i__3].i != 0.f) {
- i__3 = l + j * b_dim1;
- q__1.r = alpha->r * b[i__3].r - alpha->i * b[i__3].i,
- q__1.i = alpha->r * b[i__3].i + alpha->i * b[
- i__3].r;
- temp.r = q__1.r, temp.i = q__1.i;
- i__3 = *m;
- for (i__ = 1; i__ <= i__3; ++i__) {
- i__4 = i__ + j * c_dim1;
- i__5 = i__ + j * c_dim1;
- i__6 = i__ + l * a_dim1;
- q__2.r = temp.r * a[i__6].r - temp.i * a[i__6].i,
- q__2.i = temp.r * a[i__6].i + temp.i * a[
- i__6].r;
- q__1.r = c__[i__5].r + q__2.r, q__1.i = c__[i__5]
- .i + q__2.i;
- c__[i__4].r = q__1.r, c__[i__4].i = q__1.i;
-/* L70: */
- }
- }
-/* L80: */
- }
-/* L90: */
- }
- } else if (conja) {
-
-/* Form C := alpha*conjg( A' )*B + beta*C. */
-
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- i__2 = *m;
- for (i__ = 1; i__ <= i__2; ++i__) {
- temp.r = 0.f, temp.i = 0.f;
- i__3 = *k;
- for (l = 1; l <= i__3; ++l) {
- r_cnjg(&q__3, &a[l + i__ * a_dim1]);
- i__4 = l + j * b_dim1;
- q__2.r = q__3.r * b[i__4].r - q__3.i * b[i__4].i,
- q__2.i = q__3.r * b[i__4].i + q__3.i * b[i__4]
- .r;
- q__1.r = temp.r + q__2.r, q__1.i = temp.i + q__2.i;
- temp.r = q__1.r, temp.i = q__1.i;
-/* L100: */
- }
- if (beta->r == 0.f && beta->i == 0.f) {
- i__3 = i__ + j * c_dim1;
- q__1.r = alpha->r * temp.r - alpha->i * temp.i,
- q__1.i = alpha->r * temp.i + alpha->i *
- temp.r;
- c__[i__3].r = q__1.r, c__[i__3].i = q__1.i;
- } else {
- i__3 = i__ + j * c_dim1;
- q__2.r = alpha->r * temp.r - alpha->i * temp.i,
- q__2.i = alpha->r * temp.i + alpha->i *
- temp.r;
- i__4 = i__ + j * c_dim1;
- q__3.r = beta->r * c__[i__4].r - beta->i * c__[i__4]
- .i, q__3.i = beta->r * c__[i__4].i + beta->i *
- c__[i__4].r;
- q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
- c__[i__3].r = q__1.r, c__[i__3].i = q__1.i;
- }
-/* L110: */
- }
-/* L120: */
- }
- } else {
-
-/* Form C := alpha*A'*B + beta*C */
-
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- i__2 = *m;
- for (i__ = 1; i__ <= i__2; ++i__) {
- temp.r = 0.f, temp.i = 0.f;
- i__3 = *k;
- for (l = 1; l <= i__3; ++l) {
- i__4 = l + i__ * a_dim1;
- i__5 = l + j * b_dim1;
- q__2.r = a[i__4].r * b[i__5].r - a[i__4].i * b[i__5]
- .i, q__2.i = a[i__4].r * b[i__5].i + a[i__4]
- .i * b[i__5].r;
- q__1.r = temp.r + q__2.r, q__1.i = temp.i + q__2.i;
- temp.r = q__1.r, temp.i = q__1.i;
-/* L130: */
- }
- if (beta->r == 0.f && beta->i == 0.f) {
- i__3 = i__ + j * c_dim1;
- q__1.r = alpha->r * temp.r - alpha->i * temp.i,
- q__1.i = alpha->r * temp.i + alpha->i *
- temp.r;
- c__[i__3].r = q__1.r, c__[i__3].i = q__1.i;
- } else {
- i__3 = i__ + j * c_dim1;
- q__2.r = alpha->r * temp.r - alpha->i * temp.i,
- q__2.i = alpha->r * temp.i + alpha->i *
- temp.r;
- i__4 = i__ + j * c_dim1;
- q__3.r = beta->r * c__[i__4].r - beta->i * c__[i__4]
- .i, q__3.i = beta->r * c__[i__4].i + beta->i *
- c__[i__4].r;
- q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
- c__[i__3].r = q__1.r, c__[i__3].i = q__1.i;
- }
-/* L140: */
- }
-/* L150: */
- }
- }
- } else if (nota) {
- if (conjb) {
-
-/* Form C := alpha*A*conjg( B' ) + beta*C. */
-
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- if (beta->r == 0.f && beta->i == 0.f) {
- i__2 = *m;
- for (i__ = 1; i__ <= i__2; ++i__) {
- i__3 = i__ + j * c_dim1;
- c__[i__3].r = 0.f, c__[i__3].i = 0.f;
-/* L160: */
- }
- } else if (beta->r != 1.f || beta->i != 0.f) {
- i__2 = *m;
- for (i__ = 1; i__ <= i__2; ++i__) {
- i__3 = i__ + j * c_dim1;
- i__4 = i__ + j * c_dim1;
- q__1.r = beta->r * c__[i__4].r - beta->i * c__[i__4]
- .i, q__1.i = beta->r * c__[i__4].i + beta->i *
- c__[i__4].r;
- c__[i__3].r = q__1.r, c__[i__3].i = q__1.i;
-/* L170: */
- }
- }
- i__2 = *k;
- for (l = 1; l <= i__2; ++l) {
- i__3 = j + l * b_dim1;
- if (b[i__3].r != 0.f || b[i__3].i != 0.f) {
- r_cnjg(&q__2, &b[j + l * b_dim1]);
- q__1.r = alpha->r * q__2.r - alpha->i * q__2.i,
- q__1.i = alpha->r * q__2.i + alpha->i *
- q__2.r;
- temp.r = q__1.r, temp.i = q__1.i;
- i__3 = *m;
- for (i__ = 1; i__ <= i__3; ++i__) {
- i__4 = i__ + j * c_dim1;
- i__5 = i__ + j * c_dim1;
- i__6 = i__ + l * a_dim1;
- q__2.r = temp.r * a[i__6].r - temp.i * a[i__6].i,
- q__2.i = temp.r * a[i__6].i + temp.i * a[
- i__6].r;
- q__1.r = c__[i__5].r + q__2.r, q__1.i = c__[i__5]
- .i + q__2.i;
- c__[i__4].r = q__1.r, c__[i__4].i = q__1.i;
-/* L180: */
- }
- }
-/* L190: */
- }
-/* L200: */
- }
- } else {
-
-/* Form C := alpha*A*B' + beta*C */
-
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- if (beta->r == 0.f && beta->i == 0.f) {
- i__2 = *m;
- for (i__ = 1; i__ <= i__2; ++i__) {
- i__3 = i__ + j * c_dim1;
- c__[i__3].r = 0.f, c__[i__3].i = 0.f;
-/* L210: */
- }
- } else if (beta->r != 1.f || beta->i != 0.f) {
- i__2 = *m;
- for (i__ = 1; i__ <= i__2; ++i__) {
- i__3 = i__ + j * c_dim1;
- i__4 = i__ + j * c_dim1;
- q__1.r = beta->r * c__[i__4].r - beta->i * c__[i__4]
- .i, q__1.i = beta->r * c__[i__4].i + beta->i *
- c__[i__4].r;
- c__[i__3].r = q__1.r, c__[i__3].i = q__1.i;
-/* L220: */
- }
- }
- i__2 = *k;
- for (l = 1; l <= i__2; ++l) {
- i__3 = j + l * b_dim1;
- if (b[i__3].r != 0.f || b[i__3].i != 0.f) {
- i__3 = j + l * b_dim1;
- q__1.r = alpha->r * b[i__3].r - alpha->i * b[i__3].i,
- q__1.i = alpha->r * b[i__3].i + alpha->i * b[
- i__3].r;
- temp.r = q__1.r, temp.i = q__1.i;
- i__3 = *m;
- for (i__ = 1; i__ <= i__3; ++i__) {
- i__4 = i__ + j * c_dim1;
- i__5 = i__ + j * c_dim1;
- i__6 = i__ + l * a_dim1;
- q__2.r = temp.r * a[i__6].r - temp.i * a[i__6].i,
- q__2.i = temp.r * a[i__6].i + temp.i * a[
- i__6].r;
- q__1.r = c__[i__5].r + q__2.r, q__1.i = c__[i__5]
- .i + q__2.i;
- c__[i__4].r = q__1.r, c__[i__4].i = q__1.i;
-/* L230: */
- }
- }
-/* L240: */
- }
-/* L250: */
- }
- }
- } else if (conja) {
- if (conjb) {
-
-/* Form C := alpha*conjg( A' )*conjg( B' ) + beta*C. */
-
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- i__2 = *m;
- for (i__ = 1; i__ <= i__2; ++i__) {
- temp.r = 0.f, temp.i = 0.f;
- i__3 = *k;
- for (l = 1; l <= i__3; ++l) {
- r_cnjg(&q__3, &a[l + i__ * a_dim1]);
- r_cnjg(&q__4, &b[j + l * b_dim1]);
- q__2.r = q__3.r * q__4.r - q__3.i * q__4.i, q__2.i =
- q__3.r * q__4.i + q__3.i * q__4.r;
- q__1.r = temp.r + q__2.r, q__1.i = temp.i + q__2.i;
- temp.r = q__1.r, temp.i = q__1.i;
-/* L260: */
- }
- if (beta->r == 0.f && beta->i == 0.f) {
- i__3 = i__ + j * c_dim1;
- q__1.r = alpha->r * temp.r - alpha->i * temp.i,
- q__1.i = alpha->r * temp.i + alpha->i *
- temp.r;
- c__[i__3].r = q__1.r, c__[i__3].i = q__1.i;
- } else {
- i__3 = i__ + j * c_dim1;
- q__2.r = alpha->r * temp.r - alpha->i * temp.i,
- q__2.i = alpha->r * temp.i + alpha->i *
- temp.r;
- i__4 = i__ + j * c_dim1;
- q__3.r = beta->r * c__[i__4].r - beta->i * c__[i__4]
- .i, q__3.i = beta->r * c__[i__4].i + beta->i *
- c__[i__4].r;
- q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
- c__[i__3].r = q__1.r, c__[i__3].i = q__1.i;
- }
-/* L270: */
- }
-/* L280: */
- }
- } else {
-
-/* Form C := alpha*conjg( A' )*B' + beta*C */
-
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- i__2 = *m;
- for (i__ = 1; i__ <= i__2; ++i__) {
- temp.r = 0.f, temp.i = 0.f;
- i__3 = *k;
- for (l = 1; l <= i__3; ++l) {
- r_cnjg(&q__3, &a[l + i__ * a_dim1]);
- i__4 = j + l * b_dim1;
- q__2.r = q__3.r * b[i__4].r - q__3.i * b[i__4].i,
- q__2.i = q__3.r * b[i__4].i + q__3.i * b[i__4]
- .r;
- q__1.r = temp.r + q__2.r, q__1.i = temp.i + q__2.i;
- temp.r = q__1.r, temp.i = q__1.i;
-/* L290: */
- }
- if (beta->r == 0.f && beta->i == 0.f) {
- i__3 = i__ + j * c_dim1;
- q__1.r = alpha->r * temp.r - alpha->i * temp.i,
- q__1.i = alpha->r * temp.i + alpha->i *
- temp.r;
- c__[i__3].r = q__1.r, c__[i__3].i = q__1.i;
- } else {
- i__3 = i__ + j * c_dim1;
- q__2.r = alpha->r * temp.r - alpha->i * temp.i,
- q__2.i = alpha->r * temp.i + alpha->i *
- temp.r;
- i__4 = i__ + j * c_dim1;
- q__3.r = beta->r * c__[i__4].r - beta->i * c__[i__4]
- .i, q__3.i = beta->r * c__[i__4].i + beta->i *
- c__[i__4].r;
- q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
- c__[i__3].r = q__1.r, c__[i__3].i = q__1.i;
- }
-/* L300: */
- }
-/* L310: */
- }
- }
- } else {
- if (conjb) {
-
-/* Form C := alpha*A'*conjg( B' ) + beta*C */
-
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- i__2 = *m;
- for (i__ = 1; i__ <= i__2; ++i__) {
- temp.r = 0.f, temp.i = 0.f;
- i__3 = *k;
- for (l = 1; l <= i__3; ++l) {
- i__4 = l + i__ * a_dim1;
- r_cnjg(&q__3, &b[j + l * b_dim1]);
- q__2.r = a[i__4].r * q__3.r - a[i__4].i * q__3.i,
- q__2.i = a[i__4].r * q__3.i + a[i__4].i *
- q__3.r;
- q__1.r = temp.r + q__2.r, q__1.i = temp.i + q__2.i;
- temp.r = q__1.r, temp.i = q__1.i;
-/* L320: */
- }
- if (beta->r == 0.f && beta->i == 0.f) {
- i__3 = i__ + j * c_dim1;
- q__1.r = alpha->r * temp.r - alpha->i * temp.i,
- q__1.i = alpha->r * temp.i + alpha->i *
- temp.r;
- c__[i__3].r = q__1.r, c__[i__3].i = q__1.i;
- } else {
- i__3 = i__ + j * c_dim1;
- q__2.r = alpha->r * temp.r - alpha->i * temp.i,
- q__2.i = alpha->r * temp.i + alpha->i *
- temp.r;
- i__4 = i__ + j * c_dim1;
- q__3.r = beta->r * c__[i__4].r - beta->i * c__[i__4]
- .i, q__3.i = beta->r * c__[i__4].i + beta->i *
- c__[i__4].r;
- q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
- c__[i__3].r = q__1.r, c__[i__3].i = q__1.i;
- }
-/* L330: */
- }
-/* L340: */
- }
- } else {
-
-/* Form C := alpha*A'*B' + beta*C */
-
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- i__2 = *m;
- for (i__ = 1; i__ <= i__2; ++i__) {
- temp.r = 0.f, temp.i = 0.f;
- i__3 = *k;
- for (l = 1; l <= i__3; ++l) {
- i__4 = l + i__ * a_dim1;
- i__5 = j + l * b_dim1;
- q__2.r = a[i__4].r * b[i__5].r - a[i__4].i * b[i__5]
- .i, q__2.i = a[i__4].r * b[i__5].i + a[i__4]
- .i * b[i__5].r;
- q__1.r = temp.r + q__2.r, q__1.i = temp.i + q__2.i;
- temp.r = q__1.r, temp.i = q__1.i;
-/* L350: */
- }
- if (beta->r == 0.f && beta->i == 0.f) {
- i__3 = i__ + j * c_dim1;
- q__1.r = alpha->r * temp.r - alpha->i * temp.i,
- q__1.i = alpha->r * temp.i + alpha->i *
- temp.r;
- c__[i__3].r = q__1.r, c__[i__3].i = q__1.i;
- } else {
- i__3 = i__ + j * c_dim1;
- q__2.r = alpha->r * temp.r - alpha->i * temp.i,
- q__2.i = alpha->r * temp.i + alpha->i *
- temp.r;
- i__4 = i__ + j * c_dim1;
- q__3.r = beta->r * c__[i__4].r - beta->i * c__[i__4]
- .i, q__3.i = beta->r * c__[i__4].i + beta->i *
- c__[i__4].r;
- q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
- c__[i__3].r = q__1.r, c__[i__3].i = q__1.i;
- }
-/* L360: */
- }
-/* L370: */
- }
- }
- }
-
- return 0;
-
-/* End of CGEMM . */
-
-} /* cgemm_ */
-
-/* Subroutine */ int cgemv_(char *trans, integer *m, integer *n, complex *
- alpha, complex *a, integer *lda, complex *x, integer *incx, complex *
- beta, complex *y, integer *incy, ftnlen trans_len)
-{
- /* System generated locals */
- integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5;
- complex q__1, q__2, q__3;
-
- /* Builtin functions */
- void r_cnjg(complex *, complex *);
-
- /* Local variables */
- static integer i__, j, ix, iy, jx, jy, kx, ky, info;
- static complex temp;
- static integer lenx, leny;
- extern logical lsame_(char *, char *, ftnlen, ftnlen);
- extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen);
- static logical noconj;
-
-/* .. Scalar Arguments .. */
-/* .. Array Arguments .. */
-/* .. */
-
-/* Purpose */
-/* ======= */
-
-/* CGEMV performs one of the matrix-vector operations */
-
-/* y := alpha*A*x + beta*y, or y := alpha*A'*x + beta*y, or */
-
-/* y := alpha*conjg( A' )*x + beta*y, */
-
-/* where alpha and beta are scalars, x and y are vectors and A is an */
-/* m by n matrix. */
-
-/* Parameters */
-/* ========== */
-
-/* TRANS - CHARACTER*1. */
-/* On entry, TRANS specifies the operation to be performed as */
-/* follows: */
-
-/* TRANS = 'N' or 'n' y := alpha*A*x + beta*y. */
-
-/* TRANS = 'T' or 't' y := alpha*A'*x + beta*y. */
-
-/* TRANS = 'C' or 'c' y := alpha*conjg( A' )*x + beta*y. */
-
-/* Unchanged on exit. */
-
-/* M - INTEGER. */
-/* On entry, M specifies the number of rows of the matrix A. */
-/* M must be at least zero. */
-/* Unchanged on exit. */
-
-/* N - INTEGER. */
-/* On entry, N specifies the number of columns of the matrix A. */
-/* N must be at least zero. */
-/* Unchanged on exit. */
-
-/* ALPHA - COMPLEX . */
-/* On entry, ALPHA specifies the scalar alpha. */
-/* Unchanged on exit. */
-
-/* A - COMPLEX array of DIMENSION ( LDA, n ). */
-/* Before entry, the leading m by n part of the array A must */
-/* contain the matrix of coefficients. */
-/* Unchanged on exit. */
-
-/* LDA - INTEGER. */
-/* On entry, LDA specifies the first dimension of A as declared */
-/* in the calling (sub) program. LDA must be at least */
-/* max( 1, m ). */
-/* Unchanged on exit. */
-
-/* X - COMPLEX array of DIMENSION at least */
-/* ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n' */
-/* and at least */
-/* ( 1 + ( m - 1 )*abs( INCX ) ) otherwise. */
-/* Before entry, the incremented array X must contain the */
-/* vector x. */
-/* Unchanged on exit. */
-
-/* INCX - INTEGER. */
-/* On entry, INCX specifies the increment for the elements of */
-/* X. INCX must not be zero. */
-/* Unchanged on exit. */
-
-/* BETA - COMPLEX . */
-/* On entry, BETA specifies the scalar beta. When BETA is */
-/* supplied as zero then Y need not be set on input. */
-/* Unchanged on exit. */
-
-/* Y - COMPLEX array of DIMENSION at least */
-/* ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n' */
-/* and at least */
-/* ( 1 + ( n - 1 )*abs( INCY ) ) otherwise. */
-/* Before entry with BETA non-zero, the incremented array Y */
-/* must contain the vector y. On exit, Y is overwritten by the */
-/* updated vector y. */
-
-/* INCY - INTEGER. */
-/* On entry, INCY specifies the increment for the elements of */
-/* Y. INCY must not be zero. */
-/* Unchanged on exit. */
-
-
-/* Level 2 Blas routine. */
-
-/* -- Written on 22-October-1986. */
-/* Jack Dongarra, Argonne National Lab. */
-/* Jeremy Du Croz, Nag Central Office. */
-/* Sven Hammarling, Nag Central Office. */
-/* Richard Hanson, Sandia National Labs. */
-
-
-/* .. Parameters .. */
-/* .. Local Scalars .. */
-/* .. External Functions .. */
-/* .. External Subroutines .. */
-/* .. Intrinsic Functions .. */
-/* .. */
-/* .. Executable Statements .. */
-
-/* Test the input parameters. */
-
- /* Parameter adjustments */
- a_dim1 = *lda;
- a_offset = 1 + a_dim1 * 1;
- a -= a_offset;
- --x;
- --y;
-
- /* Function Body */
- info = 0;
- if (! lsame_(trans, "N", (ftnlen)1, (ftnlen)1) && ! lsame_(trans, "T", (
- ftnlen)1, (ftnlen)1) && ! lsame_(trans, "C", (ftnlen)1, (ftnlen)1)
- ) {
- info = 1;
- } else if (*m < 0) {
- info = 2;
- } else if (*n < 0) {
- info = 3;
- } else if (*lda < max(1,*m)) {
- info = 6;
- } else if (*incx == 0) {
- info = 8;
- } else if (*incy == 0) {
- info = 11;
- }
- if (info != 0) {
- xerbla_("CGEMV ", &info, (ftnlen)6);
- return 0;
- }
-
-/* Quick return if possible. */
-
- if (*m == 0 || *n == 0 || alpha->r == 0.f && alpha->i == 0.f && (beta->r
- == 1.f && beta->i == 0.f)) {
- return 0;
- }
-
- noconj = lsame_(trans, "T", (ftnlen)1, (ftnlen)1);
-
-/* Set LENX and LENY, the lengths of the vectors x and y, and set */
-/* up the start points in X and Y. */
-
- if (lsame_(trans, "N", (ftnlen)1, (ftnlen)1)) {
- lenx = *n;
- leny = *m;
- } else {
- lenx = *m;
- leny = *n;
- }
- if (*incx > 0) {
- kx = 1;
- } else {
- kx = 1 - (lenx - 1) * *incx;
- }
- if (*incy > 0) {
- ky = 1;
- } else {
- ky = 1 - (leny - 1) * *incy;
- }
-
-/* Start the operations. In this version the elements of A are */
-/* accessed sequentially with one pass through A. */
-
-/* First form y := beta*y. */
-
- if (beta->r != 1.f || beta->i != 0.f) {
- if (*incy == 1) {
- if (beta->r == 0.f && beta->i == 0.f) {
- i__1 = leny;
- for (i__ = 1; i__ <= i__1; ++i__) {
- i__2 = i__;
- y[i__2].r = 0.f, y[i__2].i = 0.f;
-/* L10: */
- }
- } else {
- i__1 = leny;
- for (i__ = 1; i__ <= i__1; ++i__) {
- i__2 = i__;
- i__3 = i__;
- q__1.r = beta->r * y[i__3].r - beta->i * y[i__3].i,
- q__1.i = beta->r * y[i__3].i + beta->i * y[i__3]
- .r;
- y[i__2].r = q__1.r, y[i__2].i = q__1.i;
-/* L20: */
- }
- }
- } else {
- iy = ky;
- if (beta->r == 0.f && beta->i == 0.f) {
- i__1 = leny;
- for (i__ = 1; i__ <= i__1; ++i__) {
- i__2 = iy;
- y[i__2].r = 0.f, y[i__2].i = 0.f;
- iy += *incy;
-/* L30: */
- }
- } else {
- i__1 = leny;
- for (i__ = 1; i__ <= i__1; ++i__) {
- i__2 = iy;
- i__3 = iy;
- q__1.r = beta->r * y[i__3].r - beta->i * y[i__3].i,
- q__1.i = beta->r * y[i__3].i + beta->i * y[i__3]
- .r;
- y[i__2].r = q__1.r, y[i__2].i = q__1.i;
- iy += *incy;
-/* L40: */
- }
- }
- }
- }
- if (alpha->r == 0.f && alpha->i == 0.f) {
- return 0;
- }
- if (lsame_(trans, "N", (ftnlen)1, (ftnlen)1)) {
-
-/* Form y := alpha*A*x + y. */
-
- jx = kx;
- if (*incy == 1) {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- i__2 = jx;
- if (x[i__2].r != 0.f || x[i__2].i != 0.f) {
- i__2 = jx;
- q__1.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i,
- q__1.i = alpha->r * x[i__2].i + alpha->i * x[i__2]
- .r;
- temp.r = q__1.r, temp.i = q__1.i;
- i__2 = *m;
- for (i__ = 1; i__ <= i__2; ++i__) {
- i__3 = i__;
- i__4 = i__;
- i__5 = i__ + j * a_dim1;
- q__2.r = temp.r * a[i__5].r - temp.i * a[i__5].i,
- q__2.i = temp.r * a[i__5].i + temp.i * a[i__5]
- .r;
- q__1.r = y[i__4].r + q__2.r, q__1.i = y[i__4].i +
- q__2.i;
- y[i__3].r = q__1.r, y[i__3].i = q__1.i;
-/* L50: */
- }
- }
- jx += *incx;
-/* L60: */
- }
- } else {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- i__2 = jx;
- if (x[i__2].r != 0.f || x[i__2].i != 0.f) {
- i__2 = jx;
- q__1.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i,
- q__1.i = alpha->r * x[i__2].i + alpha->i * x[i__2]
- .r;
- temp.r = q__1.r, temp.i = q__1.i;
- iy = ky;
- i__2 = *m;
- for (i__ = 1; i__ <= i__2; ++i__) {
- i__3 = iy;
- i__4 = iy;
- i__5 = i__ + j * a_dim1;
- q__2.r = temp.r * a[i__5].r - temp.i * a[i__5].i,
- q__2.i = temp.r * a[i__5].i + temp.i * a[i__5]
- .r;
- q__1.r = y[i__4].r + q__2.r, q__1.i = y[i__4].i +
- q__2.i;
- y[i__3].r = q__1.r, y[i__3].i = q__1.i;
- iy += *incy;
-/* L70: */
- }
- }
- jx += *incx;
-/* L80: */
- }
- }
- } else {
-
-/* Form y := alpha*A'*x + y or y := alpha*conjg( A' )*x + y. */
-
- jy = ky;
- if (*incx == 1) {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- temp.r = 0.f, temp.i = 0.f;
- if (noconj) {
- i__2 = *m;
- for (i__ = 1; i__ <= i__2; ++i__) {
- i__3 = i__ + j * a_dim1;
- i__4 = i__;
- q__2.r = a[i__3].r * x[i__4].r - a[i__3].i * x[i__4]
- .i, q__2.i = a[i__3].r * x[i__4].i + a[i__3]
- .i * x[i__4].r;
- q__1.r = temp.r + q__2.r, q__1.i = temp.i + q__2.i;
- temp.r = q__1.r, temp.i = q__1.i;
-/* L90: */
- }
- } else {
- i__2 = *m;
- for (i__ = 1; i__ <= i__2; ++i__) {
- r_cnjg(&q__3, &a[i__ + j * a_dim1]);
- i__3 = i__;
- q__2.r = q__3.r * x[i__3].r - q__3.i * x[i__3].i,
- q__2.i = q__3.r * x[i__3].i + q__3.i * x[i__3]
- .r;
- q__1.r = temp.r + q__2.r, q__1.i = temp.i + q__2.i;
- temp.r = q__1.r, temp.i = q__1.i;
-/* L100: */
- }
- }
- i__2 = jy;
- i__3 = jy;
- q__2.r = alpha->r * temp.r - alpha->i * temp.i, q__2.i =
- alpha->r * temp.i + alpha->i * temp.r;
- q__1.r = y[i__3].r + q__2.r, q__1.i = y[i__3].i + q__2.i;
- y[i__2].r = q__1.r, y[i__2].i = q__1.i;
- jy += *incy;
-/* L110: */
- }
- } else {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- temp.r = 0.f, temp.i = 0.f;
- ix = kx;
- if (noconj) {
- i__2 = *m;
- for (i__ = 1; i__ <= i__2; ++i__) {
- i__3 = i__ + j * a_dim1;
- i__4 = ix;
- q__2.r = a[i__3].r * x[i__4].r - a[i__3].i * x[i__4]
- .i, q__2.i = a[i__3].r * x[i__4].i + a[i__3]
- .i * x[i__4].r;
- q__1.r = temp.r + q__2.r, q__1.i = temp.i + q__2.i;
- temp.r = q__1.r, temp.i = q__1.i;
- ix += *incx;
-/* L120: */
- }
- } else {
- i__2 = *m;
- for (i__ = 1; i__ <= i__2; ++i__) {
- r_cnjg(&q__3, &a[i__ + j * a_dim1]);
- i__3 = ix;
- q__2.r = q__3.r * x[i__3].r - q__3.i * x[i__3].i,
- q__2.i = q__3.r * x[i__3].i + q__3.i * x[i__3]
- .r;
- q__1.r = temp.r + q__2.r, q__1.i = temp.i + q__2.i;
- temp.r = q__1.r, temp.i = q__1.i;
- ix += *incx;
-/* L130: */
- }
- }
- i__2 = jy;
- i__3 = jy;
- q__2.r = alpha->r * temp.r - alpha->i * temp.i, q__2.i =
- alpha->r * temp.i + alpha->i * temp.r;
- q__1.r = y[i__3].r + q__2.r, q__1.i = y[i__3].i + q__2.i;
- y[i__2].r = q__1.r, y[i__2].i = q__1.i;
- jy += *incy;
-/* L140: */
- }
- }
- }
-
- return 0;
-
-/* End of CGEMV . */
-
-} /* cgemv_ */
-
-/* Subroutine */ int cgerc_(integer *m, integer *n, complex *alpha, complex *
- x, integer *incx, complex *y, integer *incy, complex *a, integer *lda)
-{
- /* System generated locals */
- integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5;
- complex q__1, q__2;
-
- /* Builtin functions */
- void r_cnjg(complex *, complex *);
-
- /* Local variables */
- static integer i__, j, ix, jy, kx, info;
- static complex temp;
- extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen);
-
-/* .. Scalar Arguments .. */
-/* .. Array Arguments .. */
-/* .. */
-
-/* Purpose */
-/* ======= */
-
-/* CGERC performs the rank 1 operation */
-
-/* A := alpha*x*conjg( y' ) + A, */
-
-/* where alpha is a scalar, x is an m element vector, y is an n element */
-/* vector and A is an m by n matrix. */
-
-/* Parameters */
-/* ========== */
-
-/* M - INTEGER. */
-/* On entry, M specifies the number of rows of the matrix A. */
-/* M must be at least zero. */
-/* Unchanged on exit. */
-
-/* N - INTEGER. */
-/* On entry, N specifies the number of columns of the matrix A. */
-/* N must be at least zero. */
-/* Unchanged on exit. */
-
-/* ALPHA - COMPLEX . */
-/* On entry, ALPHA specifies the scalar alpha. */
-/* Unchanged on exit. */
-
-/* X - COMPLEX array of dimension at least */
-/* ( 1 + ( m - 1 )*abs( INCX ) ). */
-/* Before entry, the incremented array X must contain the m */
-/* element vector x. */
-/* Unchanged on exit. */
-
-/* INCX - INTEGER. */
-/* On entry, INCX specifies the increment for the elements of */
-/* X. INCX must not be zero. */
-/* Unchanged on exit. */
-
-/* Y - COMPLEX array of dimension at least */
-/* ( 1 + ( n - 1 )*abs( INCY ) ). */
-/* Before entry, the incremented array Y must contain the n */
-/* element vector y. */
-/* Unchanged on exit. */
-
-/* INCY - INTEGER. */
-/* On entry, INCY specifies the increment for the elements of */
-/* Y. INCY must not be zero. */
-/* Unchanged on exit. */
-
-/* A - COMPLEX array of DIMENSION ( LDA, n ). */
-/* Before entry, the leading m by n part of the array A must */
-/* contain the matrix of coefficients. On exit, A is */
-/* overwritten by the updated matrix. */
-
-/* LDA - INTEGER. */
-/* On entry, LDA specifies the first dimension of A as declared */
-/* in the calling (sub) program. LDA must be at least */
-/* max( 1, m ). */
-/* Unchanged on exit. */
-
-
-/* Level 2 Blas routine. */
-
-/* -- Written on 22-October-1986. */
-/* Jack Dongarra, Argonne National Lab. */
-/* Jeremy Du Croz, Nag Central Office. */
-/* Sven Hammarling, Nag Central Office. */
-/* Richard Hanson, Sandia National Labs. */
-
-
-/* .. Parameters .. */
-/* .. Local Scalars .. */
-/* .. External Subroutines .. */
-/* .. Intrinsic Functions .. */
-/* .. */
-/* .. Executable Statements .. */
-
-/* Test the input parameters. */
-
- /* Parameter adjustments */
- --x;
- --y;
- a_dim1 = *lda;
- a_offset = 1 + a_dim1 * 1;
- a -= a_offset;
-
- /* Function Body */
- info = 0;
- if (*m < 0) {
- info = 1;
- } else if (*n < 0) {
- info = 2;
- } else if (*incx == 0) {
- info = 5;
- } else if (*incy == 0) {
- info = 7;
- } else if (*lda < max(1,*m)) {
- info = 9;
- }
- if (info != 0) {
- xerbla_("CGERC ", &info, (ftnlen)6);
- return 0;
- }
-
-/* Quick return if possible. */
-
- if (*m == 0 || *n == 0 || alpha->r == 0.f && alpha->i == 0.f) {
- return 0;
- }
-
-/* Start the operations. In this version the elements of A are */
-/* accessed sequentially with one pass through A. */
-
- if (*incy > 0) {
- jy = 1;
- } else {
- jy = 1 - (*n - 1) * *incy;
- }
- if (*incx == 1) {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- i__2 = jy;
- if (y[i__2].r != 0.f || y[i__2].i != 0.f) {
- r_cnjg(&q__2, &y[jy]);
- q__1.r = alpha->r * q__2.r - alpha->i * q__2.i, q__1.i =
- alpha->r * q__2.i + alpha->i * q__2.r;
- temp.r = q__1.r, temp.i = q__1.i;
- i__2 = *m;
- for (i__ = 1; i__ <= i__2; ++i__) {
- i__3 = i__ + j * a_dim1;
- i__4 = i__ + j * a_dim1;
- i__5 = i__;
- q__2.r = x[i__5].r * temp.r - x[i__5].i * temp.i, q__2.i =
- x[i__5].r * temp.i + x[i__5].i * temp.r;
- q__1.r = a[i__4].r + q__2.r, q__1.i = a[i__4].i + q__2.i;
- a[i__3].r = q__1.r, a[i__3].i = q__1.i;
-/* L10: */
- }
- }
- jy += *incy;
-/* L20: */
- }
- } else {
- if (*incx > 0) {
- kx = 1;
- } else {
- kx = 1 - (*m - 1) * *incx;
- }
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- i__2 = jy;
- if (y[i__2].r != 0.f || y[i__2].i != 0.f) {
- r_cnjg(&q__2, &y[jy]);
- q__1.r = alpha->r * q__2.r - alpha->i * q__2.i, q__1.i =
- alpha->r * q__2.i + alpha->i * q__2.r;
- temp.r = q__1.r, temp.i = q__1.i;
- ix = kx;
- i__2 = *m;
- for (i__ = 1; i__ <= i__2; ++i__) {
- i__3 = i__ + j * a_dim1;
- i__4 = i__ + j * a_dim1;
- i__5 = ix;
- q__2.r = x[i__5].r * temp.r - x[i__5].i * temp.i, q__2.i =
- x[i__5].r * temp.i + x[i__5].i * temp.r;
- q__1.r = a[i__4].r + q__2.r, q__1.i = a[i__4].i + q__2.i;
- a[i__3].r = q__1.r, a[i__3].i = q__1.i;
- ix += *incx;
-/* L30: */
- }
- }
- jy += *incy;
-/* L40: */
- }
- }
-
- return 0;
-
-/* End of CGERC . */
-
-} /* cgerc_ */
-
-/* Subroutine */ int cgeru_(integer *m, integer *n, complex *alpha, complex *
- x, integer *incx, complex *y, integer *incy, complex *a, integer *lda)
-{
- /* System generated locals */
- integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5;
- complex q__1, q__2;
-
- /* Local variables */
- static integer i__, j, ix, jy, kx, info;
- static complex temp;
- extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen);
-
-/* .. Scalar Arguments .. */
-/* .. Array Arguments .. */
-/* .. */
-
-/* Purpose */
-/* ======= */
-
-/* CGERU performs the rank 1 operation */
-
-/* A := alpha*x*y' + A, */
-
-/* where alpha is a scalar, x is an m element vector, y is an n element */
-/* vector and A is an m by n matrix. */
-
-/* Parameters */
-/* ========== */
-
-/* M - INTEGER. */
-/* On entry, M specifies the number of rows of the matrix A. */
-/* M must be at least zero. */
-/* Unchanged on exit. */
-
-/* N - INTEGER. */
-/* On entry, N specifies the number of columns of the matrix A. */
-/* N must be at least zero. */
-/* Unchanged on exit. */
-
-/* ALPHA - COMPLEX . */
-/* On entry, ALPHA specifies the scalar alpha. */
-/* Unchanged on exit. */
-
-/* X - COMPLEX array of dimension at least */
-/* ( 1 + ( m - 1 )*abs( INCX ) ). */
-/* Before entry, the incremented array X must contain the m */
-/* element vector x. */
-/* Unchanged on exit. */
-
-/* INCX - INTEGER. */
-/* On entry, INCX specifies the increment for the elements of */
-/* X. INCX must not be zero. */
-/* Unchanged on exit. */
-
-/* Y - COMPLEX array of dimension at least */
-/* ( 1 + ( n - 1 )*abs( INCY ) ). */
-/* Before entry, the incremented array Y must contain the n */
-/* element vector y. */
-/* Unchanged on exit. */
-
-/* INCY - INTEGER. */
-/* On entry, INCY specifies the increment for the elements of */
-/* Y. INCY must not be zero. */
-/* Unchanged on exit. */
-
-/* A - COMPLEX array of DIMENSION ( LDA, n ). */
-/* Before entry, the leading m by n part of the array A must */
-/* contain the matrix of coefficients. On exit, A is */
-/* overwritten by the updated matrix. */
-
-/* LDA - INTEGER. */
-/* On entry, LDA specifies the first dimension of A as declared */
-/* in the calling (sub) program. LDA must be at least */
-/* max( 1, m ). */
-/* Unchanged on exit. */
-
-
-/* Level 2 Blas routine. */
-
-/* -- Written on 22-October-1986. */
-/* Jack Dongarra, Argonne National Lab. */
-/* Jeremy Du Croz, Nag Central Office. */
-/* Sven Hammarling, Nag Central Office. */
-/* Richard Hanson, Sandia National Labs. */
-
-
-/* .. Parameters .. */
-/* .. Local Scalars .. */
-/* .. External Subroutines .. */
-/* .. Intrinsic Functions .. */
-/* .. */
-/* .. Executable Statements .. */
-
-/* Test the input parameters. */
-
- /* Parameter adjustments */
- --x;
- --y;
- a_dim1 = *lda;
- a_offset = 1 + a_dim1 * 1;
- a -= a_offset;
-
- /* Function Body */
- info = 0;
- if (*m < 0) {
- info = 1;
- } else if (*n < 0) {
- info = 2;
- } else if (*incx == 0) {
- info = 5;
- } else if (*incy == 0) {
- info = 7;
- } else if (*lda < max(1,*m)) {
- info = 9;
- }
- if (info != 0) {
- xerbla_("CGERU ", &info, (ftnlen)6);
- return 0;
- }
-
-/* Quick return if possible. */
-
- if (*m == 0 || *n == 0 || alpha->r == 0.f && alpha->i == 0.f) {
- return 0;
- }
-
-/* Start the operations. In this version the elements of A are */
-/* accessed sequentially with one pass through A. */
-
- if (*incy > 0) {
- jy = 1;
- } else {
- jy = 1 - (*n - 1) * *incy;
- }
- if (*incx == 1) {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- i__2 = jy;
- if (y[i__2].r != 0.f || y[i__2].i != 0.f) {
- i__2 = jy;
- q__1.r = alpha->r * y[i__2].r - alpha->i * y[i__2].i, q__1.i =
- alpha->r * y[i__2].i + alpha->i * y[i__2].r;
- temp.r = q__1.r, temp.i = q__1.i;
- i__2 = *m;
- for (i__ = 1; i__ <= i__2; ++i__) {
- i__3 = i__ + j * a_dim1;
- i__4 = i__ + j * a_dim1;
- i__5 = i__;
- q__2.r = x[i__5].r * temp.r - x[i__5].i * temp.i, q__2.i =
- x[i__5].r * temp.i + x[i__5].i * temp.r;
- q__1.r = a[i__4].r + q__2.r, q__1.i = a[i__4].i + q__2.i;
- a[i__3].r = q__1.r, a[i__3].i = q__1.i;
-/* L10: */
- }
- }
- jy += *incy;
-/* L20: */
- }
- } else {
- if (*incx > 0) {
- kx = 1;
- } else {
- kx = 1 - (*m - 1) * *incx;
- }
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- i__2 = jy;
- if (y[i__2].r != 0.f || y[i__2].i != 0.f) {
- i__2 = jy;
- q__1.r = alpha->r * y[i__2].r - alpha->i * y[i__2].i, q__1.i =
- alpha->r * y[i__2].i + alpha->i * y[i__2].r;
- temp.r = q__1.r, temp.i = q__1.i;
- ix = kx;
- i__2 = *m;
- for (i__ = 1; i__ <= i__2; ++i__) {
- i__3 = i__ + j * a_dim1;
- i__4 = i__ + j * a_dim1;
- i__5 = ix;
- q__2.r = x[i__5].r * temp.r - x[i__5].i * temp.i, q__2.i =
- x[i__5].r * temp.i + x[i__5].i * temp.r;
- q__1.r = a[i__4].r + q__2.r, q__1.i = a[i__4].i + q__2.i;
- a[i__3].r = q__1.r, a[i__3].i = q__1.i;
- ix += *incx;
-/* L30: */
- }
- }
- jy += *incy;
-/* L40: */
- }
- }
-
- return 0;
-
-/* End of CGERU . */
-
-} /* cgeru_ */
-
-/* Subroutine */ int chbmv_(char *uplo, integer *n, integer *k, complex *
- alpha, complex *a, integer *lda, complex *x, integer *incx, complex *
- beta, complex *y, integer *incy, ftnlen uplo_len)
-{
- /* System generated locals */
- integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5;
- real r__1;
- complex q__1, q__2, q__3, q__4;
-
- /* Builtin functions */
- void r_cnjg(complex *, complex *);
-
- /* Local variables */
- static integer i__, j, l, ix, iy, jx, jy, kx, ky, info;
- static complex temp1, temp2;
- extern logical lsame_(char *, char *, ftnlen, ftnlen);
- static integer kplus1;
- extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen);
-
-/* .. Scalar Arguments .. */
-/* .. Array Arguments .. */
-/* .. */
-
-/* Purpose */
-/* ======= */
-
-/* CHBMV performs the matrix-vector operation */
-
-/* y := alpha*A*x + beta*y, */
-
-/* where alpha and beta are scalars, x and y are n element vectors and */
-/* A is an n by n hermitian band matrix, with k super-diagonals. */
-
-/* Parameters */
-/* ========== */
-
-/* UPLO - CHARACTER*1. */
-/* On entry, UPLO specifies whether the upper or lower */
-/* triangular part of the band matrix A is being supplied as */
-/* follows: */
-
-/* UPLO = 'U' or 'u' The upper triangular part of A is */
-/* being supplied. */
-
-/* UPLO = 'L' or 'l' The lower triangular part of A is */
-/* being supplied. */
-
-/* Unchanged on exit. */
-
-/* N - INTEGER. */
-/* On entry, N specifies the order of the matrix A. */
-/* N must be at least zero. */
-/* Unchanged on exit. */
-
-/* K - INTEGER. */
-/* On entry, K specifies the number of super-diagonals of the */
-/* matrix A. K must satisfy 0 .le. K. */
-/* Unchanged on exit. */
-
-/* ALPHA - COMPLEX . */
-/* On entry, ALPHA specifies the scalar alpha. */
-/* Unchanged on exit. */
-
-/* A - COMPLEX array of DIMENSION ( LDA, n ). */
-/* Before entry with UPLO = 'U' or 'u', the leading ( k + 1 ) */
-/* by n part of the array A must contain the upper triangular */
-/* band part of the hermitian matrix, supplied column by */
-/* column, with the leading diagonal of the matrix in row */
-/* ( k + 1 ) of the array, the first super-diagonal starting at */
-/* position 2 in row k, and so on. The top left k by k triangle */
-/* of the array A is not referenced. */
-/* The following program segment will transfer the upper */
-/* triangular part of a hermitian band matrix from conventional */
-/* full matrix storage to band storage: */
-
-/* DO 20, J = 1, N */
-/* M = K + 1 - J */
-/* DO 10, I = MAX( 1, J - K ), J */
-/* A( M + I, J ) = matrix( I, J ) */
-/* 10 CONTINUE */
-/* 20 CONTINUE */
-
-/* Before entry with UPLO = 'L' or 'l', the leading ( k + 1 ) */
-/* by n part of the array A must contain the lower triangular */
-/* band part of the hermitian matrix, supplied column by */
-/* column, with the leading diagonal of the matrix in row 1 of */
-/* the array, the first sub-diagonal starting at position 1 in */
-/* row 2, and so on. The bottom right k by k triangle of the */
-/* array A is not referenced. */
-/* The following program segment will transfer the lower */
-/* triangular part of a hermitian band matrix from conventional */
-/* full matrix storage to band storage: */
-
-/* DO 20, J = 1, N */
-/* M = 1 - J */
-/* DO 10, I = J, MIN( N, J + K ) */
-/* A( M + I, J ) = matrix( I, J ) */
-/* 10 CONTINUE */
-/* 20 CONTINUE */
-
-/* Note that the imaginary parts of the diagonal elements need */
-/* not be set and are assumed to be zero. */
-/* Unchanged on exit. */
-
-/* LDA - INTEGER. */
-/* On entry, LDA specifies the first dimension of A as declared */
-/* in the calling (sub) program. LDA must be at least */
-/* ( k + 1 ). */
-/* Unchanged on exit. */
-
-/* X - COMPLEX array of DIMENSION at least */
-/* ( 1 + ( n - 1 )*abs( INCX ) ). */
-/* Before entry, the incremented array X must contain the */
-/* vector x. */
-/* Unchanged on exit. */
-
-/* INCX - INTEGER. */
-/* On entry, INCX specifies the increment for the elements of */
-/* X. INCX must not be zero. */
-/* Unchanged on exit. */
-
-/* BETA - COMPLEX . */
-/* On entry, BETA specifies the scalar beta. */
-/* Unchanged on exit. */
-
-/* Y - COMPLEX array of DIMENSION at least */
-/* ( 1 + ( n - 1 )*abs( INCY ) ). */
-/* Before entry, the incremented array Y must contain the */
-/* vector y. On exit, Y is overwritten by the updated vector y. */
-
-/* INCY - INTEGER. */
-/* On entry, INCY specifies the increment for the elements of */
-/* Y. INCY must not be zero. */
-/* Unchanged on exit. */
-
-
-/* Level 2 Blas routine. */
-
-/* -- Written on 22-October-1986. */
-/* Jack Dongarra, Argonne National Lab. */
-/* Jeremy Du Croz, Nag Central Office. */
-/* Sven Hammarling, Nag Central Office. */
-/* Richard Hanson, Sandia National Labs. */
-
-
-/* .. Parameters .. */
-/* .. Local Scalars .. */
-/* .. External Functions .. */
-/* .. External Subroutines .. */
-/* .. Intrinsic Functions .. */
-/* .. */
-/* .. Executable Statements .. */
-
-/* Test the input parameters. */
-
- /* Parameter adjustments */
- a_dim1 = *lda;
- a_offset = 1 + a_dim1 * 1;
- a -= a_offset;
- --x;
- --y;
-
- /* Function Body */
- info = 0;
- if (! lsame_(uplo, "U", (ftnlen)1, (ftnlen)1) && ! lsame_(uplo, "L", (
- ftnlen)1, (ftnlen)1)) {
- info = 1;
- } else if (*n < 0) {
- info = 2;
- } else if (*k < 0) {
- info = 3;
- } else if (*lda < *k + 1) {
- info = 6;
- } else if (*incx == 0) {
- info = 8;
- } else if (*incy == 0) {
- info = 11;
- }
- if (info != 0) {
- xerbla_("CHBMV ", &info, (ftnlen)6);
- return 0;
- }
-
-/* Quick return if possible. */
-
- if (*n == 0 || alpha->r == 0.f && alpha->i == 0.f && (beta->r == 1.f &&
- beta->i == 0.f)) {
- return 0;
- }
-
-/* Set up the start points in X and Y. */
-
- if (*incx > 0) {
- kx = 1;
- } else {
- kx = 1 - (*n - 1) * *incx;
- }
- if (*incy > 0) {
- ky = 1;
- } else {
- ky = 1 - (*n - 1) * *incy;
- }
-
-/* Start the operations. In this version the elements of the array A */
-/* are accessed sequentially with one pass through A. */
-
-/* First form y := beta*y. */
-
- if (beta->r != 1.f || beta->i != 0.f) {
- if (*incy == 1) {
- if (beta->r == 0.f && beta->i == 0.f) {
- i__1 = *n;
- for (i__ = 1; i__ <= i__1; ++i__) {
- i__2 = i__;
- y[i__2].r = 0.f, y[i__2].i = 0.f;
-/* L10: */
- }
- } else {
- i__1 = *n;
- for (i__ = 1; i__ <= i__1; ++i__) {
- i__2 = i__;
- i__3 = i__;
- q__1.r = beta->r * y[i__3].r - beta->i * y[i__3].i,
- q__1.i = beta->r * y[i__3].i + beta->i * y[i__3]
- .r;
- y[i__2].r = q__1.r, y[i__2].i = q__1.i;
-/* L20: */
- }
- }
- } else {
- iy = ky;
- if (beta->r == 0.f && beta->i == 0.f) {
- i__1 = *n;
- for (i__ = 1; i__ <= i__1; ++i__) {
- i__2 = iy;
- y[i__2].r = 0.f, y[i__2].i = 0.f;
- iy += *incy;
-/* L30: */
- }
- } else {
- i__1 = *n;
- for (i__ = 1; i__ <= i__1; ++i__) {
- i__2 = iy;
- i__3 = iy;
- q__1.r = beta->r * y[i__3].r - beta->i * y[i__3].i,
- q__1.i = beta->r * y[i__3].i + beta->i * y[i__3]
- .r;
- y[i__2].r = q__1.r, y[i__2].i = q__1.i;
- iy += *incy;
-/* L40: */
- }
- }
- }
- }
- if (alpha->r == 0.f && alpha->i == 0.f) {
- return 0;
- }
- if (lsame_(uplo, "U", (ftnlen)1, (ftnlen)1)) {
-
-/* Form y when upper triangle of A is stored. */
-
- kplus1 = *k + 1;
- if (*incx == 1 && *incy == 1) {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- i__2 = j;
- q__1.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i, q__1.i =
- alpha->r * x[i__2].i + alpha->i * x[i__2].r;
- temp1.r = q__1.r, temp1.i = q__1.i;
- temp2.r = 0.f, temp2.i = 0.f;
- l = kplus1 - j;
-/* Computing MAX */
- i__2 = 1, i__3 = j - *k;
- i__4 = j - 1;
- for (i__ = max(i__2,i__3); i__ <= i__4; ++i__) {
- i__2 = i__;
- i__3 = i__;
- i__5 = l + i__ + j * a_dim1;
- q__2.r = temp1.r * a[i__5].r - temp1.i * a[i__5].i,
- q__2.i = temp1.r * a[i__5].i + temp1.i * a[i__5]
- .r;
- q__1.r = y[i__3].r + q__2.r, q__1.i = y[i__3].i + q__2.i;
- y[i__2].r = q__1.r, y[i__2].i = q__1.i;
- r_cnjg(&q__3, &a[l + i__ + j * a_dim1]);
- i__2 = i__;
- q__2.r = q__3.r * x[i__2].r - q__3.i * x[i__2].i, q__2.i =
- q__3.r * x[i__2].i + q__3.i * x[i__2].r;
- q__1.r = temp2.r + q__2.r, q__1.i = temp2.i + q__2.i;
- temp2.r = q__1.r, temp2.i = q__1.i;
-/* L50: */
- }
- i__4 = j;
- i__2 = j;
- i__3 = kplus1 + j * a_dim1;
- r__1 = a[i__3].r;
- q__3.r = r__1 * temp1.r, q__3.i = r__1 * temp1.i;
- q__2.r = y[i__2].r + q__3.r, q__2.i = y[i__2].i + q__3.i;
- q__4.r = alpha->r * temp2.r - alpha->i * temp2.i, q__4.i =
- alpha->r * temp2.i + alpha->i * temp2.r;
- q__1.r = q__2.r + q__4.r, q__1.i = q__2.i + q__4.i;
- y[i__4].r = q__1.r, y[i__4].i = q__1.i;
-/* L60: */
- }
- } else {
- jx = kx;
- jy = ky;
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- i__4 = jx;
- q__1.r = alpha->r * x[i__4].r - alpha->i * x[i__4].i, q__1.i =
- alpha->r * x[i__4].i + alpha->i * x[i__4].r;
- temp1.r = q__1.r, temp1.i = q__1.i;
- temp2.r = 0.f, temp2.i = 0.f;
- ix = kx;
- iy = ky;
- l = kplus1 - j;
-/* Computing MAX */
- i__4 = 1, i__2 = j - *k;
- i__3 = j - 1;
- for (i__ = max(i__4,i__2); i__ <= i__3; ++i__) {
- i__4 = iy;
- i__2 = iy;
- i__5 = l + i__ + j * a_dim1;
- q__2.r = temp1.r * a[i__5].r - temp1.i * a[i__5].i,
- q__2.i = temp1.r * a[i__5].i + temp1.i * a[i__5]
- .r;
- q__1.r = y[i__2].r + q__2.r, q__1.i = y[i__2].i + q__2.i;
- y[i__4].r = q__1.r, y[i__4].i = q__1.i;
- r_cnjg(&q__3, &a[l + i__ + j * a_dim1]);
- i__4 = ix;
- q__2.r = q__3.r * x[i__4].r - q__3.i * x[i__4].i, q__2.i =
- q__3.r * x[i__4].i + q__3.i * x[i__4].r;
- q__1.r = temp2.r + q__2.r, q__1.i = temp2.i + q__2.i;
- temp2.r = q__1.r, temp2.i = q__1.i;
- ix += *incx;
- iy += *incy;
-/* L70: */
- }
- i__3 = jy;
- i__4 = jy;
- i__2 = kplus1 + j * a_dim1;
- r__1 = a[i__2].r;
- q__3.r = r__1 * temp1.r, q__3.i = r__1 * temp1.i;
- q__2.r = y[i__4].r + q__3.r, q__2.i = y[i__4].i + q__3.i;
- q__4.r = alpha->r * temp2.r - alpha->i * temp2.i, q__4.i =
- alpha->r * temp2.i + alpha->i * temp2.r;
- q__1.r = q__2.r + q__4.r, q__1.i = q__2.i + q__4.i;
- y[i__3].r = q__1.r, y[i__3].i = q__1.i;
- jx += *incx;
- jy += *incy;
- if (j > *k) {
- kx += *incx;
- ky += *incy;
- }
-/* L80: */
- }
- }
- } else {
-
-/* Form y when lower triangle of A is stored. */
-
- if (*incx == 1 && *incy == 1) {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- i__3 = j;
- q__1.r = alpha->r * x[i__3].r - alpha->i * x[i__3].i, q__1.i =
- alpha->r * x[i__3].i + alpha->i * x[i__3].r;
- temp1.r = q__1.r, temp1.i = q__1.i;
- temp2.r = 0.f, temp2.i = 0.f;
- i__3 = j;
- i__4 = j;
- i__2 = j * a_dim1 + 1;
- r__1 = a[i__2].r;
- q__2.r = r__1 * temp1.r, q__2.i = r__1 * temp1.i;
- q__1.r = y[i__4].r + q__2.r, q__1.i = y[i__4].i + q__2.i;
- y[i__3].r = q__1.r, y[i__3].i = q__1.i;
- l = 1 - j;
-/* Computing MIN */
- i__4 = *n, i__2 = j + *k;
- i__3 = min(i__4,i__2);
- for (i__ = j + 1; i__ <= i__3; ++i__) {
- i__4 = i__;
- i__2 = i__;
- i__5 = l + i__ + j * a_dim1;
- q__2.r = temp1.r * a[i__5].r - temp1.i * a[i__5].i,
- q__2.i = temp1.r * a[i__5].i + temp1.i * a[i__5]
- .r;
- q__1.r = y[i__2].r + q__2.r, q__1.i = y[i__2].i + q__2.i;
- y[i__4].r = q__1.r, y[i__4].i = q__1.i;
- r_cnjg(&q__3, &a[l + i__ + j * a_dim1]);
- i__4 = i__;
- q__2.r = q__3.r * x[i__4].r - q__3.i * x[i__4].i, q__2.i =
- q__3.r * x[i__4].i + q__3.i * x[i__4].r;
- q__1.r = temp2.r + q__2.r, q__1.i = temp2.i + q__2.i;
- temp2.r = q__1.r, temp2.i = q__1.i;
-/* L90: */
- }
- i__3 = j;
- i__4 = j;
- q__2.r = alpha->r * temp2.r - alpha->i * temp2.i, q__2.i =
- alpha->r * temp2.i + alpha->i * temp2.r;
- q__1.r = y[i__4].r + q__2.r, q__1.i = y[i__4].i + q__2.i;
- y[i__3].r = q__1.r, y[i__3].i = q__1.i;
-/* L100: */
- }
- } else {
- jx = kx;
- jy = ky;
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- i__3 = jx;
- q__1.r = alpha->r * x[i__3].r - alpha->i * x[i__3].i, q__1.i =
- alpha->r * x[i__3].i + alpha->i * x[i__3].r;
- temp1.r = q__1.r, temp1.i = q__1.i;
- temp2.r = 0.f, temp2.i = 0.f;
- i__3 = jy;
- i__4 = jy;
- i__2 = j * a_dim1 + 1;
- r__1 = a[i__2].r;
- q__2.r = r__1 * temp1.r, q__2.i = r__1 * temp1.i;
- q__1.r = y[i__4].r + q__2.r, q__1.i = y[i__4].i + q__2.i;
- y[i__3].r = q__1.r, y[i__3].i = q__1.i;
- l = 1 - j;
- ix = jx;
- iy = jy;
-/* Computing MIN */
- i__4 = *n, i__2 = j + *k;
- i__3 = min(i__4,i__2);
- for (i__ = j + 1; i__ <= i__3; ++i__) {
- ix += *incx;
- iy += *incy;
- i__4 = iy;
- i__2 = iy;
- i__5 = l + i__ + j * a_dim1;
- q__2.r = temp1.r * a[i__5].r - temp1.i * a[i__5].i,
- q__2.i = temp1.r * a[i__5].i + temp1.i * a[i__5]
- .r;
- q__1.r = y[i__2].r + q__2.r, q__1.i = y[i__2].i + q__2.i;
- y[i__4].r = q__1.r, y[i__4].i = q__1.i;
- r_cnjg(&q__3, &a[l + i__ + j * a_dim1]);
- i__4 = ix;
- q__2.r = q__3.r * x[i__4].r - q__3.i * x[i__4].i, q__2.i =
- q__3.r * x[i__4].i + q__3.i * x[i__4].r;
- q__1.r = temp2.r + q__2.r, q__1.i = temp2.i + q__2.i;
- temp2.r = q__1.r, temp2.i = q__1.i;
-/* L110: */
- }
- i__3 = jy;
- i__4 = jy;
- q__2.r = alpha->r * temp2.r - alpha->i * temp2.i, q__2.i =
- alpha->r * temp2.i + alpha->i * temp2.r;
- q__1.r = y[i__4].r + q__2.r, q__1.i = y[i__4].i + q__2.i;
- y[i__3].r = q__1.r, y[i__3].i = q__1.i;
- jx += *incx;
- jy += *incy;
-/* L120: */
- }
- }
- }
-
- return 0;
-
-/* End of CHBMV . */
-
-} /* chbmv_ */
-
-/* Subroutine */ int chemm_(char *side, char *uplo, integer *m, integer *n,
- complex *alpha, complex *a, integer *lda, complex *b, integer *ldb,
- complex *beta, complex *c__, integer *ldc, ftnlen side_len, ftnlen
- uplo_len)
-{
- /* System generated locals */
- integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2,
- i__3, i__4, i__5, i__6;
- real r__1;
- complex q__1, q__2, q__3, q__4, q__5;
-
- /* Builtin functions */
- void r_cnjg(complex *, complex *);
-
- /* Local variables */
- static integer i__, j, k, info;
- static complex temp1, temp2;
- extern logical lsame_(char *, char *, ftnlen, ftnlen);
- static integer nrowa;
- static logical upper;
- extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen);
-
-/* .. Scalar Arguments .. */
-/* .. Array Arguments .. */
-/* .. */
-
-/* Purpose */
-/* ======= */
-
-/* CHEMM performs one of the matrix-matrix operations */
-
-/* C := alpha*A*B + beta*C, */
-
-/* or */
-
-/* C := alpha*B*A + beta*C, */
-
-/* where alpha and beta are scalars, A is an hermitian matrix and B and */
-/* C are m by n matrices. */
-
-/* Parameters */
-/* ========== */
-
-/* SIDE - CHARACTER*1. */
-/* On entry, SIDE specifies whether the hermitian matrix A */
-/* appears on the left or right in the operation as follows: */
-
-/* SIDE = 'L' or 'l' C := alpha*A*B + beta*C, */
-
-/* SIDE = 'R' or 'r' C := alpha*B*A + beta*C, */
-
-/* Unchanged on exit. */
-
-/* UPLO - CHARACTER*1. */
-/* On entry, UPLO specifies whether the upper or lower */
-/* triangular part of the hermitian matrix A is to be */
-/* referenced as follows: */
-
-/* UPLO = 'U' or 'u' Only the upper triangular part of the */
-/* hermitian matrix is to be referenced. */
-
-/* UPLO = 'L' or 'l' Only the lower triangular part of the */
-/* hermitian matrix is to be referenced. */
-
-/* Unchanged on exit. */
-
-/* M - INTEGER. */
-/* On entry, M specifies the number of rows of the matrix C. */
-/* M must be at least zero. */
-/* Unchanged on exit. */
-
-/* N - INTEGER. */
-/* On entry, N specifies the number of columns of the matrix C. */
-/* N must be at least zero. */
-/* Unchanged on exit. */
-
-/* ALPHA - COMPLEX . */
-/* On entry, ALPHA specifies the scalar alpha. */
-/* Unchanged on exit. */
-
-/* A - COMPLEX array of DIMENSION ( LDA, ka ), where ka is */
-/* m when SIDE = 'L' or 'l' and is n otherwise. */
-/* Before entry with SIDE = 'L' or 'l', the m by m part of */
-/* the array A must contain the hermitian matrix, such that */
-/* when UPLO = 'U' or 'u', the leading m by m upper triangular */
-/* part of the array A must contain the upper triangular part */
-/* of the hermitian matrix and the strictly lower triangular */
-/* part of A is not referenced, and when UPLO = 'L' or 'l', */
-/* the leading m by m lower triangular part of the array A */
-/* must contain the lower triangular part of the hermitian */
-/* matrix and the strictly upper triangular part of A is not */
-/* referenced. */
-/* Before entry with SIDE = 'R' or 'r', the n by n part of */
-/* the array A must contain the hermitian matrix, such that */
-/* when UPLO = 'U' or 'u', the leading n by n upper triangular */
-/* part of the array A must contain the upper triangular part */
-/* of the hermitian matrix and the strictly lower triangular */
-/* part of A is not referenced, and when UPLO = 'L' or 'l', */
-/* the leading n by n lower triangular part of the array A */
-/* must contain the lower triangular part of the hermitian */
-/* matrix and the strictly upper triangular part of A is not */
-/* referenced. */
-/* Note that the imaginary parts of the diagonal elements need */
-/* not be set, they are assumed to be zero. */
-/* Unchanged on exit. */
-
-/* LDA - INTEGER. */
-/* On entry, LDA specifies the first dimension of A as declared */
-/* in the calling (sub) program. When SIDE = 'L' or 'l' then */
-/* LDA must be at least max( 1, m ), otherwise LDA must be at */
-/* least max( 1, n ). */
-/* Unchanged on exit. */
-
-/* B - COMPLEX array of DIMENSION ( LDB, n ). */
-/* Before entry, the leading m by n part of the array B must */
-/* contain the matrix B. */
-/* Unchanged on exit. */
-
-/* LDB - INTEGER. */
-/* On entry, LDB specifies the first dimension of B as declared */
-/* in the calling (sub) program. LDB must be at least */
-/* max( 1, m ). */
-/* Unchanged on exit. */
-
-/* BETA - COMPLEX . */
-/* On entry, BETA specifies the scalar beta. When BETA is */
-/* supplied as zero then C need not be set on input. */
-/* Unchanged on exit. */
-
-/* C - COMPLEX array of DIMENSION ( LDC, n ). */
-/* Before entry, the leading m by n part of the array C must */
-/* contain the matrix C, except when beta is zero, in which */
-/* case C need not be set on entry. */
-/* On exit, the array C is overwritten by the m by n updated */
-/* matrix. */
-
-/* LDC - INTEGER. */
-/* On entry, LDC specifies the first dimension of C as declared */
-/* in the calling (sub) program. LDC must be at least */
-/* max( 1, m ). */
-/* Unchanged on exit. */
-
-
-/* Level 3 Blas routine. */
-
-/* -- Written on 8-February-1989. */
-/* Jack Dongarra, Argonne National Laboratory. */
-/* Iain Duff, AERE Harwell. */
-/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */
-/* Sven Hammarling, Numerical Algorithms Group Ltd. */
-
-
-/* .. External Functions .. */
-/* .. External Subroutines .. */
-/* .. Intrinsic Functions .. */
-/* .. Local Scalars .. */
-/* .. Parameters .. */
-/* .. */
-/* .. Executable Statements .. */
-
-/* Set NROWA as the number of rows of A. */
-
- /* Parameter adjustments */
- a_dim1 = *lda;
- a_offset = 1 + a_dim1 * 1;
- a -= a_offset;
- b_dim1 = *ldb;
- b_offset = 1 + b_dim1 * 1;
- b -= b_offset;
- c_dim1 = *ldc;
- c_offset = 1 + c_dim1 * 1;
- c__ -= c_offset;
-
- /* Function Body */
- if (lsame_(side, "L", (ftnlen)1, (ftnlen)1)) {
- nrowa = *m;
- } else {
- nrowa = *n;
- }
- upper = lsame_(uplo, "U", (ftnlen)1, (ftnlen)1);
-
-/* Test the input parameters. */
-
- info = 0;
- if (! lsame_(side, "L", (ftnlen)1, (ftnlen)1) && ! lsame_(side, "R", (
- ftnlen)1, (ftnlen)1)) {
- info = 1;
- } else if (! upper && ! lsame_(uplo, "L", (ftnlen)1, (ftnlen)1)) {
- info = 2;
- } else if (*m < 0) {
- info = 3;
- } else if (*n < 0) {
- info = 4;
- } else if (*lda < max(1,nrowa)) {
- info = 7;
- } else if (*ldb < max(1,*m)) {
- info = 9;
- } else if (*ldc < max(1,*m)) {
- info = 12;
- }
- if (info != 0) {
- xerbla_("CHEMM ", &info, (ftnlen)6);
- return 0;
- }
-
-/* Quick return if possible. */
-
- if (*m == 0 || *n == 0 || alpha->r == 0.f && alpha->i == 0.f && (beta->r
- == 1.f && beta->i == 0.f)) {
- return 0;
- }
-
-/* And when alpha.eq.zero. */
-
- if (alpha->r == 0.f && alpha->i == 0.f) {
- if (beta->r == 0.f && beta->i == 0.f) {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- i__2 = *m;
- for (i__ = 1; i__ <= i__2; ++i__) {
- i__3 = i__ + j * c_dim1;
- c__[i__3].r = 0.f, c__[i__3].i = 0.f;
-/* L10: */
- }
-/* L20: */
- }
- } else {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- i__2 = *m;
- for (i__ = 1; i__ <= i__2; ++i__) {
- i__3 = i__ + j * c_dim1;
- i__4 = i__ + j * c_dim1;
- q__1.r = beta->r * c__[i__4].r - beta->i * c__[i__4].i,
- q__1.i = beta->r * c__[i__4].i + beta->i * c__[
- i__4].r;
- c__[i__3].r = q__1.r, c__[i__3].i = q__1.i;
-/* L30: */
- }
-/* L40: */
- }
- }
- return 0;
- }
-
-/* Start the operations. */
-
- if (lsame_(side, "L", (ftnlen)1, (ftnlen)1)) {
-
-/* Form C := alpha*A*B + beta*C. */
-
- if (upper) {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- i__2 = *m;
- for (i__ = 1; i__ <= i__2; ++i__) {
- i__3 = i__ + j * b_dim1;
- q__1.r = alpha->r * b[i__3].r - alpha->i * b[i__3].i,
- q__1.i = alpha->r * b[i__3].i + alpha->i * b[i__3]
- .r;
- temp1.r = q__1.r, temp1.i = q__1.i;
- temp2.r = 0.f, temp2.i = 0.f;
- i__3 = i__ - 1;
- for (k = 1; k <= i__3; ++k) {
- i__4 = k + j * c_dim1;
- i__5 = k + j * c_dim1;
- i__6 = k + i__ * a_dim1;
- q__2.r = temp1.r * a[i__6].r - temp1.i * a[i__6].i,
- q__2.i = temp1.r * a[i__6].i + temp1.i * a[
- i__6].r;
- q__1.r = c__[i__5].r + q__2.r, q__1.i = c__[i__5].i +
- q__2.i;
- c__[i__4].r = q__1.r, c__[i__4].i = q__1.i;
- i__4 = k + j * b_dim1;
- r_cnjg(&q__3, &a[k + i__ * a_dim1]);
- q__2.r = b[i__4].r * q__3.r - b[i__4].i * q__3.i,
- q__2.i = b[i__4].r * q__3.i + b[i__4].i *
- q__3.r;
- q__1.r = temp2.r + q__2.r, q__1.i = temp2.i + q__2.i;
- temp2.r = q__1.r, temp2.i = q__1.i;
-/* L50: */
- }
- if (beta->r == 0.f && beta->i == 0.f) {
- i__3 = i__ + j * c_dim1;
- i__4 = i__ + i__ * a_dim1;
- r__1 = a[i__4].r;
- q__2.r = r__1 * temp1.r, q__2.i = r__1 * temp1.i;
- q__3.r = alpha->r * temp2.r - alpha->i * temp2.i,
- q__3.i = alpha->r * temp2.i + alpha->i *
- temp2.r;
- q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
- c__[i__3].r = q__1.r, c__[i__3].i = q__1.i;
- } else {
- i__3 = i__ + j * c_dim1;
- i__4 = i__ + j * c_dim1;
- q__3.r = beta->r * c__[i__4].r - beta->i * c__[i__4]
- .i, q__3.i = beta->r * c__[i__4].i + beta->i *
- c__[i__4].r;
- i__5 = i__ + i__ * a_dim1;
- r__1 = a[i__5].r;
- q__4.r = r__1 * temp1.r, q__4.i = r__1 * temp1.i;
- q__2.r = q__3.r + q__4.r, q__2.i = q__3.i + q__4.i;
- q__5.r = alpha->r * temp2.r - alpha->i * temp2.i,
- q__5.i = alpha->r * temp2.i + alpha->i *
- temp2.r;
- q__1.r = q__2.r + q__5.r, q__1.i = q__2.i + q__5.i;
- c__[i__3].r = q__1.r, c__[i__3].i = q__1.i;
- }
-/* L60: */
- }
-/* L70: */
- }
- } else {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- for (i__ = *m; i__ >= 1; --i__) {
- i__2 = i__ + j * b_dim1;
- q__1.r = alpha->r * b[i__2].r - alpha->i * b[i__2].i,
- q__1.i = alpha->r * b[i__2].i + alpha->i * b[i__2]
- .r;
- temp1.r = q__1.r, temp1.i = q__1.i;
- temp2.r = 0.f, temp2.i = 0.f;
- i__2 = *m;
- for (k = i__ + 1; k <= i__2; ++k) {
- i__3 = k + j * c_dim1;
- i__4 = k + j * c_dim1;
- i__5 = k + i__ * a_dim1;
- q__2.r = temp1.r * a[i__5].r - temp1.i * a[i__5].i,
- q__2.i = temp1.r * a[i__5].i + temp1.i * a[
- i__5].r;
- q__1.r = c__[i__4].r + q__2.r, q__1.i = c__[i__4].i +
- q__2.i;
- c__[i__3].r = q__1.r, c__[i__3].i = q__1.i;
- i__3 = k + j * b_dim1;
- r_cnjg(&q__3, &a[k + i__ * a_dim1]);
- q__2.r = b[i__3].r * q__3.r - b[i__3].i * q__3.i,
- q__2.i = b[i__3].r * q__3.i + b[i__3].i *
- q__3.r;
- q__1.r = temp2.r + q__2.r, q__1.i = temp2.i + q__2.i;
- temp2.r = q__1.r, temp2.i = q__1.i;
-/* L80: */
- }
- if (beta->r == 0.f && beta->i == 0.f) {
- i__2 = i__ + j * c_dim1;
- i__3 = i__ + i__ * a_dim1;
- r__1 = a[i__3].r;
- q__2.r = r__1 * temp1.r, q__2.i = r__1 * temp1.i;
- q__3.r = alpha->r * temp2.r - alpha->i * temp2.i,
- q__3.i = alpha->r * temp2.i + alpha->i *
- temp2.r;
- q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
- c__[i__2].r = q__1.r, c__[i__2].i = q__1.i;
- } else {
- i__2 = i__ + j * c_dim1;
- i__3 = i__ + j * c_dim1;
- q__3.r = beta->r * c__[i__3].r - beta->i * c__[i__3]
- .i, q__3.i = beta->r * c__[i__3].i + beta->i *
- c__[i__3].r;
- i__4 = i__ + i__ * a_dim1;
- r__1 = a[i__4].r;
- q__4.r = r__1 * temp1.r, q__4.i = r__1 * temp1.i;
- q__2.r = q__3.r + q__4.r, q__2.i = q__3.i + q__4.i;
- q__5.r = alpha->r * temp2.r - alpha->i * temp2.i,
- q__5.i = alpha->r * temp2.i + alpha->i *
- temp2.r;
- q__1.r = q__2.r + q__5.r, q__1.i = q__2.i + q__5.i;
- c__[i__2].r = q__1.r, c__[i__2].i = q__1.i;
- }
-/* L90: */
- }
-/* L100: */
- }
- }
- } else {
-
-/* Form C := alpha*B*A + beta*C. */
-
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- i__2 = j + j * a_dim1;
- r__1 = a[i__2].r;
- q__1.r = r__1 * alpha->r, q__1.i = r__1 * alpha->i;
- temp1.r = q__1.r, temp1.i = q__1.i;
- if (beta->r == 0.f && beta->i == 0.f) {
- i__2 = *m;
- for (i__ = 1; i__ <= i__2; ++i__) {
- i__3 = i__ + j * c_dim1;
- i__4 = i__ + j * b_dim1;
- q__1.r = temp1.r * b[i__4].r - temp1.i * b[i__4].i,
- q__1.i = temp1.r * b[i__4].i + temp1.i * b[i__4]
- .r;
- c__[i__3].r = q__1.r, c__[i__3].i = q__1.i;
-/* L110: */
- }
- } else {
- i__2 = *m;
- for (i__ = 1; i__ <= i__2; ++i__) {
- i__3 = i__ + j * c_dim1;
- i__4 = i__ + j * c_dim1;
- q__2.r = beta->r * c__[i__4].r - beta->i * c__[i__4].i,
- q__2.i = beta->r * c__[i__4].i + beta->i * c__[
- i__4].r;
- i__5 = i__ + j * b_dim1;
- q__3.r = temp1.r * b[i__5].r - temp1.i * b[i__5].i,
- q__3.i = temp1.r * b[i__5].i + temp1.i * b[i__5]
- .r;
- q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
- c__[i__3].r = q__1.r, c__[i__3].i = q__1.i;
-/* L120: */
- }
- }
- i__2 = j - 1;
- for (k = 1; k <= i__2; ++k) {
- if (upper) {
- i__3 = k + j * a_dim1;
- q__1.r = alpha->r * a[i__3].r - alpha->i * a[i__3].i,
- q__1.i = alpha->r * a[i__3].i + alpha->i * a[i__3]
- .r;
- temp1.r = q__1.r, temp1.i = q__1.i;
- } else {
- r_cnjg(&q__2, &a[j + k * a_dim1]);
- q__1.r = alpha->r * q__2.r - alpha->i * q__2.i, q__1.i =
- alpha->r * q__2.i + alpha->i * q__2.r;
- temp1.r = q__1.r, temp1.i = q__1.i;
- }
- i__3 = *m;
- for (i__ = 1; i__ <= i__3; ++i__) {
- i__4 = i__ + j * c_dim1;
- i__5 = i__ + j * c_dim1;
- i__6 = i__ + k * b_dim1;
- q__2.r = temp1.r * b[i__6].r - temp1.i * b[i__6].i,
- q__2.i = temp1.r * b[i__6].i + temp1.i * b[i__6]
- .r;
- q__1.r = c__[i__5].r + q__2.r, q__1.i = c__[i__5].i +
- q__2.i;
- c__[i__4].r = q__1.r, c__[i__4].i = q__1.i;
-/* L130: */
- }
-/* L140: */
- }
- i__2 = *n;
- for (k = j + 1; k <= i__2; ++k) {
- if (upper) {
- r_cnjg(&q__2, &a[j + k * a_dim1]);
- q__1.r = alpha->r * q__2.r - alpha->i * q__2.i, q__1.i =
- alpha->r * q__2.i + alpha->i * q__2.r;
- temp1.r = q__1.r, temp1.i = q__1.i;
- } else {
- i__3 = k + j * a_dim1;
- q__1.r = alpha->r * a[i__3].r - alpha->i * a[i__3].i,
- q__1.i = alpha->r * a[i__3].i + alpha->i * a[i__3]
- .r;
- temp1.r = q__1.r, temp1.i = q__1.i;
- }
- i__3 = *m;
- for (i__ = 1; i__ <= i__3; ++i__) {
- i__4 = i__ + j * c_dim1;
- i__5 = i__ + j * c_dim1;
- i__6 = i__ + k * b_dim1;
- q__2.r = temp1.r * b[i__6].r - temp1.i * b[i__6].i,
- q__2.i = temp1.r * b[i__6].i + temp1.i * b[i__6]
- .r;
- q__1.r = c__[i__5].r + q__2.r, q__1.i = c__[i__5].i +
- q__2.i;
- c__[i__4].r = q__1.r, c__[i__4].i = q__1.i;
-/* L150: */
- }
-/* L160: */
- }
-/* L170: */
- }
- }
-
- return 0;
-
-/* End of CHEMM . */
-
-} /* chemm_ */
-
-/* Subroutine */ int chemv_(char *uplo, integer *n, complex *alpha, complex *
- a, integer *lda, complex *x, integer *incx, complex *beta, complex *y,
- integer *incy, ftnlen uplo_len)
-{
- /* System generated locals */
- integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5;
- real r__1;
- complex q__1, q__2, q__3, q__4;
-
- /* Builtin functions */
- void r_cnjg(complex *, complex *);
-
- /* Local variables */
- static integer i__, j, ix, iy, jx, jy, kx, ky, info;
- static complex temp1, temp2;
- extern logical lsame_(char *, char *, ftnlen, ftnlen);
- extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen);
-
-/* .. Scalar Arguments .. */
-/* .. Array Arguments .. */
-/* .. */
-
-/* Purpose */
-/* ======= */
-
-/* CHEMV performs the matrix-vector operation */
-
-/* y := alpha*A*x + beta*y, */
-
-/* where alpha and beta are scalars, x and y are n element vectors and */
-/* A is an n by n hermitian matrix. */
-
-/* Parameters */
-/* ========== */
-
-/* UPLO - CHARACTER*1. */
-/* On entry, UPLO specifies whether the upper or lower */
-/* triangular part of the array A is to be referenced as */
-/* follows: */
-
-/* UPLO = 'U' or 'u' Only the upper triangular part of A */
-/* is to be referenced. */
-
-/* UPLO = 'L' or 'l' Only the lower triangular part of A */
-/* is to be referenced. */
-
-/* Unchanged on exit. */
-
-/* N - INTEGER. */
-/* On entry, N specifies the order of the matrix A. */
-/* N must be at least zero. */
-/* Unchanged on exit. */
-
-/* ALPHA - COMPLEX . */
-/* On entry, ALPHA specifies the scalar alpha. */
-/* Unchanged on exit. */
-
-/* A - COMPLEX array of DIMENSION ( LDA, n ). */
-/* Before entry with UPLO = 'U' or 'u', the leading n by n */
-/* upper triangular part of the array A must contain the upper */
-/* triangular part of the hermitian matrix and the strictly */
-/* lower triangular part of A is not referenced. */
-/* Before entry with UPLO = 'L' or 'l', the leading n by n */
-/* lower triangular part of the array A must contain the lower */
-/* triangular part of the hermitian matrix and the strictly */
-/* upper triangular part of A is not referenced. */
-/* Note that the imaginary parts of the diagonal elements need */
-/* not be set and are assumed to be zero. */
-/* Unchanged on exit. */
-
-/* LDA - INTEGER. */
-/* On entry, LDA specifies the first dimension of A as declared */
-/* in the calling (sub) program. LDA must be at least */
-/* max( 1, n ). */
-/* Unchanged on exit. */
-
-/* X - COMPLEX array of dimension at least */
-/* ( 1 + ( n - 1 )*abs( INCX ) ). */
-/* Before entry, the incremented array X must contain the n */
-/* element vector x. */
-/* Unchanged on exit. */
-
-/* INCX - INTEGER. */
-/* On entry, INCX specifies the increment for the elements of */
-/* X. INCX must not be zero. */
-/* Unchanged on exit. */
-
-/* BETA - COMPLEX . */
-/* On entry, BETA specifies the scalar beta. When BETA is */
-/* supplied as zero then Y need not be set on input. */
-/* Unchanged on exit. */
-
-/* Y - COMPLEX array of dimension at least */
-/* ( 1 + ( n - 1 )*abs( INCY ) ). */
-/* Before entry, the incremented array Y must contain the n */
-/* element vector y. On exit, Y is overwritten by the updated */
-/* vector y. */
-
-/* INCY - INTEGER. */
-/* On entry, INCY specifies the increment for the elements of */
-/* Y. INCY must not be zero. */
-/* Unchanged on exit. */
-
-
-/* Level 2 Blas routine. */
-
-/* -- Written on 22-October-1986. */
-/* Jack Dongarra, Argonne National Lab. */
-/* Jeremy Du Croz, Nag Central Office. */
-/* Sven Hammarling, Nag Central Office. */
-/* Richard Hanson, Sandia National Labs. */
-
-
-/* .. Parameters .. */
-/* .. Local Scalars .. */
-/* .. External Functions .. */
-/* .. External Subroutines .. */
-/* .. Intrinsic Functions .. */
-/* .. */
-/* .. Executable Statements .. */
-
-/* Test the input parameters. */
-
- /* Parameter adjustments */
- a_dim1 = *lda;
- a_offset = 1 + a_dim1 * 1;
- a -= a_offset;
- --x;
- --y;
-
- /* Function Body */
- info = 0;
- if (! lsame_(uplo, "U", (ftnlen)1, (ftnlen)1) && ! lsame_(uplo, "L", (
- ftnlen)1, (ftnlen)1)) {
- info = 1;
- } else if (*n < 0) {
- info = 2;
- } else if (*lda < max(1,*n)) {
- info = 5;
- } else if (*incx == 0) {
- info = 7;
- } else if (*incy == 0) {
- info = 10;
- }
- if (info != 0) {
- xerbla_("CHEMV ", &info, (ftnlen)6);
- return 0;
- }
-
-/* Quick return if possible. */
-
- if (*n == 0 || alpha->r == 0.f && alpha->i == 0.f && (beta->r == 1.f &&
- beta->i == 0.f)) {
- return 0;
- }
-
-/* Set up the start points in X and Y. */
-
- if (*incx > 0) {
- kx = 1;
- } else {
- kx = 1 - (*n - 1) * *incx;
- }
- if (*incy > 0) {
- ky = 1;
- } else {
- ky = 1 - (*n - 1) * *incy;
- }
-
-/* Start the operations. In this version the elements of A are */
-/* accessed sequentially with one pass through the triangular part */
-/* of A. */
-
-/* First form y := beta*y. */
-
- if (beta->r != 1.f || beta->i != 0.f) {
- if (*incy == 1) {
- if (beta->r == 0.f && beta->i == 0.f) {
- i__1 = *n;
- for (i__ = 1; i__ <= i__1; ++i__) {
- i__2 = i__;
- y[i__2].r = 0.f, y[i__2].i = 0.f;
-/* L10: */
- }
- } else {
- i__1 = *n;
- for (i__ = 1; i__ <= i__1; ++i__) {
- i__2 = i__;
- i__3 = i__;
- q__1.r = beta->r * y[i__3].r - beta->i * y[i__3].i,
- q__1.i = beta->r * y[i__3].i + beta->i * y[i__3]
- .r;
- y[i__2].r = q__1.r, y[i__2].i = q__1.i;
-/* L20: */
- }
- }
- } else {
- iy = ky;
- if (beta->r == 0.f && beta->i == 0.f) {
- i__1 = *n;
- for (i__ = 1; i__ <= i__1; ++i__) {
- i__2 = iy;
- y[i__2].r = 0.f, y[i__2].i = 0.f;
- iy += *incy;
-/* L30: */
- }
- } else {
- i__1 = *n;
- for (i__ = 1; i__ <= i__1; ++i__) {
- i__2 = iy;
- i__3 = iy;
- q__1.r = beta->r * y[i__3].r - beta->i * y[i__3].i,
- q__1.i = beta->r * y[i__3].i + beta->i * y[i__3]
- .r;
- y[i__2].r = q__1.r, y[i__2].i = q__1.i;
- iy += *incy;
-/* L40: */
- }
- }
- }
- }
- if (alpha->r == 0.f && alpha->i == 0.f) {
- return 0;
- }
- if (lsame_(uplo, "U", (ftnlen)1, (ftnlen)1)) {
-
-/* Form y when A is stored in upper triangle. */
-
- if (*incx == 1 && *incy == 1) {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- i__2 = j;
- q__1.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i, q__1.i =
- alpha->r * x[i__2].i + alpha->i * x[i__2].r;
- temp1.r = q__1.r, temp1.i = q__1.i;
- temp2.r = 0.f, temp2.i = 0.f;
- i__2 = j - 1;
- for (i__ = 1; i__ <= i__2; ++i__) {
- i__3 = i__;
- i__4 = i__;
- i__5 = i__ + j * a_dim1;
- q__2.r = temp1.r * a[i__5].r - temp1.i * a[i__5].i,
- q__2.i = temp1.r * a[i__5].i + temp1.i * a[i__5]
- .r;
- q__1.r = y[i__4].r + q__2.r, q__1.i = y[i__4].i + q__2.i;
- y[i__3].r = q__1.r, y[i__3].i = q__1.i;
- r_cnjg(&q__3, &a[i__ + j * a_dim1]);
- i__3 = i__;
- q__2.r = q__3.r * x[i__3].r - q__3.i * x[i__3].i, q__2.i =
- q__3.r * x[i__3].i + q__3.i * x[i__3].r;
- q__1.r = temp2.r + q__2.r, q__1.i = temp2.i + q__2.i;
- temp2.r = q__1.r, temp2.i = q__1.i;
-/* L50: */
- }
- i__2 = j;
- i__3 = j;
- i__4 = j + j * a_dim1;
- r__1 = a[i__4].r;
- q__3.r = r__1 * temp1.r, q__3.i = r__1 * temp1.i;
- q__2.r = y[i__3].r + q__3.r, q__2.i = y[i__3].i + q__3.i;
- q__4.r = alpha->r * temp2.r - alpha->i * temp2.i, q__4.i =
- alpha->r * temp2.i + alpha->i * temp2.r;
- q__1.r = q__2.r + q__4.r, q__1.i = q__2.i + q__4.i;
- y[i__2].r = q__1.r, y[i__2].i = q__1.i;
-/* L60: */
- }
- } else {
- jx = kx;
- jy = ky;
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- i__2 = jx;
- q__1.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i, q__1.i =
- alpha->r * x[i__2].i + alpha->i * x[i__2].r;
- temp1.r = q__1.r, temp1.i = q__1.i;
- temp2.r = 0.f, temp2.i = 0.f;
- ix = kx;
- iy = ky;
- i__2 = j - 1;
- for (i__ = 1; i__ <= i__2; ++i__) {
- i__3 = iy;
- i__4 = iy;
- i__5 = i__ + j * a_dim1;
- q__2.r = temp1.r * a[i__5].r - temp1.i * a[i__5].i,
- q__2.i = temp1.r * a[i__5].i + temp1.i * a[i__5]
- .r;
- q__1.r = y[i__4].r + q__2.r, q__1.i = y[i__4].i + q__2.i;
- y[i__3].r = q__1.r, y[i__3].i = q__1.i;
- r_cnjg(&q__3, &a[i__ + j * a_dim1]);
- i__3 = ix;
- q__2.r = q__3.r * x[i__3].r - q__3.i * x[i__3].i, q__2.i =
- q__3.r * x[i__3].i + q__3.i * x[i__3].r;
- q__1.r = temp2.r + q__2.r, q__1.i = temp2.i + q__2.i;
- temp2.r = q__1.r, temp2.i = q__1.i;
- ix += *incx;
- iy += *incy;
-/* L70: */
- }
- i__2 = jy;
- i__3 = jy;
- i__4 = j + j * a_dim1;
- r__1 = a[i__4].r;
- q__3.r = r__1 * temp1.r, q__3.i = r__1 * temp1.i;
- q__2.r = y[i__3].r + q__3.r, q__2.i = y[i__3].i + q__3.i;
- q__4.r = alpha->r * temp2.r - alpha->i * temp2.i, q__4.i =
- alpha->r * temp2.i + alpha->i * temp2.r;
- q__1.r = q__2.r + q__4.r, q__1.i = q__2.i + q__4.i;
- y[i__2].r = q__1.r, y[i__2].i = q__1.i;
- jx += *incx;
- jy += *incy;
-/* L80: */
- }
- }
- } else {
-
-/* Form y when A is stored in lower triangle. */
-
- if (*incx == 1 && *incy == 1) {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- i__2 = j;
- q__1.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i, q__1.i =
- alpha->r * x[i__2].i + alpha->i * x[i__2].r;
- temp1.r = q__1.r, temp1.i = q__1.i;
- temp2.r = 0.f, temp2.i = 0.f;
- i__2 = j;
- i__3 = j;
- i__4 = j + j * a_dim1;
- r__1 = a[i__4].r;
- q__2.r = r__1 * temp1.r, q__2.i = r__1 * temp1.i;
- q__1.r = y[i__3].r + q__2.r, q__1.i = y[i__3].i + q__2.i;
- y[i__2].r = q__1.r, y[i__2].i = q__1.i;
- i__2 = *n;
- for (i__ = j + 1; i__ <= i__2; ++i__) {
- i__3 = i__;
- i__4 = i__;
- i__5 = i__ + j * a_dim1;
- q__2.r = temp1.r * a[i__5].r - temp1.i * a[i__5].i,
- q__2.i = temp1.r * a[i__5].i + temp1.i * a[i__5]
- .r;
- q__1.r = y[i__4].r + q__2.r, q__1.i = y[i__4].i + q__2.i;
- y[i__3].r = q__1.r, y[i__3].i = q__1.i;
- r_cnjg(&q__3, &a[i__ + j * a_dim1]);
- i__3 = i__;
- q__2.r = q__3.r * x[i__3].r - q__3.i * x[i__3].i, q__2.i =
- q__3.r * x[i__3].i + q__3.i * x[i__3].r;
- q__1.r = temp2.r + q__2.r, q__1.i = temp2.i + q__2.i;
- temp2.r = q__1.r, temp2.i = q__1.i;
-/* L90: */
- }
- i__2 = j;
- i__3 = j;
- q__2.r = alpha->r * temp2.r - alpha->i * temp2.i, q__2.i =
- alpha->r * temp2.i + alpha->i * temp2.r;
- q__1.r = y[i__3].r + q__2.r, q__1.i = y[i__3].i + q__2.i;
- y[i__2].r = q__1.r, y[i__2].i = q__1.i;
-/* L100: */
- }
- } else {
- jx = kx;
- jy = ky;
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- i__2 = jx;
- q__1.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i, q__1.i =
- alpha->r * x[i__2].i + alpha->i * x[i__2].r;
- temp1.r = q__1.r, temp1.i = q__1.i;
- temp2.r = 0.f, temp2.i = 0.f;
- i__2 = jy;
- i__3 = jy;
- i__4 = j + j * a_dim1;
- r__1 = a[i__4].r;
- q__2.r = r__1 * temp1.r, q__2.i = r__1 * temp1.i;
- q__1.r = y[i__3].r + q__2.r, q__1.i = y[i__3].i + q__2.i;
- y[i__2].r = q__1.r, y[i__2].i = q__1.i;
- ix = jx;
- iy = jy;
- i__2 = *n;
- for (i__ = j + 1; i__ <= i__2; ++i__) {
- ix += *incx;
- iy += *incy;
- i__3 = iy;
- i__4 = iy;
- i__5 = i__ + j * a_dim1;
- q__2.r = temp1.r * a[i__5].r - temp1.i * a[i__5].i,
- q__2.i = temp1.r * a[i__5].i + temp1.i * a[i__5]
- .r;
- q__1.r = y[i__4].r + q__2.r, q__1.i = y[i__4].i + q__2.i;
- y[i__3].r = q__1.r, y[i__3].i = q__1.i;
- r_cnjg(&q__3, &a[i__ + j * a_dim1]);
- i__3 = ix;
- q__2.r = q__3.r * x[i__3].r - q__3.i * x[i__3].i, q__2.i =
- q__3.r * x[i__3].i + q__3.i * x[i__3].r;
- q__1.r = temp2.r + q__2.r, q__1.i = temp2.i + q__2.i;
- temp2.r = q__1.r, temp2.i = q__1.i;
-/* L110: */
- }
- i__2 = jy;
- i__3 = jy;
- q__2.r = alpha->r * temp2.r - alpha->i * temp2.i, q__2.i =
- alpha->r * temp2.i + alpha->i * temp2.r;
- q__1.r = y[i__3].r + q__2.r, q__1.i = y[i__3].i + q__2.i;
- y[i__2].r = q__1.r, y[i__2].i = q__1.i;
- jx += *incx;
- jy += *incy;
-/* L120: */
- }
- }
- }
-
- return 0;
-
-/* End of CHEMV . */
-
-} /* chemv_ */
-
-/* Subroutine */ int cher_(char *uplo, integer *n, real *alpha, complex *x,
- integer *incx, complex *a, integer *lda, ftnlen uplo_len)
-{
- /* System generated locals */
- integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5;
- real r__1;
- complex q__1, q__2;
-
- /* Builtin functions */
- void r_cnjg(complex *, complex *);
-
- /* Local variables */
- static integer i__, j, ix, jx, kx, info;
- static complex temp;
- extern logical lsame_(char *, char *, ftnlen, ftnlen);
- extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen);
-
-/* .. Scalar Arguments .. */
-/* .. Array Arguments .. */
-/* .. */
-
-/* Purpose */
-/* ======= */
-
-/* CHER performs the hermitian rank 1 operation */
-
-/* A := alpha*x*conjg( x' ) + A, */
-
-/* where alpha is a real scalar, x is an n element vector and A is an */
-/* n by n hermitian matrix. */
-
-/* Parameters */
-/* ========== */
-
-/* UPLO - CHARACTER*1. */
-/* On entry, UPLO specifies whether the upper or lower */
-/* triangular part of the array A is to be referenced as */
-/* follows: */
-
-/* UPLO = 'U' or 'u' Only the upper triangular part of A */
-/* is to be referenced. */
-
-/* UPLO = 'L' or 'l' Only the lower triangular part of A */
-/* is to be referenced. */
-
-/* Unchanged on exit. */
-
-/* N - INTEGER. */
-/* On entry, N specifies the order of the matrix A. */
-/* N must be at least zero. */
-/* Unchanged on exit. */
-
-/* ALPHA - REAL . */
-/* On entry, ALPHA specifies the scalar alpha. */
-/* Unchanged on exit. */
-
-/* X - COMPLEX array of dimension at least */
-/* ( 1 + ( n - 1 )*abs( INCX ) ). */
-/* Before entry, the incremented array X must contain the n */
-/* element vector x. */
-/* Unchanged on exit. */
-
-/* INCX - INTEGER. */
-/* On entry, INCX specifies the increment for the elements of */
-/* X. INCX must not be zero. */
-/* Unchanged on exit. */
-
-/* A - COMPLEX array of DIMENSION ( LDA, n ). */
-/* Before entry with UPLO = 'U' or 'u', the leading n by n */
-/* upper triangular part of the array A must contain the upper */
-/* triangular part of the hermitian matrix and the strictly */
-/* lower triangular part of A is not referenced. On exit, the */
-/* upper triangular part of the array A is overwritten by the */
-/* upper triangular part of the updated matrix. */
-/* Before entry with UPLO = 'L' or 'l', the leading n by n */
-/* lower triangular part of the array A must contain the lower */
-/* triangular part of the hermitian matrix and the strictly */
-/* upper triangular part of A is not referenced. On exit, the */
-/* lower triangular part of the array A is overwritten by the */
-/* lower triangular part of the updated matrix. */
-/* Note that the imaginary parts of the diagonal elements need */
-/* not be set, they are assumed to be zero, and on exit they */
-/* are set to zero. */
-
-/* LDA - INTEGER. */
-/* On entry, LDA specifies the first dimension of A as declared */
-/* in the calling (sub) program. LDA must be at least */
-/* max( 1, n ). */
-/* Unchanged on exit. */
-
-
-/* Level 2 Blas routine. */
-
-/* -- Written on 22-October-1986. */
-/* Jack Dongarra, Argonne National Lab. */
-/* Jeremy Du Croz, Nag Central Office. */
-/* Sven Hammarling, Nag Central Office. */
-/* Richard Hanson, Sandia National Labs. */
-
-
-/* .. Parameters .. */
-/* .. Local Scalars .. */
-/* .. External Functions .. */
-/* .. External Subroutines .. */
-/* .. Intrinsic Functions .. */
-/* .. */
-/* .. Executable Statements .. */
-
-/* Test the input parameters. */
-
- /* Parameter adjustments */
- --x;
- a_dim1 = *lda;
- a_offset = 1 + a_dim1 * 1;
- a -= a_offset;
-
- /* Function Body */
- info = 0;
- if (! lsame_(uplo, "U", (ftnlen)1, (ftnlen)1) && ! lsame_(uplo, "L", (
- ftnlen)1, (ftnlen)1)) {
- info = 1;
- } else if (*n < 0) {
- info = 2;
- } else if (*incx == 0) {
- info = 5;
- } else if (*lda < max(1,*n)) {
- info = 7;
- }
- if (info != 0) {
- xerbla_("CHER ", &info, (ftnlen)6);
- return 0;
- }
-
-/* Quick return if possible. */
-
- if (*n == 0 || *alpha == 0.f) {
- return 0;
- }
-
-/* Set the start point in X if the increment is not unity. */
-
- if (*incx <= 0) {
- kx = 1 - (*n - 1) * *incx;
- } else if (*incx != 1) {
- kx = 1;
- }
-
-/* Start the operations. In this version the elements of A are */
-/* accessed sequentially with one pass through the triangular part */
-/* of A. */
-
- if (lsame_(uplo, "U", (ftnlen)1, (ftnlen)1)) {
-
-/* Form A when A is stored in upper triangle. */
-
- if (*incx == 1) {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- i__2 = j;
- if (x[i__2].r != 0.f || x[i__2].i != 0.f) {
- r_cnjg(&q__2, &x[j]);
- q__1.r = *alpha * q__2.r, q__1.i = *alpha * q__2.i;
- temp.r = q__1.r, temp.i = q__1.i;
- i__2 = j - 1;
- for (i__ = 1; i__ <= i__2; ++i__) {
- i__3 = i__ + j * a_dim1;
- i__4 = i__ + j * a_dim1;
- i__5 = i__;
- q__2.r = x[i__5].r * temp.r - x[i__5].i * temp.i,
- q__2.i = x[i__5].r * temp.i + x[i__5].i *
- temp.r;
- q__1.r = a[i__4].r + q__2.r, q__1.i = a[i__4].i +
- q__2.i;
- a[i__3].r = q__1.r, a[i__3].i = q__1.i;
-/* L10: */
- }
- i__2 = j + j * a_dim1;
- i__3 = j + j * a_dim1;
- i__4 = j;
- q__1.r = x[i__4].r * temp.r - x[i__4].i * temp.i, q__1.i =
- x[i__4].r * temp.i + x[i__4].i * temp.r;
- r__1 = a[i__3].r + q__1.r;
- a[i__2].r = r__1, a[i__2].i = 0.f;
- } else {
- i__2 = j + j * a_dim1;
- i__3 = j + j * a_dim1;
- r__1 = a[i__3].r;
- a[i__2].r = r__1, a[i__2].i = 0.f;
- }
-/* L20: */
- }
- } else {
- jx = kx;
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- i__2 = jx;
- if (x[i__2].r != 0.f || x[i__2].i != 0.f) {
- r_cnjg(&q__2, &x[jx]);
- q__1.r = *alpha * q__2.r, q__1.i = *alpha * q__2.i;
- temp.r = q__1.r, temp.i = q__1.i;
- ix = kx;
- i__2 = j - 1;
- for (i__ = 1; i__ <= i__2; ++i__) {
- i__3 = i__ + j * a_dim1;
- i__4 = i__ + j * a_dim1;
- i__5 = ix;
- q__2.r = x[i__5].r * temp.r - x[i__5].i * temp.i,
- q__2.i = x[i__5].r * temp.i + x[i__5].i *
- temp.r;
- q__1.r = a[i__4].r + q__2.r, q__1.i = a[i__4].i +
- q__2.i;
- a[i__3].r = q__1.r, a[i__3].i = q__1.i;
- ix += *incx;
-/* L30: */
- }
- i__2 = j + j * a_dim1;
- i__3 = j + j * a_dim1;
- i__4 = jx;
- q__1.r = x[i__4].r * temp.r - x[i__4].i * temp.i, q__1.i =
- x[i__4].r * temp.i + x[i__4].i * temp.r;
- r__1 = a[i__3].r + q__1.r;
- a[i__2].r = r__1, a[i__2].i = 0.f;
- } else {
- i__2 = j + j * a_dim1;
- i__3 = j + j * a_dim1;
- r__1 = a[i__3].r;
- a[i__2].r = r__1, a[i__2].i = 0.f;
- }
- jx += *incx;
-/* L40: */
- }
- }
- } else {
-
-/* Form A when A is stored in lower triangle. */
-
- if (*incx == 1) {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- i__2 = j;
- if (x[i__2].r != 0.f || x[i__2].i != 0.f) {
- r_cnjg(&q__2, &x[j]);
- q__1.r = *alpha * q__2.r, q__1.i = *alpha * q__2.i;
- temp.r = q__1.r, temp.i = q__1.i;
- i__2 = j + j * a_dim1;
- i__3 = j + j * a_dim1;
- i__4 = j;
- q__1.r = temp.r * x[i__4].r - temp.i * x[i__4].i, q__1.i =
- temp.r * x[i__4].i + temp.i * x[i__4].r;
- r__1 = a[i__3].r + q__1.r;
- a[i__2].r = r__1, a[i__2].i = 0.f;
- i__2 = *n;
- for (i__ = j + 1; i__ <= i__2; ++i__) {
- i__3 = i__ + j * a_dim1;
- i__4 = i__ + j * a_dim1;
- i__5 = i__;
- q__2.r = x[i__5].r * temp.r - x[i__5].i * temp.i,
- q__2.i = x[i__5].r * temp.i + x[i__5].i *
- temp.r;
- q__1.r = a[i__4].r + q__2.r, q__1.i = a[i__4].i +
- q__2.i;
- a[i__3].r = q__1.r, a[i__3].i = q__1.i;
-/* L50: */
- }
- } else {
- i__2 = j + j * a_dim1;
- i__3 = j + j * a_dim1;
- r__1 = a[i__3].r;
- a[i__2].r = r__1, a[i__2].i = 0.f;
- }
-/* L60: */
- }
- } else {
- jx = kx;
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- i__2 = jx;
- if (x[i__2].r != 0.f || x[i__2].i != 0.f) {
- r_cnjg(&q__2, &x[jx]);
- q__1.r = *alpha * q__2.r, q__1.i = *alpha * q__2.i;
- temp.r = q__1.r, temp.i = q__1.i;
- i__2 = j + j * a_dim1;
- i__3 = j + j * a_dim1;
- i__4 = jx;
- q__1.r = temp.r * x[i__4].r - temp.i * x[i__4].i, q__1.i =
- temp.r * x[i__4].i + temp.i * x[i__4].r;
- r__1 = a[i__3].r + q__1.r;
- a[i__2].r = r__1, a[i__2].i = 0.f;
- ix = jx;
- i__2 = *n;
- for (i__ = j + 1; i__ <= i__2; ++i__) {
- ix += *incx;
- i__3 = i__ + j * a_dim1;
- i__4 = i__ + j * a_dim1;
- i__5 = ix;
- q__2.r = x[i__5].r * temp.r - x[i__5].i * temp.i,
- q__2.i = x[i__5].r * temp.i + x[i__5].i *
- temp.r;
- q__1.r = a[i__4].r + q__2.r, q__1.i = a[i__4].i +
- q__2.i;
- a[i__3].r = q__1.r, a[i__3].i = q__1.i;
-/* L70: */
- }
- } else {
- i__2 = j + j * a_dim1;
- i__3 = j + j * a_dim1;
- r__1 = a[i__3].r;
- a[i__2].r = r__1, a[i__2].i = 0.f;
- }
- jx += *incx;
-/* L80: */
- }
- }
- }
-
- return 0;
-
-/* End of CHER . */
-
-} /* cher_ */
-
-/* Subroutine */ int cher2_(char *uplo, integer *n, complex *alpha, complex *
- x, integer *incx, complex *y, integer *incy, complex *a, integer *lda,
- ftnlen uplo_len)
-{
- /* System generated locals */
- integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5, i__6;
- real r__1;
- complex q__1, q__2, q__3, q__4;
-
- /* Builtin functions */
- void r_cnjg(complex *, complex *);
-
- /* Local variables */
- static integer i__, j, ix, iy, jx, jy, kx, ky, info;
- static complex temp1, temp2;
- extern logical lsame_(char *, char *, ftnlen, ftnlen);
- extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen);
-
-/* .. Scalar Arguments .. */
-/* .. Array Arguments .. */
-/* .. */
-
-/* Purpose */
-/* ======= */
-
-/* CHER2 performs the hermitian rank 2 operation */
-
-/* A := alpha*x*conjg( y' ) + conjg( alpha )*y*conjg( x' ) + A, */
-
-/* where alpha is a scalar, x and y are n element vectors and A is an n */
-/* by n hermitian matrix. */
-
-/* Parameters */
-/* ========== */
-
-/* UPLO - CHARACTER*1. */
-/* On entry, UPLO specifies whether the upper or lower */
-/* triangular part of the array A is to be referenced as */
-/* follows: */
-
-/* UPLO = 'U' or 'u' Only the upper triangular part of A */
-/* is to be referenced. */
-
-/* UPLO = 'L' or 'l' Only the lower triangular part of A */
-/* is to be referenced. */
-
-/* Unchanged on exit. */
-
-/* N - INTEGER. */
-/* On entry, N specifies the order of the matrix A. */
-/* N must be at least zero. */
-/* Unchanged on exit. */
-
-/* ALPHA - COMPLEX . */
-/* On entry, ALPHA specifies the scalar alpha. */
-/* Unchanged on exit. */
-
-/* X - COMPLEX array of dimension at least */
-/* ( 1 + ( n - 1 )*abs( INCX ) ). */
-/* Before entry, the incremented array X must contain the n */
-/* element vector x. */
-/* Unchanged on exit. */
-
-/* INCX - INTEGER. */
-/* On entry, INCX specifies the increment for the elements of */
-/* X. INCX must not be zero. */
-/* Unchanged on exit. */
-
-/* Y - COMPLEX array of dimension at least */
-/* ( 1 + ( n - 1 )*abs( INCY ) ). */
-/* Before entry, the incremented array Y must contain the n */
-/* element vector y. */
-/* Unchanged on exit. */
-
-/* INCY - INTEGER. */
-/* On entry, INCY specifies the increment for the elements of */
-/* Y. INCY must not be zero. */
-/* Unchanged on exit. */
-
-/* A - COMPLEX array of DIMENSION ( LDA, n ). */
-/* Before entry with UPLO = 'U' or 'u', the leading n by n */
-/* upper triangular part of the array A must contain the upper */
-/* triangular part of the hermitian matrix and the strictly */
-/* lower triangular part of A is not referenced. On exit, the */
-/* upper triangular part of the array A is overwritten by the */
-/* upper triangular part of the updated matrix. */
-/* Before entry with UPLO = 'L' or 'l', the leading n by n */
-/* lower triangular part of the array A must contain the lower */
-/* triangular part of the hermitian matrix and the strictly */
-/* upper triangular part of A is not referenced. On exit, the */
-/* lower triangular part of the array A is overwritten by the */
-/* lower triangular part of the updated matrix. */
-/* Note that the imaginary parts of the diagonal elements need */
-/* not be set, they are assumed to be zero, and on exit they */
-/* are set to zero. */
-
-/* LDA - INTEGER. */
-/* On entry, LDA specifies the first dimension of A as declared */
-/* in the calling (sub) program. LDA must be at least */
-/* max( 1, n ). */
-/* Unchanged on exit. */
-
-
-/* Level 2 Blas routine. */
-
-/* -- Written on 22-October-1986. */
-/* Jack Dongarra, Argonne National Lab. */
-/* Jeremy Du Croz, Nag Central Office. */
-/* Sven Hammarling, Nag Central Office. */
-/* Richard Hanson, Sandia National Labs. */
-
-
-/* .. Parameters .. */
-/* .. Local Scalars .. */
-/* .. External Functions .. */
-/* .. External Subroutines .. */
-/* .. Intrinsic Functions .. */
-/* .. */
-/* .. Executable Statements .. */
-
-/* Test the input parameters. */
-
- /* Parameter adjustments */
- --x;
- --y;
- a_dim1 = *lda;
- a_offset = 1 + a_dim1 * 1;
- a -= a_offset;
-
- /* Function Body */
- info = 0;
- if (! lsame_(uplo, "U", (ftnlen)1, (ftnlen)1) && ! lsame_(uplo, "L", (
- ftnlen)1, (ftnlen)1)) {
- info = 1;
- } else if (*n < 0) {
- info = 2;
- } else if (*incx == 0) {
- info = 5;
- } else if (*incy == 0) {
- info = 7;
- } else if (*lda < max(1,*n)) {
- info = 9;
- }
- if (info != 0) {
- xerbla_("CHER2 ", &info, (ftnlen)6);
- return 0;
- }
-
-/* Quick return if possible. */
-
- if (*n == 0 || alpha->r == 0.f && alpha->i == 0.f) {
- return 0;
- }
-
-/* Set up the start points in X and Y if the increments are not both */
-/* unity. */
-
- if (*incx != 1 || *incy != 1) {
- if (*incx > 0) {
- kx = 1;
- } else {
- kx = 1 - (*n - 1) * *incx;
- }
- if (*incy > 0) {
- ky = 1;
- } else {
- ky = 1 - (*n - 1) * *incy;
- }
- jx = kx;
- jy = ky;
- }
-
-/* Start the operations. In this version the elements of A are */
-/* accessed sequentially with one pass through the triangular part */
-/* of A. */
-
- if (lsame_(uplo, "U", (ftnlen)1, (ftnlen)1)) {
-
-/* Form A when A is stored in the upper triangle. */
-
- if (*incx == 1 && *incy == 1) {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- i__2 = j;
- i__3 = j;
- if (x[i__2].r != 0.f || x[i__2].i != 0.f || (y[i__3].r != 0.f
- || y[i__3].i != 0.f)) {
- r_cnjg(&q__2, &y[j]);
- q__1.r = alpha->r * q__2.r - alpha->i * q__2.i, q__1.i =
- alpha->r * q__2.i + alpha->i * q__2.r;
- temp1.r = q__1.r, temp1.i = q__1.i;
- i__2 = j;
- q__2.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i,
- q__2.i = alpha->r * x[i__2].i + alpha->i * x[i__2]
- .r;
- r_cnjg(&q__1, &q__2);
- temp2.r = q__1.r, temp2.i = q__1.i;
- i__2 = j - 1;
- for (i__ = 1; i__ <= i__2; ++i__) {
- i__3 = i__ + j * a_dim1;
- i__4 = i__ + j * a_dim1;
- i__5 = i__;
- q__3.r = x[i__5].r * temp1.r - x[i__5].i * temp1.i,
- q__3.i = x[i__5].r * temp1.i + x[i__5].i *
- temp1.r;
- q__2.r = a[i__4].r + q__3.r, q__2.i = a[i__4].i +
- q__3.i;
- i__6 = i__;
- q__4.r = y[i__6].r * temp2.r - y[i__6].i * temp2.i,
- q__4.i = y[i__6].r * temp2.i + y[i__6].i *
- temp2.r;
- q__1.r = q__2.r + q__4.r, q__1.i = q__2.i + q__4.i;
- a[i__3].r = q__1.r, a[i__3].i = q__1.i;
-/* L10: */
- }
- i__2 = j + j * a_dim1;
- i__3 = j + j * a_dim1;
- i__4 = j;
- q__2.r = x[i__4].r * temp1.r - x[i__4].i * temp1.i,
- q__2.i = x[i__4].r * temp1.i + x[i__4].i *
- temp1.r;
- i__5 = j;
- q__3.r = y[i__5].r * temp2.r - y[i__5].i * temp2.i,
- q__3.i = y[i__5].r * temp2.i + y[i__5].i *
- temp2.r;
- q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
- r__1 = a[i__3].r + q__1.r;
- a[i__2].r = r__1, a[i__2].i = 0.f;
- } else {
- i__2 = j + j * a_dim1;
- i__3 = j + j * a_dim1;
- r__1 = a[i__3].r;
- a[i__2].r = r__1, a[i__2].i = 0.f;
- }
-/* L20: */
- }
- } else {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- i__2 = jx;
- i__3 = jy;
- if (x[i__2].r != 0.f || x[i__2].i != 0.f || (y[i__3].r != 0.f
- || y[i__3].i != 0.f)) {
- r_cnjg(&q__2, &y[jy]);
- q__1.r = alpha->r * q__2.r - alpha->i * q__2.i, q__1.i =
- alpha->r * q__2.i + alpha->i * q__2.r;
- temp1.r = q__1.r, temp1.i = q__1.i;
- i__2 = jx;
- q__2.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i,
- q__2.i = alpha->r * x[i__2].i + alpha->i * x[i__2]
- .r;
- r_cnjg(&q__1, &q__2);
- temp2.r = q__1.r, temp2.i = q__1.i;
- ix = kx;
- iy = ky;
- i__2 = j - 1;
- for (i__ = 1; i__ <= i__2; ++i__) {
- i__3 = i__ + j * a_dim1;
- i__4 = i__ + j * a_dim1;
- i__5 = ix;
- q__3.r = x[i__5].r * temp1.r - x[i__5].i * temp1.i,
- q__3.i = x[i__5].r * temp1.i + x[i__5].i *
- temp1.r;
- q__2.r = a[i__4].r + q__3.r, q__2.i = a[i__4].i +
- q__3.i;
- i__6 = iy;
- q__4.r = y[i__6].r * temp2.r - y[i__6].i * temp2.i,
- q__4.i = y[i__6].r * temp2.i + y[i__6].i *
- temp2.r;
- q__1.r = q__2.r + q__4.r, q__1.i = q__2.i + q__4.i;
- a[i__3].r = q__1.r, a[i__3].i = q__1.i;
- ix += *incx;
- iy += *incy;
-/* L30: */
- }
- i__2 = j + j * a_dim1;
- i__3 = j + j * a_dim1;
- i__4 = jx;
- q__2.r = x[i__4].r * temp1.r - x[i__4].i * temp1.i,
- q__2.i = x[i__4].r * temp1.i + x[i__4].i *
- temp1.r;
- i__5 = jy;
- q__3.r = y[i__5].r * temp2.r - y[i__5].i * temp2.i,
- q__3.i = y[i__5].r * temp2.i + y[i__5].i *
- temp2.r;
- q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
- r__1 = a[i__3].r + q__1.r;
- a[i__2].r = r__1, a[i__2].i = 0.f;
- } else {
- i__2 = j + j * a_dim1;
- i__3 = j + j * a_dim1;
- r__1 = a[i__3].r;
- a[i__2].r = r__1, a[i__2].i = 0.f;
- }
- jx += *incx;
- jy += *incy;
-/* L40: */
- }
- }
- } else {
-
-/* Form A when A is stored in the lower triangle. */
-
- if (*incx == 1 && *incy == 1) {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- i__2 = j;
- i__3 = j;
- if (x[i__2].r != 0.f || x[i__2].i != 0.f || (y[i__3].r != 0.f
- || y[i__3].i != 0.f)) {
- r_cnjg(&q__2, &y[j]);
- q__1.r = alpha->r * q__2.r - alpha->i * q__2.i, q__1.i =
- alpha->r * q__2.i + alpha->i * q__2.r;
- temp1.r = q__1.r, temp1.i = q__1.i;
- i__2 = j;
- q__2.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i,
- q__2.i = alpha->r * x[i__2].i + alpha->i * x[i__2]
- .r;
- r_cnjg(&q__1, &q__2);
- temp2.r = q__1.r, temp2.i = q__1.i;
- i__2 = j + j * a_dim1;
- i__3 = j + j * a_dim1;
- i__4 = j;
- q__2.r = x[i__4].r * temp1.r - x[i__4].i * temp1.i,
- q__2.i = x[i__4].r * temp1.i + x[i__4].i *
- temp1.r;
- i__5 = j;
- q__3.r = y[i__5].r * temp2.r - y[i__5].i * temp2.i,
- q__3.i = y[i__5].r * temp2.i + y[i__5].i *
- temp2.r;
- q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
- r__1 = a[i__3].r + q__1.r;
- a[i__2].r = r__1, a[i__2].i = 0.f;
- i__2 = *n;
- for (i__ = j + 1; i__ <= i__2; ++i__) {
- i__3 = i__ + j * a_dim1;
- i__4 = i__ + j * a_dim1;
- i__5 = i__;
- q__3.r = x[i__5].r * temp1.r - x[i__5].i * temp1.i,
- q__3.i = x[i__5].r * temp1.i + x[i__5].i *
- temp1.r;
- q__2.r = a[i__4].r + q__3.r, q__2.i = a[i__4].i +
- q__3.i;
- i__6 = i__;
- q__4.r = y[i__6].r * temp2.r - y[i__6].i * temp2.i,
- q__4.i = y[i__6].r * temp2.i + y[i__6].i *
- temp2.r;
- q__1.r = q__2.r + q__4.r, q__1.i = q__2.i + q__4.i;
- a[i__3].r = q__1.r, a[i__3].i = q__1.i;
-/* L50: */
- }
- } else {
- i__2 = j + j * a_dim1;
- i__3 = j + j * a_dim1;
- r__1 = a[i__3].r;
- a[i__2].r = r__1, a[i__2].i = 0.f;
- }
-/* L60: */
- }
- } else {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- i__2 = jx;
- i__3 = jy;
- if (x[i__2].r != 0.f || x[i__2].i != 0.f || (y[i__3].r != 0.f
- || y[i__3].i != 0.f)) {
- r_cnjg(&q__2, &y[jy]);
- q__1.r = alpha->r * q__2.r - alpha->i * q__2.i, q__1.i =
- alpha->r * q__2.i + alpha->i * q__2.r;
- temp1.r = q__1.r, temp1.i = q__1.i;
- i__2 = jx;
- q__2.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i,
- q__2.i = alpha->r * x[i__2].i + alpha->i * x[i__2]
- .r;
- r_cnjg(&q__1, &q__2);
- temp2.r = q__1.r, temp2.i = q__1.i;
- i__2 = j + j * a_dim1;
- i__3 = j + j * a_dim1;
- i__4 = jx;
- q__2.r = x[i__4].r * temp1.r - x[i__4].i * temp1.i,
- q__2.i = x[i__4].r * temp1.i + x[i__4].i *
- temp1.r;
- i__5 = jy;
- q__3.r = y[i__5].r * temp2.r - y[i__5].i * temp2.i,
- q__3.i = y[i__5].r * temp2.i + y[i__5].i *
- temp2.r;
- q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
- r__1 = a[i__3].r + q__1.r;
- a[i__2].r = r__1, a[i__2].i = 0.f;
- ix = jx;
- iy = jy;
- i__2 = *n;
- for (i__ = j + 1; i__ <= i__2; ++i__) {
- ix += *incx;
- iy += *incy;
- i__3 = i__ + j * a_dim1;
- i__4 = i__ + j * a_dim1;
- i__5 = ix;
- q__3.r = x[i__5].r * temp1.r - x[i__5].i * temp1.i,
- q__3.i = x[i__5].r * temp1.i + x[i__5].i *
- temp1.r;
- q__2.r = a[i__4].r + q__3.r, q__2.i = a[i__4].i +
- q__3.i;
- i__6 = iy;
- q__4.r = y[i__6].r * temp2.r - y[i__6].i * temp2.i,
- q__4.i = y[i__6].r * temp2.i + y[i__6].i *
- temp2.r;
- q__1.r = q__2.r + q__4.r, q__1.i = q__2.i + q__4.i;
- a[i__3].r = q__1.r, a[i__3].i = q__1.i;
-/* L70: */
- }
- } else {
- i__2 = j + j * a_dim1;
- i__3 = j + j * a_dim1;
- r__1 = a[i__3].r;
- a[i__2].r = r__1, a[i__2].i = 0.f;
- }
- jx += *incx;
- jy += *incy;
-/* L80: */
- }
- }
- }
-
- return 0;
-
-/* End of CHER2 . */
-
-} /* cher2_ */
-
-/* Subroutine */ int cher2k_(char *uplo, char *trans, integer *n, integer *k,
- complex *alpha, complex *a, integer *lda, complex *b, integer *ldb,
- real *beta, complex *c__, integer *ldc, ftnlen uplo_len, ftnlen
- trans_len)
-{
- /* System generated locals */
- integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2,
- i__3, i__4, i__5, i__6, i__7;
- real r__1;
- complex q__1, q__2, q__3, q__4, q__5, q__6;
-
- /* Builtin functions */
- void r_cnjg(complex *, complex *);
-
- /* Local variables */
- static integer i__, j, l, info;
- static complex temp1, temp2;
- extern logical lsame_(char *, char *, ftnlen, ftnlen);
- static integer nrowa;
- static logical upper;
- extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen);
-
-/* .. Scalar Arguments .. */
-/* .. Array Arguments .. */
-/* .. */
-
-/* Purpose */
-/* ======= */
-
-/* CHER2K performs one of the hermitian rank 2k operations */
-
-/* C := alpha*A*conjg( B' ) + conjg( alpha )*B*conjg( A' ) + beta*C, */
-
-/* or */
-
-/* C := alpha*conjg( A' )*B + conjg( alpha )*conjg( B' )*A + beta*C, */
-
-/* where alpha and beta are scalars with beta real, C is an n by n */
-/* hermitian matrix and A and B are n by k matrices in the first case */
-/* and k by n matrices in the second case. */
-
-/* Parameters */
-/* ========== */
-
-/* UPLO - CHARACTER*1. */
-/* On entry, UPLO specifies whether the upper or lower */
-/* triangular part of the array C is to be referenced as */
-/* follows: */
-
-/* UPLO = 'U' or 'u' Only the upper triangular part of C */
-/* is to be referenced. */
-
-/* UPLO = 'L' or 'l' Only the lower triangular part of C */
-/* is to be referenced. */
-
-/* Unchanged on exit. */
-
-/* TRANS - CHARACTER*1. */
-/* On entry, TRANS specifies the operation to be performed as */
-/* follows: */
-
-/* TRANS = 'N' or 'n' C := alpha*A*conjg( B' ) + */
-/* conjg( alpha )*B*conjg( A' ) + */
-/* beta*C. */
-
-/* TRANS = 'C' or 'c' C := alpha*conjg( A' )*B + */
-/* conjg( alpha )*conjg( B' )*A + */
-/* beta*C. */
-
-/* Unchanged on exit. */
-
-/* N - INTEGER. */
-/* On entry, N specifies the order of the matrix C. N must be */
-/* at least zero. */
-/* Unchanged on exit. */
-
-/* K - INTEGER. */
-/* On entry with TRANS = 'N' or 'n', K specifies the number */
-/* of columns of the matrices A and B, and on entry with */
-/* TRANS = 'C' or 'c', K specifies the number of rows of the */
-/* matrices A and B. K must be at least zero. */
-/* Unchanged on exit. */
-
-/* ALPHA - COMPLEX . */
-/* On entry, ALPHA specifies the scalar alpha. */
-/* Unchanged on exit. */
-
-/* A - COMPLEX array of DIMENSION ( LDA, ka ), where ka is */
-/* k when TRANS = 'N' or 'n', and is n otherwise. */
-/* Before entry with TRANS = 'N' or 'n', the leading n by k */
-/* part of the array A must contain the matrix A, otherwise */
-/* the leading k by n part of the array A must contain the */
-/* matrix A. */
-/* Unchanged on exit. */
-
-/* LDA - INTEGER. */
-/* On entry, LDA specifies the first dimension of A as declared */
-/* in the calling (sub) program. When TRANS = 'N' or 'n' */
-/* then LDA must be at least max( 1, n ), otherwise LDA must */
-/* be at least max( 1, k ). */
-/* Unchanged on exit. */
-
-/* B - COMPLEX array of DIMENSION ( LDB, kb ), where kb is */
-/* k when TRANS = 'N' or 'n', and is n otherwise. */
-/* Before entry with TRANS = 'N' or 'n', the leading n by k */
-/* part of the array B must contain the matrix B, otherwise */
-/* the leading k by n part of the array B must contain the */
-/* matrix B. */
-/* Unchanged on exit. */
-
-/* LDB - INTEGER. */
-/* On entry, LDB specifies the first dimension of B as declared */
-/* in the calling (sub) program. When TRANS = 'N' or 'n' */
-/* then LDB must be at least max( 1, n ), otherwise LDB must */
-/* be at least max( 1, k ). */
-/* Unchanged on exit. */
-
-/* BETA - REAL . */
-/* On entry, BETA specifies the scalar beta. */
-/* Unchanged on exit. */
-
-/* C - COMPLEX array of DIMENSION ( LDC, n ). */
-/* Before entry with UPLO = 'U' or 'u', the leading n by n */
-/* upper triangular part of the array C must contain the upper */
-/* triangular part of the hermitian matrix and the strictly */
-/* lower triangular part of C is not referenced. On exit, the */
-/* upper triangular part of the array C is overwritten by the */
-/* upper triangular part of the updated matrix. */
-/* Before entry with UPLO = 'L' or 'l', the leading n by n */
-/* lower triangular part of the array C must contain the lower */
-/* triangular part of the hermitian matrix and the strictly */
-/* upper triangular part of C is not referenced. On exit, the */
-/* lower triangular part of the array C is overwritten by the */
-/* lower triangular part of the updated matrix. */
-/* Note that the imaginary parts of the diagonal elements need */
-/* not be set, they are assumed to be zero, and on exit they */
-/* are set to zero. */
-
-/* LDC - INTEGER. */
-/* On entry, LDC specifies the first dimension of C as declared */
-/* in the calling (sub) program. LDC must be at least */
-/* max( 1, n ). */
-/* Unchanged on exit. */
-
-
-/* Level 3 Blas routine. */
-
-/* -- Written on 8-February-1989. */
-/* Jack Dongarra, Argonne National Laboratory. */
-/* Iain Duff, AERE Harwell. */
-/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */
-/* Sven Hammarling, Numerical Algorithms Group Ltd. */
-
-/* -- Modified 8-Nov-93 to set C(J,J) to REAL( C(J,J) ) when BETA = 1. */
-/* Ed Anderson, Cray Research Inc. */
-
-
-/* .. External Functions .. */
-/* .. External Subroutines .. */
-/* .. Intrinsic Functions .. */
-/* .. Local Scalars .. */
-/* .. Parameters .. */
-/* .. */
-/* .. Executable Statements .. */
-
-/* Test the input parameters. */
-
- /* Parameter adjustments */
- a_dim1 = *lda;
- a_offset = 1 + a_dim1 * 1;
- a -= a_offset;
- b_dim1 = *ldb;
- b_offset = 1 + b_dim1 * 1;
- b -= b_offset;
- c_dim1 = *ldc;
- c_offset = 1 + c_dim1 * 1;
- c__ -= c_offset;
-
- /* Function Body */
- if (lsame_(trans, "N", (ftnlen)1, (ftnlen)1)) {
- nrowa = *n;
- } else {
- nrowa = *k;
- }
- upper = lsame_(uplo, "U", (ftnlen)1, (ftnlen)1);
-
- info = 0;
- if (! upper && ! lsame_(uplo, "L", (ftnlen)1, (ftnlen)1)) {
- info = 1;
- } else if (! lsame_(trans, "N", (ftnlen)1, (ftnlen)1) && ! lsame_(trans,
- "C", (ftnlen)1, (ftnlen)1)) {
- info = 2;
- } else if (*n < 0) {
- info = 3;
- } else if (*k < 0) {
- info = 4;
- } else if (*lda < max(1,nrowa)) {
- info = 7;
- } else if (*ldb < max(1,nrowa)) {
- info = 9;
- } else if (*ldc < max(1,*n)) {
- info = 12;
- }
- if (info != 0) {
- xerbla_("CHER2K", &info, (ftnlen)6);
- return 0;
- }
-
-/* Quick return if possible. */
-
- if (*n == 0 || (alpha->r == 0.f && alpha->i == 0.f || *k == 0) && *beta ==
- 1.f) {
- return 0;
- }
-
-/* And when alpha.eq.zero. */
-
- if (alpha->r == 0.f && alpha->i == 0.f) {
- if (upper) {
- if (*beta == 0.f) {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- i__2 = j;
- for (i__ = 1; i__ <= i__2; ++i__) {
- i__3 = i__ + j * c_dim1;
- c__[i__3].r = 0.f, c__[i__3].i = 0.f;
-/* L10: */
- }
-/* L20: */
- }
- } else {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- i__2 = j - 1;
- for (i__ = 1; i__ <= i__2; ++i__) {
- i__3 = i__ + j * c_dim1;
- i__4 = i__ + j * c_dim1;
- q__1.r = *beta * c__[i__4].r, q__1.i = *beta * c__[
- i__4].i;
- c__[i__3].r = q__1.r, c__[i__3].i = q__1.i;
-/* L30: */
- }
- i__2 = j + j * c_dim1;
- i__3 = j + j * c_dim1;
- r__1 = *beta * c__[i__3].r;
- c__[i__2].r = r__1, c__[i__2].i = 0.f;
-/* L40: */
- }
- }
- } else {
- if (*beta == 0.f) {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- i__2 = *n;
- for (i__ = j; i__ <= i__2; ++i__) {
- i__3 = i__ + j * c_dim1;
- c__[i__3].r = 0.f, c__[i__3].i = 0.f;
-/* L50: */
- }
-/* L60: */
- }
- } else {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- i__2 = j + j * c_dim1;
- i__3 = j + j * c_dim1;
- r__1 = *beta * c__[i__3].r;
- c__[i__2].r = r__1, c__[i__2].i = 0.f;
- i__2 = *n;
- for (i__ = j + 1; i__ <= i__2; ++i__) {
- i__3 = i__ + j * c_dim1;
- i__4 = i__ + j * c_dim1;
- q__1.r = *beta * c__[i__4].r, q__1.i = *beta * c__[
- i__4].i;
- c__[i__3].r = q__1.r, c__[i__3].i = q__1.i;
-/* L70: */
- }
-/* L80: */
- }
- }
- }
- return 0;
- }
-
-/* Start the operations. */
-
- if (lsame_(trans, "N", (ftnlen)1, (ftnlen)1)) {
-
-/* Form C := alpha*A*conjg( B' ) + conjg( alpha )*B*conjg( A' ) + */
-/* C. */
-
- if (upper) {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- if (*beta == 0.f) {
- i__2 = j;
- for (i__ = 1; i__ <= i__2; ++i__) {
- i__3 = i__ + j * c_dim1;
- c__[i__3].r = 0.f, c__[i__3].i = 0.f;
-/* L90: */
- }
- } else if (*beta != 1.f) {
- i__2 = j - 1;
- for (i__ = 1; i__ <= i__2; ++i__) {
- i__3 = i__ + j * c_dim1;
- i__4 = i__ + j * c_dim1;
- q__1.r = *beta * c__[i__4].r, q__1.i = *beta * c__[
- i__4].i;
- c__[i__3].r = q__1.r, c__[i__3].i = q__1.i;
-/* L100: */
- }
- i__2 = j + j * c_dim1;
- i__3 = j + j * c_dim1;
- r__1 = *beta * c__[i__3].r;
- c__[i__2].r = r__1, c__[i__2].i = 0.f;
- } else {
- i__2 = j + j * c_dim1;
- i__3 = j + j * c_dim1;
- r__1 = c__[i__3].r;
- c__[i__2].r = r__1, c__[i__2].i = 0.f;
- }
- i__2 = *k;
- for (l = 1; l <= i__2; ++l) {
- i__3 = j + l * a_dim1;
- i__4 = j + l * b_dim1;
- if (a[i__3].r != 0.f || a[i__3].i != 0.f || (b[i__4].r !=
- 0.f || b[i__4].i != 0.f)) {
- r_cnjg(&q__2, &b[j + l * b_dim1]);
- q__1.r = alpha->r * q__2.r - alpha->i * q__2.i,
- q__1.i = alpha->r * q__2.i + alpha->i *
- q__2.r;
- temp1.r = q__1.r, temp1.i = q__1.i;
- i__3 = j + l * a_dim1;
- q__2.r = alpha->r * a[i__3].r - alpha->i * a[i__3].i,
- q__2.i = alpha->r * a[i__3].i + alpha->i * a[
- i__3].r;
- r_cnjg(&q__1, &q__2);
- temp2.r = q__1.r, temp2.i = q__1.i;
- i__3 = j - 1;
- for (i__ = 1; i__ <= i__3; ++i__) {
- i__4 = i__ + j * c_dim1;
- i__5 = i__ + j * c_dim1;
- i__6 = i__ + l * a_dim1;
- q__3.r = a[i__6].r * temp1.r - a[i__6].i *
- temp1.i, q__3.i = a[i__6].r * temp1.i + a[
- i__6].i * temp1.r;
- q__2.r = c__[i__5].r + q__3.r, q__2.i = c__[i__5]
- .i + q__3.i;
- i__7 = i__ + l * b_dim1;
- q__4.r = b[i__7].r * temp2.r - b[i__7].i *
- temp2.i, q__4.i = b[i__7].r * temp2.i + b[
- i__7].i * temp2.r;
- q__1.r = q__2.r + q__4.r, q__1.i = q__2.i +
- q__4.i;
- c__[i__4].r = q__1.r, c__[i__4].i = q__1.i;
-/* L110: */
- }
- i__3 = j + j * c_dim1;
- i__4 = j + j * c_dim1;
- i__5 = j + l * a_dim1;
- q__2.r = a[i__5].r * temp1.r - a[i__5].i * temp1.i,
- q__2.i = a[i__5].r * temp1.i + a[i__5].i *
- temp1.r;
- i__6 = j + l * b_dim1;
- q__3.r = b[i__6].r * temp2.r - b[i__6].i * temp2.i,
- q__3.i = b[i__6].r * temp2.i + b[i__6].i *
- temp2.r;
- q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
- r__1 = c__[i__4].r + q__1.r;
- c__[i__3].r = r__1, c__[i__3].i = 0.f;
- }
-/* L120: */
- }
-/* L130: */
- }
- } else {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- if (*beta == 0.f) {
- i__2 = *n;
- for (i__ = j; i__ <= i__2; ++i__) {
- i__3 = i__ + j * c_dim1;
- c__[i__3].r = 0.f, c__[i__3].i = 0.f;
-/* L140: */
- }
- } else if (*beta != 1.f) {
- i__2 = *n;
- for (i__ = j + 1; i__ <= i__2; ++i__) {
- i__3 = i__ + j * c_dim1;
- i__4 = i__ + j * c_dim1;
- q__1.r = *beta * c__[i__4].r, q__1.i = *beta * c__[
- i__4].i;
- c__[i__3].r = q__1.r, c__[i__3].i = q__1.i;
-/* L150: */
- }
- i__2 = j + j * c_dim1;
- i__3 = j + j * c_dim1;
- r__1 = *beta * c__[i__3].r;
- c__[i__2].r = r__1, c__[i__2].i = 0.f;
- } else {
- i__2 = j + j * c_dim1;
- i__3 = j + j * c_dim1;
- r__1 = c__[i__3].r;
- c__[i__2].r = r__1, c__[i__2].i = 0.f;
- }
- i__2 = *k;
- for (l = 1; l <= i__2; ++l) {
- i__3 = j + l * a_dim1;
- i__4 = j + l * b_dim1;
- if (a[i__3].r != 0.f || a[i__3].i != 0.f || (b[i__4].r !=
- 0.f || b[i__4].i != 0.f)) {
- r_cnjg(&q__2, &b[j + l * b_dim1]);
- q__1.r = alpha->r * q__2.r - alpha->i * q__2.i,
- q__1.i = alpha->r * q__2.i + alpha->i *
- q__2.r;
- temp1.r = q__1.r, temp1.i = q__1.i;
- i__3 = j + l * a_dim1;
- q__2.r = alpha->r * a[i__3].r - alpha->i * a[i__3].i,
- q__2.i = alpha->r * a[i__3].i + alpha->i * a[
- i__3].r;
- r_cnjg(&q__1, &q__2);
- temp2.r = q__1.r, temp2.i = q__1.i;
- i__3 = *n;
- for (i__ = j + 1; i__ <= i__3; ++i__) {
- i__4 = i__ + j * c_dim1;
- i__5 = i__ + j * c_dim1;
- i__6 = i__ + l * a_dim1;
- q__3.r = a[i__6].r * temp1.r - a[i__6].i *
- temp1.i, q__3.i = a[i__6].r * temp1.i + a[
- i__6].i * temp1.r;
- q__2.r = c__[i__5].r + q__3.r, q__2.i = c__[i__5]
- .i + q__3.i;
- i__7 = i__ + l * b_dim1;
- q__4.r = b[i__7].r * temp2.r - b[i__7].i *
- temp2.i, q__4.i = b[i__7].r * temp2.i + b[
- i__7].i * temp2.r;
- q__1.r = q__2.r + q__4.r, q__1.i = q__2.i +
- q__4.i;
- c__[i__4].r = q__1.r, c__[i__4].i = q__1.i;
-/* L160: */
- }
- i__3 = j + j * c_dim1;
- i__4 = j + j * c_dim1;
- i__5 = j + l * a_dim1;
- q__2.r = a[i__5].r * temp1.r - a[i__5].i * temp1.i,
- q__2.i = a[i__5].r * temp1.i + a[i__5].i *
- temp1.r;
- i__6 = j + l * b_dim1;
- q__3.r = b[i__6].r * temp2.r - b[i__6].i * temp2.i,
- q__3.i = b[i__6].r * temp2.i + b[i__6].i *
- temp2.r;
- q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
- r__1 = c__[i__4].r + q__1.r;
- c__[i__3].r = r__1, c__[i__3].i = 0.f;
- }
-/* L170: */
- }
-/* L180: */
- }
- }
- } else {
-
-/* Form C := alpha*conjg( A' )*B + conjg( alpha )*conjg( B' )*A + */
-/* C. */
-
- if (upper) {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- i__2 = j;
- for (i__ = 1; i__ <= i__2; ++i__) {
- temp1.r = 0.f, temp1.i = 0.f;
- temp2.r = 0.f, temp2.i = 0.f;
- i__3 = *k;
- for (l = 1; l <= i__3; ++l) {
- r_cnjg(&q__3, &a[l + i__ * a_dim1]);
- i__4 = l + j * b_dim1;
- q__2.r = q__3.r * b[i__4].r - q__3.i * b[i__4].i,
- q__2.i = q__3.r * b[i__4].i + q__3.i * b[i__4]
- .r;
- q__1.r = temp1.r + q__2.r, q__1.i = temp1.i + q__2.i;
- temp1.r = q__1.r, temp1.i = q__1.i;
- r_cnjg(&q__3, &b[l + i__ * b_dim1]);
- i__4 = l + j * a_dim1;
- q__2.r = q__3.r * a[i__4].r - q__3.i * a[i__4].i,
- q__2.i = q__3.r * a[i__4].i + q__3.i * a[i__4]
- .r;
- q__1.r = temp2.r + q__2.r, q__1.i = temp2.i + q__2.i;
- temp2.r = q__1.r, temp2.i = q__1.i;
-/* L190: */
- }
- if (i__ == j) {
- if (*beta == 0.f) {
- i__3 = j + j * c_dim1;
- q__2.r = alpha->r * temp1.r - alpha->i * temp1.i,
- q__2.i = alpha->r * temp1.i + alpha->i *
- temp1.r;
- r_cnjg(&q__4, alpha);
- q__3.r = q__4.r * temp2.r - q__4.i * temp2.i,
- q__3.i = q__4.r * temp2.i + q__4.i *
- temp2.r;
- q__1.r = q__2.r + q__3.r, q__1.i = q__2.i +
- q__3.i;
- r__1 = q__1.r;
- c__[i__3].r = r__1, c__[i__3].i = 0.f;
- } else {
- i__3 = j + j * c_dim1;
- i__4 = j + j * c_dim1;
- q__2.r = alpha->r * temp1.r - alpha->i * temp1.i,
- q__2.i = alpha->r * temp1.i + alpha->i *
- temp1.r;
- r_cnjg(&q__4, alpha);
- q__3.r = q__4.r * temp2.r - q__4.i * temp2.i,
- q__3.i = q__4.r * temp2.i + q__4.i *
- temp2.r;
- q__1.r = q__2.r + q__3.r, q__1.i = q__2.i +
- q__3.i;
- r__1 = *beta * c__[i__4].r + q__1.r;
- c__[i__3].r = r__1, c__[i__3].i = 0.f;
- }
- } else {
- if (*beta == 0.f) {
- i__3 = i__ + j * c_dim1;
- q__2.r = alpha->r * temp1.r - alpha->i * temp1.i,
- q__2.i = alpha->r * temp1.i + alpha->i *
- temp1.r;
- r_cnjg(&q__4, alpha);
- q__3.r = q__4.r * temp2.r - q__4.i * temp2.i,
- q__3.i = q__4.r * temp2.i + q__4.i *
- temp2.r;
- q__1.r = q__2.r + q__3.r, q__1.i = q__2.i +
- q__3.i;
- c__[i__3].r = q__1.r, c__[i__3].i = q__1.i;
- } else {
- i__3 = i__ + j * c_dim1;
- i__4 = i__ + j * c_dim1;
- q__3.r = *beta * c__[i__4].r, q__3.i = *beta *
- c__[i__4].i;
- q__4.r = alpha->r * temp1.r - alpha->i * temp1.i,
- q__4.i = alpha->r * temp1.i + alpha->i *
- temp1.r;
- q__2.r = q__3.r + q__4.r, q__2.i = q__3.i +
- q__4.i;
- r_cnjg(&q__6, alpha);
- q__5.r = q__6.r * temp2.r - q__6.i * temp2.i,
- q__5.i = q__6.r * temp2.i + q__6.i *
- temp2.r;
- q__1.r = q__2.r + q__5.r, q__1.i = q__2.i +
- q__5.i;
- c__[i__3].r = q__1.r, c__[i__3].i = q__1.i;
- }
- }
-/* L200: */
- }
-/* L210: */
- }
- } else {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- i__2 = *n;
- for (i__ = j; i__ <= i__2; ++i__) {
- temp1.r = 0.f, temp1.i = 0.f;
- temp2.r = 0.f, temp2.i = 0.f;
- i__3 = *k;
- for (l = 1; l <= i__3; ++l) {
- r_cnjg(&q__3, &a[l + i__ * a_dim1]);
- i__4 = l + j * b_dim1;
- q__2.r = q__3.r * b[i__4].r - q__3.i * b[i__4].i,
- q__2.i = q__3.r * b[i__4].i + q__3.i * b[i__4]
- .r;
- q__1.r = temp1.r + q__2.r, q__1.i = temp1.i + q__2.i;
- temp1.r = q__1.r, temp1.i = q__1.i;
- r_cnjg(&q__3, &b[l + i__ * b_dim1]);
- i__4 = l + j * a_dim1;
- q__2.r = q__3.r * a[i__4].r - q__3.i * a[i__4].i,
- q__2.i = q__3.r * a[i__4].i + q__3.i * a[i__4]
- .r;
- q__1.r = temp2.r + q__2.r, q__1.i = temp2.i + q__2.i;
- temp2.r = q__1.r, temp2.i = q__1.i;
-/* L220: */
- }
- if (i__ == j) {
- if (*beta == 0.f) {
- i__3 = j + j * c_dim1;
- q__2.r = alpha->r * temp1.r - alpha->i * temp1.i,
- q__2.i = alpha->r * temp1.i + alpha->i *
- temp1.r;
- r_cnjg(&q__4, alpha);
- q__3.r = q__4.r * temp2.r - q__4.i * temp2.i,
- q__3.i = q__4.r * temp2.i + q__4.i *
- temp2.r;
- q__1.r = q__2.r + q__3.r, q__1.i = q__2.i +
- q__3.i;
- r__1 = q__1.r;
- c__[i__3].r = r__1, c__[i__3].i = 0.f;
- } else {
- i__3 = j + j * c_dim1;
- i__4 = j + j * c_dim1;
- q__2.r = alpha->r * temp1.r - alpha->i * temp1.i,
- q__2.i = alpha->r * temp1.i + alpha->i *
- temp1.r;
- r_cnjg(&q__4, alpha);
- q__3.r = q__4.r * temp2.r - q__4.i * temp2.i,
- q__3.i = q__4.r * temp2.i + q__4.i *
- temp2.r;
- q__1.r = q__2.r + q__3.r, q__1.i = q__2.i +
- q__3.i;
- r__1 = *beta * c__[i__4].r + q__1.r;
- c__[i__3].r = r__1, c__[i__3].i = 0.f;
- }
- } else {
- if (*beta == 0.f) {
- i__3 = i__ + j * c_dim1;
- q__2.r = alpha->r * temp1.r - alpha->i * temp1.i,
- q__2.i = alpha->r * temp1.i + alpha->i *
- temp1.r;
- r_cnjg(&q__4, alpha);
- q__3.r = q__4.r * temp2.r - q__4.i * temp2.i,
- q__3.i = q__4.r * temp2.i + q__4.i *
- temp2.r;
- q__1.r = q__2.r + q__3.r, q__1.i = q__2.i +
- q__3.i;
- c__[i__3].r = q__1.r, c__[i__3].i = q__1.i;
- } else {
- i__3 = i__ + j * c_dim1;
- i__4 = i__ + j * c_dim1;
- q__3.r = *beta * c__[i__4].r, q__3.i = *beta *
- c__[i__4].i;
- q__4.r = alpha->r * temp1.r - alpha->i * temp1.i,
- q__4.i = alpha->r * temp1.i + alpha->i *
- temp1.r;
- q__2.r = q__3.r + q__4.r, q__2.i = q__3.i +
- q__4.i;
- r_cnjg(&q__6, alpha);
- q__5.r = q__6.r * temp2.r - q__6.i * temp2.i,
- q__5.i = q__6.r * temp2.i + q__6.i *
- temp2.r;
- q__1.r = q__2.r + q__5.r, q__1.i = q__2.i +
- q__5.i;
- c__[i__3].r = q__1.r, c__[i__3].i = q__1.i;
- }
- }
-/* L230: */
- }
-/* L240: */
- }
- }
- }
-
- return 0;
-
-/* End of CHER2K. */
-
-} /* cher2k_ */
-
-/* Subroutine */ int cherk_(char *uplo, char *trans, integer *n, integer *k,
- real *alpha, complex *a, integer *lda, real *beta, complex *c__,
- integer *ldc, ftnlen uplo_len, ftnlen trans_len)
-{
- /* System generated locals */
- integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2, i__3, i__4, i__5,
- i__6;
- real r__1;
- complex q__1, q__2, q__3;
-
- /* Builtin functions */
- void r_cnjg(complex *, complex *);
-
- /* Local variables */
- static integer i__, j, l, info;
- static complex temp;
- extern logical lsame_(char *, char *, ftnlen, ftnlen);
- static integer nrowa;
- static real rtemp;
- static logical upper;
- extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen);
-
-/* .. Scalar Arguments .. */
-/* .. Array Arguments .. */
-/* .. */
-
-/* Purpose */
-/* ======= */
-
-/* CHERK performs one of the hermitian rank k operations */
-
-/* C := alpha*A*conjg( A' ) + beta*C, */
-
-/* or */
-
-/* C := alpha*conjg( A' )*A + beta*C, */
-
-/* where alpha and beta are real scalars, C is an n by n hermitian */
-/* matrix and A is an n by k matrix in the first case and a k by n */
-/* matrix in the second case. */
-
-/* Parameters */
-/* ========== */
-
-/* UPLO - CHARACTER*1. */
-/* On entry, UPLO specifies whether the upper or lower */
-/* triangular part of the array C is to be referenced as */
-/* follows: */
-
-/* UPLO = 'U' or 'u' Only the upper triangular part of C */
-/* is to be referenced. */
-
-/* UPLO = 'L' or 'l' Only the lower triangular part of C */
-/* is to be referenced. */
-
-/* Unchanged on exit. */
-
-/* TRANS - CHARACTER*1. */
-/* On entry, TRANS specifies the operation to be performed as */
-/* follows: */
-
-/* TRANS = 'N' or 'n' C := alpha*A*conjg( A' ) + beta*C. */
-
-/* TRANS = 'C' or 'c' C := alpha*conjg( A' )*A + beta*C. */
-
-/* Unchanged on exit. */
-
-/* N - INTEGER. */
-/* On entry, N specifies the order of the matrix C. N must be */
-/* at least zero. */
-/* Unchanged on exit. */
-
-/* K - INTEGER. */
-/* On entry with TRANS = 'N' or 'n', K specifies the number */
-/* of columns of the matrix A, and on entry with */
-/* TRANS = 'C' or 'c', K specifies the number of rows of the */
-/* matrix A. K must be at least zero. */
-/* Unchanged on exit. */
-
-/* ALPHA - REAL . */
-/* On entry, ALPHA specifies the scalar alpha. */
-/* Unchanged on exit. */
-
-/* A - COMPLEX array of DIMENSION ( LDA, ka ), where ka is */
-/* k when TRANS = 'N' or 'n', and is n otherwise. */
-/* Before entry with TRANS = 'N' or 'n', the leading n by k */
-/* part of the array A must contain the matrix A, otherwise */
-/* the leading k by n part of the array A must contain the */
-/* matrix A. */
-/* Unchanged on exit. */
-
-/* LDA - INTEGER. */
-/* On entry, LDA specifies the first dimension of A as declared */
-/* in the calling (sub) program. When TRANS = 'N' or 'n' */
-/* then LDA must be at least max( 1, n ), otherwise LDA must */
-/* be at least max( 1, k ). */
-/* Unchanged on exit. */
-
-/* BETA - REAL . */
-/* On entry, BETA specifies the scalar beta. */
-/* Unchanged on exit. */
-
-/* C - COMPLEX array of DIMENSION ( LDC, n ). */
-/* Before entry with UPLO = 'U' or 'u', the leading n by n */
-/* upper triangular part of the array C must contain the upper */
-/* triangular part of the hermitian matrix and the strictly */
-/* lower triangular part of C is not referenced. On exit, the */
-/* upper triangular part of the array C is overwritten by the */
-/* upper triangular part of the updated matrix. */
-/* Before entry with UPLO = 'L' or 'l', the leading n by n */
-/* lower triangular part of the array C must contain the lower */
-/* triangular part of the hermitian matrix and the strictly */
-/* upper triangular part of C is not referenced. On exit, the */
-/* lower triangular part of the array C is overwritten by the */
-/* lower triangular part of the updated matrix. */
-/* Note that the imaginary parts of the diagonal elements need */
-/* not be set, they are assumed to be zero, and on exit they */
-/* are set to zero. */
-
-/* LDC - INTEGER. */
-/* On entry, LDC specifies the first dimension of C as declared */
-/* in the calling (sub) program. LDC must be at least */
-/* max( 1, n ). */
-/* Unchanged on exit. */
-
-
-/* Level 3 Blas routine. */
-
-/* -- Written on 8-February-1989. */
-/* Jack Dongarra, Argonne National Laboratory. */
-/* Iain Duff, AERE Harwell. */
-/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */
-/* Sven Hammarling, Numerical Algorithms Group Ltd. */
-
-/* -- Modified 8-Nov-93 to set C(J,J) to REAL( C(J,J) ) when BETA = 1. */
-/* Ed Anderson, Cray Research Inc. */
-
-
-/* .. External Functions .. */
-/* .. External Subroutines .. */
-/* .. Intrinsic Functions .. */
-/* .. Local Scalars .. */
-/* .. Parameters .. */
-/* .. */
-/* .. Executable Statements .. */
-
-/* Test the input parameters. */
-
- /* Parameter adjustments */
- a_dim1 = *lda;
- a_offset = 1 + a_dim1 * 1;
- a -= a_offset;
- c_dim1 = *ldc;
- c_offset = 1 + c_dim1 * 1;
- c__ -= c_offset;
-
- /* Function Body */
- if (lsame_(trans, "N", (ftnlen)1, (ftnlen)1)) {
- nrowa = *n;
- } else {
- nrowa = *k;
- }
- upper = lsame_(uplo, "U", (ftnlen)1, (ftnlen)1);
-
- info = 0;
- if (! upper && ! lsame_(uplo, "L", (ftnlen)1, (ftnlen)1)) {
- info = 1;
- } else if (! lsame_(trans, "N", (ftnlen)1, (ftnlen)1) && ! lsame_(trans,
- "C", (ftnlen)1, (ftnlen)1)) {
- info = 2;
- } else if (*n < 0) {
- info = 3;
- } else if (*k < 0) {
- info = 4;
- } else if (*lda < max(1,nrowa)) {
- info = 7;
- } else if (*ldc < max(1,*n)) {
- info = 10;
- }
- if (info != 0) {
- xerbla_("CHERK ", &info, (ftnlen)6);
- return 0;
- }
-
-/* Quick return if possible. */
-
- if (*n == 0 || (*alpha == 0.f || *k == 0) && *beta == 1.f) {
- return 0;
- }
-
-/* And when alpha.eq.zero. */
-
- if (*alpha == 0.f) {
- if (upper) {
- if (*beta == 0.f) {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- i__2 = j;
- for (i__ = 1; i__ <= i__2; ++i__) {
- i__3 = i__ + j * c_dim1;
- c__[i__3].r = 0.f, c__[i__3].i = 0.f;
-/* L10: */
- }
-/* L20: */
- }
- } else {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- i__2 = j - 1;
- for (i__ = 1; i__ <= i__2; ++i__) {
- i__3 = i__ + j * c_dim1;
- i__4 = i__ + j * c_dim1;
- q__1.r = *beta * c__[i__4].r, q__1.i = *beta * c__[
- i__4].i;
- c__[i__3].r = q__1.r, c__[i__3].i = q__1.i;
-/* L30: */
- }
- i__2 = j + j * c_dim1;
- i__3 = j + j * c_dim1;
- r__1 = *beta * c__[i__3].r;
- c__[i__2].r = r__1, c__[i__2].i = 0.f;
-/* L40: */
- }
- }
- } else {
- if (*beta == 0.f) {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- i__2 = *n;
- for (i__ = j; i__ <= i__2; ++i__) {
- i__3 = i__ + j * c_dim1;
- c__[i__3].r = 0.f, c__[i__3].i = 0.f;
-/* L50: */
- }
-/* L60: */
- }
- } else {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- i__2 = j + j * c_dim1;
- i__3 = j + j * c_dim1;
- r__1 = *beta * c__[i__3].r;
- c__[i__2].r = r__1, c__[i__2].i = 0.f;
- i__2 = *n;
- for (i__ = j + 1; i__ <= i__2; ++i__) {
- i__3 = i__ + j * c_dim1;
- i__4 = i__ + j * c_dim1;
- q__1.r = *beta * c__[i__4].r, q__1.i = *beta * c__[
- i__4].i;
- c__[i__3].r = q__1.r, c__[i__3].i = q__1.i;
-/* L70: */
- }
-/* L80: */
- }
- }
- }
- return 0;
- }
-
-/* Start the operations. */
-
- if (lsame_(trans, "N", (ftnlen)1, (ftnlen)1)) {
-
-/* Form C := alpha*A*conjg( A' ) + beta*C. */
-
- if (upper) {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- if (*beta == 0.f) {
- i__2 = j;
- for (i__ = 1; i__ <= i__2; ++i__) {
- i__3 = i__ + j * c_dim1;
- c__[i__3].r = 0.f, c__[i__3].i = 0.f;
-/* L90: */
- }
- } else if (*beta != 1.f) {
- i__2 = j - 1;
- for (i__ = 1; i__ <= i__2; ++i__) {
- i__3 = i__ + j * c_dim1;
- i__4 = i__ + j * c_dim1;
- q__1.r = *beta * c__[i__4].r, q__1.i = *beta * c__[
- i__4].i;
- c__[i__3].r = q__1.r, c__[i__3].i = q__1.i;
-/* L100: */
- }
- i__2 = j + j * c_dim1;
- i__3 = j + j * c_dim1;
- r__1 = *beta * c__[i__3].r;
- c__[i__2].r = r__1, c__[i__2].i = 0.f;
- } else {
- i__2 = j + j * c_dim1;
- i__3 = j + j * c_dim1;
- r__1 = c__[i__3].r;
- c__[i__2].r = r__1, c__[i__2].i = 0.f;
- }
- i__2 = *k;
- for (l = 1; l <= i__2; ++l) {
- i__3 = j + l * a_dim1;
- if (a[i__3].r != 0.f || a[i__3].i != 0.f) {
- r_cnjg(&q__2, &a[j + l * a_dim1]);
- q__1.r = *alpha * q__2.r, q__1.i = *alpha * q__2.i;
- temp.r = q__1.r, temp.i = q__1.i;
- i__3 = j - 1;
- for (i__ = 1; i__ <= i__3; ++i__) {
- i__4 = i__ + j * c_dim1;
- i__5 = i__ + j * c_dim1;
- i__6 = i__ + l * a_dim1;
- q__2.r = temp.r * a[i__6].r - temp.i * a[i__6].i,
- q__2.i = temp.r * a[i__6].i + temp.i * a[
- i__6].r;
- q__1.r = c__[i__5].r + q__2.r, q__1.i = c__[i__5]
- .i + q__2.i;
- c__[i__4].r = q__1.r, c__[i__4].i = q__1.i;
-/* L110: */
- }
- i__3 = j + j * c_dim1;
- i__4 = j + j * c_dim1;
- i__5 = i__ + l * a_dim1;
- q__1.r = temp.r * a[i__5].r - temp.i * a[i__5].i,
- q__1.i = temp.r * a[i__5].i + temp.i * a[i__5]
- .r;
- r__1 = c__[i__4].r + q__1.r;
- c__[i__3].r = r__1, c__[i__3].i = 0.f;
- }
-/* L120: */
- }
-/* L130: */
- }
- } else {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- if (*beta == 0.f) {
- i__2 = *n;
- for (i__ = j; i__ <= i__2; ++i__) {
- i__3 = i__ + j * c_dim1;
- c__[i__3].r = 0.f, c__[i__3].i = 0.f;
-/* L140: */
- }
- } else if (*beta != 1.f) {
- i__2 = j + j * c_dim1;
- i__3 = j + j * c_dim1;
- r__1 = *beta * c__[i__3].r;
- c__[i__2].r = r__1, c__[i__2].i = 0.f;
- i__2 = *n;
- for (i__ = j + 1; i__ <= i__2; ++i__) {
- i__3 = i__ + j * c_dim1;
- i__4 = i__ + j * c_dim1;
- q__1.r = *beta * c__[i__4].r, q__1.i = *beta * c__[
- i__4].i;
- c__[i__3].r = q__1.r, c__[i__3].i = q__1.i;
-/* L150: */
- }
- } else {
- i__2 = j + j * c_dim1;
- i__3 = j + j * c_dim1;
- r__1 = c__[i__3].r;
- c__[i__2].r = r__1, c__[i__2].i = 0.f;
- }
- i__2 = *k;
- for (l = 1; l <= i__2; ++l) {
- i__3 = j + l * a_dim1;
- if (a[i__3].r != 0.f || a[i__3].i != 0.f) {
- r_cnjg(&q__2, &a[j + l * a_dim1]);
- q__1.r = *alpha * q__2.r, q__1.i = *alpha * q__2.i;
- temp.r = q__1.r, temp.i = q__1.i;
- i__3 = j + j * c_dim1;
- i__4 = j + j * c_dim1;
- i__5 = j + l * a_dim1;
- q__1.r = temp.r * a[i__5].r - temp.i * a[i__5].i,
- q__1.i = temp.r * a[i__5].i + temp.i * a[i__5]
- .r;
- r__1 = c__[i__4].r + q__1.r;
- c__[i__3].r = r__1, c__[i__3].i = 0.f;
- i__3 = *n;
- for (i__ = j + 1; i__ <= i__3; ++i__) {
- i__4 = i__ + j * c_dim1;
- i__5 = i__ + j * c_dim1;
- i__6 = i__ + l * a_dim1;
- q__2.r = temp.r * a[i__6].r - temp.i * a[i__6].i,
- q__2.i = temp.r * a[i__6].i + temp.i * a[
- i__6].r;
- q__1.r = c__[i__5].r + q__2.r, q__1.i = c__[i__5]
- .i + q__2.i;
- c__[i__4].r = q__1.r, c__[i__4].i = q__1.i;
-/* L160: */
- }
- }
-/* L170: */
- }
-/* L180: */
- }
- }
- } else {
-
-/* Form C := alpha*conjg( A' )*A + beta*C. */
-
- if (upper) {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- i__2 = j - 1;
- for (i__ = 1; i__ <= i__2; ++i__) {
- temp.r = 0.f, temp.i = 0.f;
- i__3 = *k;
- for (l = 1; l <= i__3; ++l) {
- r_cnjg(&q__3, &a[l + i__ * a_dim1]);
- i__4 = l + j * a_dim1;
- q__2.r = q__3.r * a[i__4].r - q__3.i * a[i__4].i,
- q__2.i = q__3.r * a[i__4].i + q__3.i * a[i__4]
- .r;
- q__1.r = temp.r + q__2.r, q__1.i = temp.i + q__2.i;
- temp.r = q__1.r, temp.i = q__1.i;
-/* L190: */
- }
- if (*beta == 0.f) {
- i__3 = i__ + j * c_dim1;
- q__1.r = *alpha * temp.r, q__1.i = *alpha * temp.i;
- c__[i__3].r = q__1.r, c__[i__3].i = q__1.i;
- } else {
- i__3 = i__ + j * c_dim1;
- q__2.r = *alpha * temp.r, q__2.i = *alpha * temp.i;
- i__4 = i__ + j * c_dim1;
- q__3.r = *beta * c__[i__4].r, q__3.i = *beta * c__[
- i__4].i;
- q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
- c__[i__3].r = q__1.r, c__[i__3].i = q__1.i;
- }
-/* L200: */
- }
- rtemp = 0.f;
- i__2 = *k;
- for (l = 1; l <= i__2; ++l) {
- r_cnjg(&q__3, &a[l + j * a_dim1]);
- i__3 = l + j * a_dim1;
- q__2.r = q__3.r * a[i__3].r - q__3.i * a[i__3].i, q__2.i =
- q__3.r * a[i__3].i + q__3.i * a[i__3].r;
- q__1.r = rtemp + q__2.r, q__1.i = q__2.i;
- rtemp = q__1.r;
-/* L210: */
- }
- if (*beta == 0.f) {
- i__2 = j + j * c_dim1;
- r__1 = *alpha * rtemp;
- c__[i__2].r = r__1, c__[i__2].i = 0.f;
- } else {
- i__2 = j + j * c_dim1;
- i__3 = j + j * c_dim1;
- r__1 = *alpha * rtemp + *beta * c__[i__3].r;
- c__[i__2].r = r__1, c__[i__2].i = 0.f;
- }
-/* L220: */
- }
- } else {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- rtemp = 0.f;
- i__2 = *k;
- for (l = 1; l <= i__2; ++l) {
- r_cnjg(&q__3, &a[l + j * a_dim1]);
- i__3 = l + j * a_dim1;
- q__2.r = q__3.r * a[i__3].r - q__3.i * a[i__3].i, q__2.i =
- q__3.r * a[i__3].i + q__3.i * a[i__3].r;
- q__1.r = rtemp + q__2.r, q__1.i = q__2.i;
- rtemp = q__1.r;
-/* L230: */
- }
- if (*beta == 0.f) {
- i__2 = j + j * c_dim1;
- r__1 = *alpha * rtemp;
- c__[i__2].r = r__1, c__[i__2].i = 0.f;
- } else {
- i__2 = j + j * c_dim1;
- i__3 = j + j * c_dim1;
- r__1 = *alpha * rtemp + *beta * c__[i__3].r;
- c__[i__2].r = r__1, c__[i__2].i = 0.f;
- }
- i__2 = *n;
- for (i__ = j + 1; i__ <= i__2; ++i__) {
- temp.r = 0.f, temp.i = 0.f;
- i__3 = *k;
- for (l = 1; l <= i__3; ++l) {
- r_cnjg(&q__3, &a[l + i__ * a_dim1]);
- i__4 = l + j * a_dim1;
- q__2.r = q__3.r * a[i__4].r - q__3.i * a[i__4].i,
- q__2.i = q__3.r * a[i__4].i + q__3.i * a[i__4]
- .r;
- q__1.r = temp.r + q__2.r, q__1.i = temp.i + q__2.i;
- temp.r = q__1.r, temp.i = q__1.i;
-/* L240: */
- }
- if (*beta == 0.f) {
- i__3 = i__ + j * c_dim1;
- q__1.r = *alpha * temp.r, q__1.i = *alpha * temp.i;
- c__[i__3].r = q__1.r, c__[i__3].i = q__1.i;
- } else {
- i__3 = i__ + j * c_dim1;
- q__2.r = *alpha * temp.r, q__2.i = *alpha * temp.i;
- i__4 = i__ + j * c_dim1;
- q__3.r = *beta * c__[i__4].r, q__3.i = *beta * c__[
- i__4].i;
- q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
- c__[i__3].r = q__1.r, c__[i__3].i = q__1.i;
- }
-/* L250: */
- }
-/* L260: */
- }
- }
- }
-
- return 0;
-
-/* End of CHERK . */
-
-} /* cherk_ */
-
-/* Subroutine */ int chpmv_(char *uplo, integer *n, complex *alpha, complex *
- ap, complex *x, integer *incx, complex *beta, complex *y, integer *
- incy, ftnlen uplo_len)
-{
- /* System generated locals */
- integer i__1, i__2, i__3, i__4, i__5;
- real r__1;
- complex q__1, q__2, q__3, q__4;
-
- /* Builtin functions */
- void r_cnjg(complex *, complex *);
-
- /* Local variables */
- static integer i__, j, k, kk, ix, iy, jx, jy, kx, ky, info;
- static complex temp1, temp2;
- extern logical lsame_(char *, char *, ftnlen, ftnlen);
- extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen);
-
-/* .. Scalar Arguments .. */
-/* .. Array Arguments .. */
-/* .. */
-
-/* Purpose */
-/* ======= */
-
-/* CHPMV performs the matrix-vector operation */
-
-/* y := alpha*A*x + beta*y, */
-
-/* where alpha and beta are scalars, x and y are n element vectors and */
-/* A is an n by n hermitian matrix, supplied in packed form. */
-
-/* Parameters */
-/* ========== */
-
-/* UPLO - CHARACTER*1. */
-/* On entry, UPLO specifies whether the upper or lower */
-/* triangular part of the matrix A is supplied in the packed */
-/* array AP as follows: */
-
-/* UPLO = 'U' or 'u' The upper triangular part of A is */
-/* supplied in AP. */
-
-/* UPLO = 'L' or 'l' The lower triangular part of A is */
-/* supplied in AP. */
-
-/* Unchanged on exit. */
-
-/* N - INTEGER. */
-/* On entry, N specifies the order of the matrix A. */
-/* N must be at least zero. */
-/* Unchanged on exit. */
-
-/* ALPHA - COMPLEX . */
-/* On entry, ALPHA specifies the scalar alpha. */
-/* Unchanged on exit. */
-
-/* AP - COMPLEX array of DIMENSION at least */
-/* ( ( n*( n + 1 ) )/2 ). */
-/* Before entry with UPLO = 'U' or 'u', the array AP must */
-/* contain the upper triangular part of the hermitian matrix */
-/* packed sequentially, column by column, so that AP( 1 ) */
-/* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 ) */
-/* and a( 2, 2 ) respectively, and so on. */
-/* Before entry with UPLO = 'L' or 'l', the array AP must */
-/* contain the lower triangular part of the hermitian matrix */
-/* packed sequentially, column by column, so that AP( 1 ) */
-/* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 ) */
-/* and a( 3, 1 ) respectively, and so on. */
-/* Note that the imaginary parts of the diagonal elements need */
-/* not be set and are assumed to be zero. */
-/* Unchanged on exit. */
-
-/* X - COMPLEX array of dimension at least */
-/* ( 1 + ( n - 1 )*abs( INCX ) ). */
-/* Before entry, the incremented array X must contain the n */
-/* element vector x. */
-/* Unchanged on exit. */
-
-/* INCX - INTEGER. */
-/* On entry, INCX specifies the increment for the elements of */
-/* X. INCX must not be zero. */
-/* Unchanged on exit. */
-
-/* BETA - COMPLEX . */
-/* On entry, BETA specifies the scalar beta. When BETA is */
-/* supplied as zero then Y need not be set on input. */
-/* Unchanged on exit. */
-
-/* Y - COMPLEX array of dimension at least */
-/* ( 1 + ( n - 1 )*abs( INCY ) ). */
-/* Before entry, the incremented array Y must contain the n */
-/* element vector y. On exit, Y is overwritten by the updated */
-/* vector y. */
-
-/* INCY - INTEGER. */
-/* On entry, INCY specifies the increment for the elements of */
-/* Y. INCY must not be zero. */
-/* Unchanged on exit. */
-
-
-/* Level 2 Blas routine. */
-
-/* -- Written on 22-October-1986. */
-/* Jack Dongarra, Argonne National Lab. */
-/* Jeremy Du Croz, Nag Central Office. */
-/* Sven Hammarling, Nag Central Office. */
-/* Richard Hanson, Sandia National Labs. */
-
-
-/* .. Parameters .. */
-/* .. Local Scalars .. */
-/* .. External Functions .. */
-/* .. External Subroutines .. */
-/* .. Intrinsic Functions .. */
-/* .. */
-/* .. Executable Statements .. */
-
-/* Test the input parameters. */
-
- /* Parameter adjustments */
- --y;
- --x;
- --ap;
-
- /* Function Body */
- info = 0;
- if (! lsame_(uplo, "U", (ftnlen)1, (ftnlen)1) && ! lsame_(uplo, "L", (
- ftnlen)1, (ftnlen)1)) {
- info = 1;
- } else if (*n < 0) {
- info = 2;
- } else if (*incx == 0) {
- info = 6;
- } else if (*incy == 0) {
- info = 9;
- }
- if (info != 0) {
- xerbla_("CHPMV ", &info, (ftnlen)6);
- return 0;
- }
-
-/* Quick return if possible. */
-
- if (*n == 0 || alpha->r == 0.f && alpha->i == 0.f && (beta->r == 1.f &&
- beta->i == 0.f)) {
- return 0;
- }
-
-/* Set up the start points in X and Y. */
-
- if (*incx > 0) {
- kx = 1;
- } else {
- kx = 1 - (*n - 1) * *incx;
- }
- if (*incy > 0) {
- ky = 1;
- } else {
- ky = 1 - (*n - 1) * *incy;
- }
-
-/* Start the operations. In this version the elements of the array AP */
-/* are accessed sequentially with one pass through AP. */
-
-/* First form y := beta*y. */
-
- if (beta->r != 1.f || beta->i != 0.f) {
- if (*incy == 1) {
- if (beta->r == 0.f && beta->i == 0.f) {
- i__1 = *n;
- for (i__ = 1; i__ <= i__1; ++i__) {
- i__2 = i__;
- y[i__2].r = 0.f, y[i__2].i = 0.f;
-/* L10: */
- }
- } else {
- i__1 = *n;
- for (i__ = 1; i__ <= i__1; ++i__) {
- i__2 = i__;
- i__3 = i__;
- q__1.r = beta->r * y[i__3].r - beta->i * y[i__3].i,
- q__1.i = beta->r * y[i__3].i + beta->i * y[i__3]
- .r;
- y[i__2].r = q__1.r, y[i__2].i = q__1.i;
-/* L20: */
- }
- }
- } else {
- iy = ky;
- if (beta->r == 0.f && beta->i == 0.f) {
- i__1 = *n;
- for (i__ = 1; i__ <= i__1; ++i__) {
- i__2 = iy;
- y[i__2].r = 0.f, y[i__2].i = 0.f;
- iy += *incy;
-/* L30: */
- }
- } else {
- i__1 = *n;
- for (i__ = 1; i__ <= i__1; ++i__) {
- i__2 = iy;
- i__3 = iy;
- q__1.r = beta->r * y[i__3].r - beta->i * y[i__3].i,
- q__1.i = beta->r * y[i__3].i + beta->i * y[i__3]
- .r;
- y[i__2].r = q__1.r, y[i__2].i = q__1.i;
- iy += *incy;
-/* L40: */
- }
- }
- }
- }
- if (alpha->r == 0.f && alpha->i == 0.f) {
- return 0;
- }
- kk = 1;
- if (lsame_(uplo, "U", (ftnlen)1, (ftnlen)1)) {
-
-/* Form y when AP contains the upper triangle. */
-
- if (*incx == 1 && *incy == 1) {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- i__2 = j;
- q__1.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i, q__1.i =
- alpha->r * x[i__2].i + alpha->i * x[i__2].r;
- temp1.r = q__1.r, temp1.i = q__1.i;
- temp2.r = 0.f, temp2.i = 0.f;
- k = kk;
- i__2 = j - 1;
- for (i__ = 1; i__ <= i__2; ++i__) {
- i__3 = i__;
- i__4 = i__;
- i__5 = k;
- q__2.r = temp1.r * ap[i__5].r - temp1.i * ap[i__5].i,
- q__2.i = temp1.r * ap[i__5].i + temp1.i * ap[i__5]
- .r;
- q__1.r = y[i__4].r + q__2.r, q__1.i = y[i__4].i + q__2.i;
- y[i__3].r = q__1.r, y[i__3].i = q__1.i;
- r_cnjg(&q__3, &ap[k]);
- i__3 = i__;
- q__2.r = q__3.r * x[i__3].r - q__3.i * x[i__3].i, q__2.i =
- q__3.r * x[i__3].i + q__3.i * x[i__3].r;
- q__1.r = temp2.r + q__2.r, q__1.i = temp2.i + q__2.i;
- temp2.r = q__1.r, temp2.i = q__1.i;
- ++k;
-/* L50: */
- }
- i__2 = j;
- i__3 = j;
- i__4 = kk + j - 1;
- r__1 = ap[i__4].r;
- q__3.r = r__1 * temp1.r, q__3.i = r__1 * temp1.i;
- q__2.r = y[i__3].r + q__3.r, q__2.i = y[i__3].i + q__3.i;
- q__4.r = alpha->r * temp2.r - alpha->i * temp2.i, q__4.i =
- alpha->r * temp2.i + alpha->i * temp2.r;
- q__1.r = q__2.r + q__4.r, q__1.i = q__2.i + q__4.i;
- y[i__2].r = q__1.r, y[i__2].i = q__1.i;
- kk += j;
-/* L60: */
- }
- } else {
- jx = kx;
- jy = ky;
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- i__2 = jx;
- q__1.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i, q__1.i =
- alpha->r * x[i__2].i + alpha->i * x[i__2].r;
- temp1.r = q__1.r, temp1.i = q__1.i;
- temp2.r = 0.f, temp2.i = 0.f;
- ix = kx;
- iy = ky;
- i__2 = kk + j - 2;
- for (k = kk; k <= i__2; ++k) {
- i__3 = iy;
- i__4 = iy;
- i__5 = k;
- q__2.r = temp1.r * ap[i__5].r - temp1.i * ap[i__5].i,
- q__2.i = temp1.r * ap[i__5].i + temp1.i * ap[i__5]
- .r;
- q__1.r = y[i__4].r + q__2.r, q__1.i = y[i__4].i + q__2.i;
- y[i__3].r = q__1.r, y[i__3].i = q__1.i;
- r_cnjg(&q__3, &ap[k]);
- i__3 = ix;
- q__2.r = q__3.r * x[i__3].r - q__3.i * x[i__3].i, q__2.i =
- q__3.r * x[i__3].i + q__3.i * x[i__3].r;
- q__1.r = temp2.r + q__2.r, q__1.i = temp2.i + q__2.i;
- temp2.r = q__1.r, temp2.i = q__1.i;
- ix += *incx;
- iy += *incy;
-/* L70: */
- }
- i__2 = jy;
- i__3 = jy;
- i__4 = kk + j - 1;
- r__1 = ap[i__4].r;
- q__3.r = r__1 * temp1.r, q__3.i = r__1 * temp1.i;
- q__2.r = y[i__3].r + q__3.r, q__2.i = y[i__3].i + q__3.i;
- q__4.r = alpha->r * temp2.r - alpha->i * temp2.i, q__4.i =
- alpha->r * temp2.i + alpha->i * temp2.r;
- q__1.r = q__2.r + q__4.r, q__1.i = q__2.i + q__4.i;
- y[i__2].r = q__1.r, y[i__2].i = q__1.i;
- jx += *incx;
- jy += *incy;
- kk += j;
-/* L80: */
- }
- }
- } else {
-
-/* Form y when AP contains the lower triangle. */
-
- if (*incx == 1 && *incy == 1) {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- i__2 = j;
- q__1.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i, q__1.i =
- alpha->r * x[i__2].i + alpha->i * x[i__2].r;
- temp1.r = q__1.r, temp1.i = q__1.i;
- temp2.r = 0.f, temp2.i = 0.f;
- i__2 = j;
- i__3 = j;
- i__4 = kk;
- r__1 = ap[i__4].r;
- q__2.r = r__1 * temp1.r, q__2.i = r__1 * temp1.i;
- q__1.r = y[i__3].r + q__2.r, q__1.i = y[i__3].i + q__2.i;
- y[i__2].r = q__1.r, y[i__2].i = q__1.i;
- k = kk + 1;
- i__2 = *n;
- for (i__ = j + 1; i__ <= i__2; ++i__) {
- i__3 = i__;
- i__4 = i__;
- i__5 = k;
- q__2.r = temp1.r * ap[i__5].r - temp1.i * ap[i__5].i,
- q__2.i = temp1.r * ap[i__5].i + temp1.i * ap[i__5]
- .r;
- q__1.r = y[i__4].r + q__2.r, q__1.i = y[i__4].i + q__2.i;
- y[i__3].r = q__1.r, y[i__3].i = q__1.i;
- r_cnjg(&q__3, &ap[k]);
- i__3 = i__;
- q__2.r = q__3.r * x[i__3].r - q__3.i * x[i__3].i, q__2.i =
- q__3.r * x[i__3].i + q__3.i * x[i__3].r;
- q__1.r = temp2.r + q__2.r, q__1.i = temp2.i + q__2.i;
- temp2.r = q__1.r, temp2.i = q__1.i;
- ++k;
-/* L90: */
- }
- i__2 = j;
- i__3 = j;
- q__2.r = alpha->r * temp2.r - alpha->i * temp2.i, q__2.i =
- alpha->r * temp2.i + alpha->i * temp2.r;
- q__1.r = y[i__3].r + q__2.r, q__1.i = y[i__3].i + q__2.i;
- y[i__2].r = q__1.r, y[i__2].i = q__1.i;
- kk += *n - j + 1;
-/* L100: */
- }
- } else {
- jx = kx;
- jy = ky;
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- i__2 = jx;
- q__1.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i, q__1.i =
- alpha->r * x[i__2].i + alpha->i * x[i__2].r;
- temp1.r = q__1.r, temp1.i = q__1.i;
- temp2.r = 0.f, temp2.i = 0.f;
- i__2 = jy;
- i__3 = jy;
- i__4 = kk;
- r__1 = ap[i__4].r;
- q__2.r = r__1 * temp1.r, q__2.i = r__1 * temp1.i;
- q__1.r = y[i__3].r + q__2.r, q__1.i = y[i__3].i + q__2.i;
- y[i__2].r = q__1.r, y[i__2].i = q__1.i;
- ix = jx;
- iy = jy;
- i__2 = kk + *n - j;
- for (k = kk + 1; k <= i__2; ++k) {
- ix += *incx;
- iy += *incy;
- i__3 = iy;
- i__4 = iy;
- i__5 = k;
- q__2.r = temp1.r * ap[i__5].r - temp1.i * ap[i__5].i,
- q__2.i = temp1.r * ap[i__5].i + temp1.i * ap[i__5]
- .r;
- q__1.r = y[i__4].r + q__2.r, q__1.i = y[i__4].i + q__2.i;
- y[i__3].r = q__1.r, y[i__3].i = q__1.i;
- r_cnjg(&q__3, &ap[k]);
- i__3 = ix;
- q__2.r = q__3.r * x[i__3].r - q__3.i * x[i__3].i, q__2.i =
- q__3.r * x[i__3].i + q__3.i * x[i__3].r;
- q__1.r = temp2.r + q__2.r, q__1.i = temp2.i + q__2.i;
- temp2.r = q__1.r, temp2.i = q__1.i;
-/* L110: */
- }
- i__2 = jy;
- i__3 = jy;
- q__2.r = alpha->r * temp2.r - alpha->i * temp2.i, q__2.i =
- alpha->r * temp2.i + alpha->i * temp2.r;
- q__1.r = y[i__3].r + q__2.r, q__1.i = y[i__3].i + q__2.i;
- y[i__2].r = q__1.r, y[i__2].i = q__1.i;
- jx += *incx;
- jy += *incy;
- kk += *n - j + 1;
-/* L120: */
- }
- }
- }
-
- return 0;
-
-/* End of CHPMV . */
-
-} /* chpmv_ */
-
-/* Subroutine */ int chpr_(char *uplo, integer *n, real *alpha, complex *x,
- integer *incx, complex *ap, ftnlen uplo_len)
-{
- /* System generated locals */
- integer i__1, i__2, i__3, i__4, i__5;
- real r__1;
- complex q__1, q__2;
-
- /* Builtin functions */
- void r_cnjg(complex *, complex *);
-
- /* Local variables */
- static integer i__, j, k, kk, ix, jx, kx, info;
- static complex temp;
- extern logical lsame_(char *, char *, ftnlen, ftnlen);
- extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen);
-
-/* .. Scalar Arguments .. */
-/* .. Array Arguments .. */
-/* .. */
-
-/* Purpose */
-/* ======= */
-
-/* CHPR performs the hermitian rank 1 operation */
-
-/* A := alpha*x*conjg( x' ) + A, */
-
-/* where alpha is a real scalar, x is an n element vector and A is an */
-/* n by n hermitian matrix, supplied in packed form. */
-
-/* Parameters */
-/* ========== */
-
-/* UPLO - CHARACTER*1. */
-/* On entry, UPLO specifies whether the upper or lower */
-/* triangular part of the matrix A is supplied in the packed */
-/* array AP as follows: */
-
-/* UPLO = 'U' or 'u' The upper triangular part of A is */
-/* supplied in AP. */
-
-/* UPLO = 'L' or 'l' The lower triangular part of A is */
-/* supplied in AP. */
-
-/* Unchanged on exit. */
-
-/* N - INTEGER. */
-/* On entry, N specifies the order of the matrix A. */
-/* N must be at least zero. */
-/* Unchanged on exit. */
-
-/* ALPHA - REAL . */
-/* On entry, ALPHA specifies the scalar alpha. */
-/* Unchanged on exit. */
-
-/* X - COMPLEX array of dimension at least */
-/* ( 1 + ( n - 1 )*abs( INCX ) ). */
-/* Before entry, the incremented array X must contain the n */
-/* element vector x. */
-/* Unchanged on exit. */
-
-/* INCX - INTEGER. */
-/* On entry, INCX specifies the increment for the elements of */
-/* X. INCX must not be zero. */
-/* Unchanged on exit. */
-
-/* AP - COMPLEX array of DIMENSION at least */
-/* ( ( n*( n + 1 ) )/2 ). */
-/* Before entry with UPLO = 'U' or 'u', the array AP must */
-/* contain the upper triangular part of the hermitian matrix */
-/* packed sequentially, column by column, so that AP( 1 ) */
-/* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 ) */
-/* and a( 2, 2 ) respectively, and so on. On exit, the array */
-/* AP is overwritten by the upper triangular part of the */
-/* updated matrix. */
-/* Before entry with UPLO = 'L' or 'l', the array AP must */
-/* contain the lower triangular part of the hermitian matrix */
-/* packed sequentially, column by column, so that AP( 1 ) */
-/* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 ) */
-/* and a( 3, 1 ) respectively, and so on. On exit, the array */
-/* AP is overwritten by the lower triangular part of the */
-/* updated matrix. */
-/* Note that the imaginary parts of the diagonal elements need */
-/* not be set, they are assumed to be zero, and on exit they */
-/* are set to zero. */
-
-
-/* Level 2 Blas routine. */
-
-/* -- Written on 22-October-1986. */
-/* Jack Dongarra, Argonne National Lab. */
-/* Jeremy Du Croz, Nag Central Office. */
-/* Sven Hammarling, Nag Central Office. */
-/* Richard Hanson, Sandia National Labs. */
-
-
-/* .. Parameters .. */
-/* .. Local Scalars .. */
-/* .. External Functions .. */
-/* .. External Subroutines .. */
-/* .. Intrinsic Functions .. */
-/* .. */
-/* .. Executable Statements .. */
-
-/* Test the input parameters. */
-
- /* Parameter adjustments */
- --ap;
- --x;
-
- /* Function Body */
- info = 0;
- if (! lsame_(uplo, "U", (ftnlen)1, (ftnlen)1) && ! lsame_(uplo, "L", (
- ftnlen)1, (ftnlen)1)) {
- info = 1;
- } else if (*n < 0) {
- info = 2;
- } else if (*incx == 0) {
- info = 5;
- }
- if (info != 0) {
- xerbla_("CHPR ", &info, (ftnlen)6);
- return 0;
- }
-
-/* Quick return if possible. */
-
- if (*n == 0 || *alpha == 0.f) {
- return 0;
- }
-
-/* Set the start point in X if the increment is not unity. */
-
- if (*incx <= 0) {
- kx = 1 - (*n - 1) * *incx;
- } else if (*incx != 1) {
- kx = 1;
- }
-
-/* Start the operations. In this version the elements of the array AP */
-/* are accessed sequentially with one pass through AP. */
-
- kk = 1;
- if (lsame_(uplo, "U", (ftnlen)1, (ftnlen)1)) {
-
-/* Form A when upper triangle is stored in AP. */
-
- if (*incx == 1) {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- i__2 = j;
- if (x[i__2].r != 0.f || x[i__2].i != 0.f) {
- r_cnjg(&q__2, &x[j]);
- q__1.r = *alpha * q__2.r, q__1.i = *alpha * q__2.i;
- temp.r = q__1.r, temp.i = q__1.i;
- k = kk;
- i__2 = j - 1;
- for (i__ = 1; i__ <= i__2; ++i__) {
- i__3 = k;
- i__4 = k;
- i__5 = i__;
- q__2.r = x[i__5].r * temp.r - x[i__5].i * temp.i,
- q__2.i = x[i__5].r * temp.i + x[i__5].i *
- temp.r;
- q__1.r = ap[i__4].r + q__2.r, q__1.i = ap[i__4].i +
- q__2.i;
- ap[i__3].r = q__1.r, ap[i__3].i = q__1.i;
- ++k;
-/* L10: */
- }
- i__2 = kk + j - 1;
- i__3 = kk + j - 1;
- i__4 = j;
- q__1.r = x[i__4].r * temp.r - x[i__4].i * temp.i, q__1.i =
- x[i__4].r * temp.i + x[i__4].i * temp.r;
- r__1 = ap[i__3].r + q__1.r;
- ap[i__2].r = r__1, ap[i__2].i = 0.f;
- } else {
- i__2 = kk + j - 1;
- i__3 = kk + j - 1;
- r__1 = ap[i__3].r;
- ap[i__2].r = r__1, ap[i__2].i = 0.f;
- }
- kk += j;
-/* L20: */
- }
- } else {
- jx = kx;
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- i__2 = jx;
- if (x[i__2].r != 0.f || x[i__2].i != 0.f) {
- r_cnjg(&q__2, &x[jx]);
- q__1.r = *alpha * q__2.r, q__1.i = *alpha * q__2.i;
- temp.r = q__1.r, temp.i = q__1.i;
- ix = kx;
- i__2 = kk + j - 2;
- for (k = kk; k <= i__2; ++k) {
- i__3 = k;
- i__4 = k;
- i__5 = ix;
- q__2.r = x[i__5].r * temp.r - x[i__5].i * temp.i,
- q__2.i = x[i__5].r * temp.i + x[i__5].i *
- temp.r;
- q__1.r = ap[i__4].r + q__2.r, q__1.i = ap[i__4].i +
- q__2.i;
- ap[i__3].r = q__1.r, ap[i__3].i = q__1.i;
- ix += *incx;
-/* L30: */
- }
- i__2 = kk + j - 1;
- i__3 = kk + j - 1;
- i__4 = jx;
- q__1.r = x[i__4].r * temp.r - x[i__4].i * temp.i, q__1.i =
- x[i__4].r * temp.i + x[i__4].i * temp.r;
- r__1 = ap[i__3].r + q__1.r;
- ap[i__2].r = r__1, ap[i__2].i = 0.f;
- } else {
- i__2 = kk + j - 1;
- i__3 = kk + j - 1;
- r__1 = ap[i__3].r;
- ap[i__2].r = r__1, ap[i__2].i = 0.f;
- }
- jx += *incx;
- kk += j;
-/* L40: */
- }
- }
- } else {
-
-/* Form A when lower triangle is stored in AP. */
-
- if (*incx == 1) {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- i__2 = j;
- if (x[i__2].r != 0.f || x[i__2].i != 0.f) {
- r_cnjg(&q__2, &x[j]);
- q__1.r = *alpha * q__2.r, q__1.i = *alpha * q__2.i;
- temp.r = q__1.r, temp.i = q__1.i;
- i__2 = kk;
- i__3 = kk;
- i__4 = j;
- q__1.r = temp.r * x[i__4].r - temp.i * x[i__4].i, q__1.i =
- temp.r * x[i__4].i + temp.i * x[i__4].r;
- r__1 = ap[i__3].r + q__1.r;
- ap[i__2].r = r__1, ap[i__2].i = 0.f;
- k = kk + 1;
- i__2 = *n;
- for (i__ = j + 1; i__ <= i__2; ++i__) {
- i__3 = k;
- i__4 = k;
- i__5 = i__;
- q__2.r = x[i__5].r * temp.r - x[i__5].i * temp.i,
- q__2.i = x[i__5].r * temp.i + x[i__5].i *
- temp.r;
- q__1.r = ap[i__4].r + q__2.r, q__1.i = ap[i__4].i +
- q__2.i;
- ap[i__3].r = q__1.r, ap[i__3].i = q__1.i;
- ++k;
-/* L50: */
- }
- } else {
- i__2 = kk;
- i__3 = kk;
- r__1 = ap[i__3].r;
- ap[i__2].r = r__1, ap[i__2].i = 0.f;
- }
- kk = kk + *n - j + 1;
-/* L60: */
- }
- } else {
- jx = kx;
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- i__2 = jx;
- if (x[i__2].r != 0.f || x[i__2].i != 0.f) {
- r_cnjg(&q__2, &x[jx]);
- q__1.r = *alpha * q__2.r, q__1.i = *alpha * q__2.i;
- temp.r = q__1.r, temp.i = q__1.i;
- i__2 = kk;
- i__3 = kk;
- i__4 = jx;
- q__1.r = temp.r * x[i__4].r - temp.i * x[i__4].i, q__1.i =
- temp.r * x[i__4].i + temp.i * x[i__4].r;
- r__1 = ap[i__3].r + q__1.r;
- ap[i__2].r = r__1, ap[i__2].i = 0.f;
- ix = jx;
- i__2 = kk + *n - j;
- for (k = kk + 1; k <= i__2; ++k) {
- ix += *incx;
- i__3 = k;
- i__4 = k;
- i__5 = ix;
- q__2.r = x[i__5].r * temp.r - x[i__5].i * temp.i,
- q__2.i = x[i__5].r * temp.i + x[i__5].i *
- temp.r;
- q__1.r = ap[i__4].r + q__2.r, q__1.i = ap[i__4].i +
- q__2.i;
- ap[i__3].r = q__1.r, ap[i__3].i = q__1.i;
-/* L70: */
- }
- } else {
- i__2 = kk;
- i__3 = kk;
- r__1 = ap[i__3].r;
- ap[i__2].r = r__1, ap[i__2].i = 0.f;
- }
- jx += *incx;
- kk = kk + *n - j + 1;
-/* L80: */
- }
- }
- }
-
- return 0;
-
-/* End of CHPR . */
-
-} /* chpr_ */
-
-/* Subroutine */ int chpr2_(char *uplo, integer *n, complex *alpha, complex *
- x, integer *incx, complex *y, integer *incy, complex *ap, ftnlen
- uplo_len)
-{
- /* System generated locals */
- integer i__1, i__2, i__3, i__4, i__5, i__6;
- real r__1;
- complex q__1, q__2, q__3, q__4;
-
- /* Builtin functions */
- void r_cnjg(complex *, complex *);
-
- /* Local variables */
- static integer i__, j, k, kk, ix, iy, jx, jy, kx, ky, info;
- static complex temp1, temp2;
- extern logical lsame_(char *, char *, ftnlen, ftnlen);
- extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen);
-
-/* .. Scalar Arguments .. */
-/* .. Array Arguments .. */
-/* .. */
-
-/* Purpose */
-/* ======= */
-
-/* CHPR2 performs the hermitian rank 2 operation */
-
-/* A := alpha*x*conjg( y' ) + conjg( alpha )*y*conjg( x' ) + A, */
-
-/* where alpha is a scalar, x and y are n element vectors and A is an */
-/* n by n hermitian matrix, supplied in packed form. */
-
-/* Parameters */
-/* ========== */
-
-/* UPLO - CHARACTER*1. */
-/* On entry, UPLO specifies whether the upper or lower */
-/* triangular part of the matrix A is supplied in the packed */
-/* array AP as follows: */
-
-/* UPLO = 'U' or 'u' The upper triangular part of A is */
-/* supplied in AP. */
-
-/* UPLO = 'L' or 'l' The lower triangular part of A is */
-/* supplied in AP. */
-
-/* Unchanged on exit. */
-
-/* N - INTEGER. */
-/* On entry, N specifies the order of the matrix A. */
-/* N must be at least zero. */
-/* Unchanged on exit. */
-
-/* ALPHA - COMPLEX . */
-/* On entry, ALPHA specifies the scalar alpha. */
-/* Unchanged on exit. */
-
-/* X - COMPLEX array of dimension at least */
-/* ( 1 + ( n - 1 )*abs( INCX ) ). */
-/* Before entry, the incremented array X must contain the n */
-/* element vector x. */
-/* Unchanged on exit. */
-
-/* INCX - INTEGER. */
-/* On entry, INCX specifies the increment for the elements of */
-/* X. INCX must not be zero. */
-/* Unchanged on exit. */
-
-/* Y - COMPLEX array of dimension at least */
-/* ( 1 + ( n - 1 )*abs( INCY ) ). */
-/* Before entry, the incremented array Y must contain the n */
-/* element vector y. */
-/* Unchanged on exit. */
-
-/* INCY - INTEGER. */
-/* On entry, INCY specifies the increment for the elements of */
-/* Y. INCY must not be zero. */
-/* Unchanged on exit. */
-
-/* AP - COMPLEX array of DIMENSION at least */
-/* ( ( n*( n + 1 ) )/2 ). */
-/* Before entry with UPLO = 'U' or 'u', the array AP must */
-/* contain the upper triangular part of the hermitian matrix */
-/* packed sequentially, column by column, so that AP( 1 ) */
-/* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 ) */
-/* and a( 2, 2 ) respectively, and so on. On exit, the array */
-/* AP is overwritten by the upper triangular part of the */
-/* updated matrix. */
-/* Before entry with UPLO = 'L' or 'l', the array AP must */
-/* contain the lower triangular part of the hermitian matrix */
-/* packed sequentially, column by column, so that AP( 1 ) */
-/* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 ) */
-/* and a( 3, 1 ) respectively, and so on. On exit, the array */
-/* AP is overwritten by the lower triangular part of the */
-/* updated matrix. */
-/* Note that the imaginary parts of the diagonal elements need */
-/* not be set, they are assumed to be zero, and on exit they */
-/* are set to zero. */
-
-
-/* Level 2 Blas routine. */
-
-/* -- Written on 22-October-1986. */
-/* Jack Dongarra, Argonne National Lab. */
-/* Jeremy Du Croz, Nag Central Office. */
-/* Sven Hammarling, Nag Central Office. */
-/* Richard Hanson, Sandia National Labs. */
-
-
-/* .. Parameters .. */
-/* .. Local Scalars .. */
-/* .. External Functions .. */
-/* .. External Subroutines .. */
-/* .. Intrinsic Functions .. */
-/* .. */
-/* .. Executable Statements .. */
-
-/* Test the input parameters. */
-
- /* Parameter adjustments */
- --ap;
- --y;
- --x;
-
- /* Function Body */
- info = 0;
- if (! lsame_(uplo, "U", (ftnlen)1, (ftnlen)1) && ! lsame_(uplo, "L", (
- ftnlen)1, (ftnlen)1)) {
- info = 1;
- } else if (*n < 0) {
- info = 2;
- } else if (*incx == 0) {
- info = 5;
- } else if (*incy == 0) {
- info = 7;
- }
- if (info != 0) {
- xerbla_("CHPR2 ", &info, (ftnlen)6);
- return 0;
- }
-
-/* Quick return if possible. */
-
- if (*n == 0 || alpha->r == 0.f && alpha->i == 0.f) {
- return 0;
- }
-
-/* Set up the start points in X and Y if the increments are not both */
-/* unity. */
-
- if (*incx != 1 || *incy != 1) {
- if (*incx > 0) {
- kx = 1;
- } else {
- kx = 1 - (*n - 1) * *incx;
- }
- if (*incy > 0) {
- ky = 1;
- } else {
- ky = 1 - (*n - 1) * *incy;
- }
- jx = kx;
- jy = ky;
- }
-
-/* Start the operations. In this version the elements of the array AP */
-/* are accessed sequentially with one pass through AP. */
-
- kk = 1;
- if (lsame_(uplo, "U", (ftnlen)1, (ftnlen)1)) {
-
-/* Form A when upper triangle is stored in AP. */
-
- if (*incx == 1 && *incy == 1) {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- i__2 = j;
- i__3 = j;
- if (x[i__2].r != 0.f || x[i__2].i != 0.f || (y[i__3].r != 0.f
- || y[i__3].i != 0.f)) {
- r_cnjg(&q__2, &y[j]);
- q__1.r = alpha->r * q__2.r - alpha->i * q__2.i, q__1.i =
- alpha->r * q__2.i + alpha->i * q__2.r;
- temp1.r = q__1.r, temp1.i = q__1.i;
- i__2 = j;
- q__2.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i,
- q__2.i = alpha->r * x[i__2].i + alpha->i * x[i__2]
- .r;
- r_cnjg(&q__1, &q__2);
- temp2.r = q__1.r, temp2.i = q__1.i;
- k = kk;
- i__2 = j - 1;
- for (i__ = 1; i__ <= i__2; ++i__) {
- i__3 = k;
- i__4 = k;
- i__5 = i__;
- q__3.r = x[i__5].r * temp1.r - x[i__5].i * temp1.i,
- q__3.i = x[i__5].r * temp1.i + x[i__5].i *
- temp1.r;
- q__2.r = ap[i__4].r + q__3.r, q__2.i = ap[i__4].i +
- q__3.i;
- i__6 = i__;
- q__4.r = y[i__6].r * temp2.r - y[i__6].i * temp2.i,
- q__4.i = y[i__6].r * temp2.i + y[i__6].i *
- temp2.r;
- q__1.r = q__2.r + q__4.r, q__1.i = q__2.i + q__4.i;
- ap[i__3].r = q__1.r, ap[i__3].i = q__1.i;
- ++k;
-/* L10: */
- }
- i__2 = kk + j - 1;
- i__3 = kk + j - 1;
- i__4 = j;
- q__2.r = x[i__4].r * temp1.r - x[i__4].i * temp1.i,
- q__2.i = x[i__4].r * temp1.i + x[i__4].i *
- temp1.r;
- i__5 = j;
- q__3.r = y[i__5].r * temp2.r - y[i__5].i * temp2.i,
- q__3.i = y[i__5].r * temp2.i + y[i__5].i *
- temp2.r;
- q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
- r__1 = ap[i__3].r + q__1.r;
- ap[i__2].r = r__1, ap[i__2].i = 0.f;
- } else {
- i__2 = kk + j - 1;
- i__3 = kk + j - 1;
- r__1 = ap[i__3].r;
- ap[i__2].r = r__1, ap[i__2].i = 0.f;
- }
- kk += j;
-/* L20: */
- }
- } else {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- i__2 = jx;
- i__3 = jy;
- if (x[i__2].r != 0.f || x[i__2].i != 0.f || (y[i__3].r != 0.f
- || y[i__3].i != 0.f)) {
- r_cnjg(&q__2, &y[jy]);
- q__1.r = alpha->r * q__2.r - alpha->i * q__2.i, q__1.i =
- alpha->r * q__2.i + alpha->i * q__2.r;
- temp1.r = q__1.r, temp1.i = q__1.i;
- i__2 = jx;
- q__2.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i,
- q__2.i = alpha->r * x[i__2].i + alpha->i * x[i__2]
- .r;
- r_cnjg(&q__1, &q__2);
- temp2.r = q__1.r, temp2.i = q__1.i;
- ix = kx;
- iy = ky;
- i__2 = kk + j - 2;
- for (k = kk; k <= i__2; ++k) {
- i__3 = k;
- i__4 = k;
- i__5 = ix;
- q__3.r = x[i__5].r * temp1.r - x[i__5].i * temp1.i,
- q__3.i = x[i__5].r * temp1.i + x[i__5].i *
- temp1.r;
- q__2.r = ap[i__4].r + q__3.r, q__2.i = ap[i__4].i +
- q__3.i;
- i__6 = iy;
- q__4.r = y[i__6].r * temp2.r - y[i__6].i * temp2.i,
- q__4.i = y[i__6].r * temp2.i + y[i__6].i *
- temp2.r;
- q__1.r = q__2.r + q__4.r, q__1.i = q__2.i + q__4.i;
- ap[i__3].r = q__1.r, ap[i__3].i = q__1.i;
- ix += *incx;
- iy += *incy;
-/* L30: */
- }
- i__2 = kk + j - 1;
- i__3 = kk + j - 1;
- i__4 = jx;
- q__2.r = x[i__4].r * temp1.r - x[i__4].i * temp1.i,
- q__2.i = x[i__4].r * temp1.i + x[i__4].i *
- temp1.r;
- i__5 = jy;
- q__3.r = y[i__5].r * temp2.r - y[i__5].i * temp2.i,
- q__3.i = y[i__5].r * temp2.i + y[i__5].i *
- temp2.r;
- q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
- r__1 = ap[i__3].r + q__1.r;
- ap[i__2].r = r__1, ap[i__2].i = 0.f;
- } else {
- i__2 = kk + j - 1;
- i__3 = kk + j - 1;
- r__1 = ap[i__3].r;
- ap[i__2].r = r__1, ap[i__2].i = 0.f;
- }
- jx += *incx;
- jy += *incy;
- kk += j;
-/* L40: */
- }
- }
- } else {
-
-/* Form A when lower triangle is stored in AP. */
-
- if (*incx == 1 && *incy == 1) {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- i__2 = j;
- i__3 = j;
- if (x[i__2].r != 0.f || x[i__2].i != 0.f || (y[i__3].r != 0.f
- || y[i__3].i != 0.f)) {
- r_cnjg(&q__2, &y[j]);
- q__1.r = alpha->r * q__2.r - alpha->i * q__2.i, q__1.i =
- alpha->r * q__2.i + alpha->i * q__2.r;
- temp1.r = q__1.r, temp1.i = q__1.i;
- i__2 = j;
- q__2.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i,
- q__2.i = alpha->r * x[i__2].i + alpha->i * x[i__2]
- .r;
- r_cnjg(&q__1, &q__2);
- temp2.r = q__1.r, temp2.i = q__1.i;
- i__2 = kk;
- i__3 = kk;
- i__4 = j;
- q__2.r = x[i__4].r * temp1.r - x[i__4].i * temp1.i,
- q__2.i = x[i__4].r * temp1.i + x[i__4].i *
- temp1.r;
- i__5 = j;
- q__3.r = y[i__5].r * temp2.r - y[i__5].i * temp2.i,
- q__3.i = y[i__5].r * temp2.i + y[i__5].i *
- temp2.r;
- q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
- r__1 = ap[i__3].r + q__1.r;
- ap[i__2].r = r__1, ap[i__2].i = 0.f;
- k = kk + 1;
- i__2 = *n;
- for (i__ = j + 1; i__ <= i__2; ++i__) {
- i__3 = k;
- i__4 = k;
- i__5 = i__;
- q__3.r = x[i__5].r * temp1.r - x[i__5].i * temp1.i,
- q__3.i = x[i__5].r * temp1.i + x[i__5].i *
- temp1.r;
- q__2.r = ap[i__4].r + q__3.r, q__2.i = ap[i__4].i +
- q__3.i;
- i__6 = i__;
- q__4.r = y[i__6].r * temp2.r - y[i__6].i * temp2.i,
- q__4.i = y[i__6].r * temp2.i + y[i__6].i *
- temp2.r;
- q__1.r = q__2.r + q__4.r, q__1.i = q__2.i + q__4.i;
- ap[i__3].r = q__1.r, ap[i__3].i = q__1.i;
- ++k;
-/* L50: */
- }
- } else {
- i__2 = kk;
- i__3 = kk;
- r__1 = ap[i__3].r;
- ap[i__2].r = r__1, ap[i__2].i = 0.f;
- }
- kk = kk + *n - j + 1;
-/* L60: */
- }
- } else {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- i__2 = jx;
- i__3 = jy;
- if (x[i__2].r != 0.f || x[i__2].i != 0.f || (y[i__3].r != 0.f
- || y[i__3].i != 0.f)) {
- r_cnjg(&q__2, &y[jy]);
- q__1.r = alpha->r * q__2.r - alpha->i * q__2.i, q__1.i =
- alpha->r * q__2.i + alpha->i * q__2.r;
- temp1.r = q__1.r, temp1.i = q__1.i;
- i__2 = jx;
- q__2.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i,
- q__2.i = alpha->r * x[i__2].i + alpha->i * x[i__2]
- .r;
- r_cnjg(&q__1, &q__2);
- temp2.r = q__1.r, temp2.i = q__1.i;
- i__2 = kk;
- i__3 = kk;
- i__4 = jx;
- q__2.r = x[i__4].r * temp1.r - x[i__4].i * temp1.i,
- q__2.i = x[i__4].r * temp1.i + x[i__4].i *
- temp1.r;
- i__5 = jy;
- q__3.r = y[i__5].r * temp2.r - y[i__5].i * temp2.i,
- q__3.i = y[i__5].r * temp2.i + y[i__5].i *
- temp2.r;
- q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
- r__1 = ap[i__3].r + q__1.r;
- ap[i__2].r = r__1, ap[i__2].i = 0.f;
- ix = jx;
- iy = jy;
- i__2 = kk + *n - j;
- for (k = kk + 1; k <= i__2; ++k) {
- ix += *incx;
- iy += *incy;
- i__3 = k;
- i__4 = k;
- i__5 = ix;
- q__3.r = x[i__5].r * temp1.r - x[i__5].i * temp1.i,
- q__3.i = x[i__5].r * temp1.i + x[i__5].i *
- temp1.r;
- q__2.r = ap[i__4].r + q__3.r, q__2.i = ap[i__4].i +
- q__3.i;
- i__6 = iy;
- q__4.r = y[i__6].r * temp2.r - y[i__6].i * temp2.i,
- q__4.i = y[i__6].r * temp2.i + y[i__6].i *
- temp2.r;
- q__1.r = q__2.r + q__4.r, q__1.i = q__2.i + q__4.i;
- ap[i__3].r = q__1.r, ap[i__3].i = q__1.i;
-/* L70: */
- }
- } else {
- i__2 = kk;
- i__3 = kk;
- r__1 = ap[i__3].r;
- ap[i__2].r = r__1, ap[i__2].i = 0.f;
- }
- jx += *incx;
- jy += *incy;
- kk = kk + *n - j + 1;
-/* L80: */
- }
- }
- }
-
- return 0;
-
-/* End of CHPR2 . */
-
-} /* chpr2_ */
-
-/* Subroutine */ int crotg_(complex *ca, complex *cb, real *c__, complex *s)
-{
- /* System generated locals */
- real r__1, r__2;
- complex q__1, q__2, q__3;
-
- /* Builtin functions */
- double c_abs(complex *), sqrt(doublereal);
- void r_cnjg(complex *, complex *);
-
- /* Local variables */
- static real norm;
- static complex alpha;
- static real scale;
-
- if (c_abs(ca) != 0.f) {
- goto L10;
- }
- *c__ = 0.f;
- s->r = 1.f, s->i = 0.f;
- ca->r = cb->r, ca->i = cb->i;
- goto L20;
-L10:
- scale = c_abs(ca) + c_abs(cb);
- q__1.r = ca->r / scale, q__1.i = ca->i / scale;
-/* Computing 2nd power */
- r__1 = c_abs(&q__1);
- q__2.r = cb->r / scale, q__2.i = cb->i / scale;
-/* Computing 2nd power */
- r__2 = c_abs(&q__2);
- norm = scale * sqrt(r__1 * r__1 + r__2 * r__2);
- r__1 = c_abs(ca);
- q__1.r = ca->r / r__1, q__1.i = ca->i / r__1;
- alpha.r = q__1.r, alpha.i = q__1.i;
- *c__ = c_abs(ca) / norm;
- r_cnjg(&q__3, cb);
- q__2.r = alpha.r * q__3.r - alpha.i * q__3.i, q__2.i = alpha.r * q__3.i +
- alpha.i * q__3.r;
- q__1.r = q__2.r / norm, q__1.i = q__2.i / norm;
- s->r = q__1.r, s->i = q__1.i;
- q__1.r = norm * alpha.r, q__1.i = norm * alpha.i;
- ca->r = q__1.r, ca->i = q__1.i;
-L20:
- return 0;
-} /* crotg_ */
-
-/* Subroutine */ int cscal_(integer *n, complex *ca, complex *cx, integer *
- incx)
-{
- /* System generated locals */
- integer i__1, i__2, i__3, i__4;
- complex q__1;
-
- /* Local variables */
- static integer i__, nincx;
-
-
-/* scales a vector by a constant. */
-/* jack dongarra, linpack, 3/11/78. */
-/* modified 3/93 to return if incx .le. 0. */
-/* modified 12/3/93, array(1) declarations changed to array(*) */
-
-
- /* Parameter adjustments */
- --cx;
-
- /* Function Body */
- if (*n <= 0 || *incx <= 0) {
- return 0;
- }
- if (*incx == 1) {
- goto L20;
- }
-
-/* code for increment not equal to 1 */
-
- nincx = *n * *incx;
- i__1 = nincx;
- i__2 = *incx;
- for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
- i__3 = i__;
- i__4 = i__;
- q__1.r = ca->r * cx[i__4].r - ca->i * cx[i__4].i, q__1.i = ca->r * cx[
- i__4].i + ca->i * cx[i__4].r;
- cx[i__3].r = q__1.r, cx[i__3].i = q__1.i;
-/* L10: */
- }
- return 0;
-
-/* code for increment equal to 1 */
-
-L20:
- i__2 = *n;
- for (i__ = 1; i__ <= i__2; ++i__) {
- i__1 = i__;
- i__3 = i__;
- q__1.r = ca->r * cx[i__3].r - ca->i * cx[i__3].i, q__1.i = ca->r * cx[
- i__3].i + ca->i * cx[i__3].r;
- cx[i__1].r = q__1.r, cx[i__1].i = q__1.i;
-/* L30: */
- }
- return 0;
-} /* cscal_ */
-
-/* Subroutine */ int csrot_(integer *n, complex *cx, integer *incx, complex *
- cy, integer *incy, real *c__, real *s)
-{
- /* System generated locals */
- integer i__1, i__2, i__3, i__4;
- complex q__1, q__2, q__3;
-
- /* Local variables */
- static integer i__, ix, iy;
- static complex ctemp;
-
-
-/* applies a plane rotation, where the cos and sin (c and s) are real */
-/* and the vectors cx and cy are complex. */
-/* jack dongarra, linpack, 3/11/78. */
-
-
- /* Parameter adjustments */
- --cy;
- --cx;
-
- /* Function Body */
- if (*n <= 0) {
- return 0;
- }
- if (*incx == 1 && *incy == 1) {
- goto L20;
- }
-
-/* code for unequal increments or equal increments not equal */
-/* to 1 */
-
- ix = 1;
- iy = 1;
- if (*incx < 0) {
- ix = (-(*n) + 1) * *incx + 1;
- }
- if (*incy < 0) {
- iy = (-(*n) + 1) * *incy + 1;
- }
- i__1 = *n;
- for (i__ = 1; i__ <= i__1; ++i__) {
- i__2 = ix;
- q__2.r = *c__ * cx[i__2].r, q__2.i = *c__ * cx[i__2].i;
- i__3 = iy;
- q__3.r = *s * cy[i__3].r, q__3.i = *s * cy[i__3].i;
- q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
- ctemp.r = q__1.r, ctemp.i = q__1.i;
- i__2 = iy;
- i__3 = iy;
- q__2.r = *c__ * cy[i__3].r, q__2.i = *c__ * cy[i__3].i;
- i__4 = ix;
- q__3.r = *s * cx[i__4].r, q__3.i = *s * cx[i__4].i;
- q__1.r = q__2.r - q__3.r, q__1.i = q__2.i - q__3.i;
- cy[i__2].r = q__1.r, cy[i__2].i = q__1.i;
- i__2 = ix;
- cx[i__2].r = ctemp.r, cx[i__2].i = ctemp.i;
- ix += *incx;
- iy += *incy;
-/* L10: */
- }
- return 0;
-
-/* code for both increments equal to 1 */
-
-L20:
- i__1 = *n;
- for (i__ = 1; i__ <= i__1; ++i__) {
- i__2 = i__;
- q__2.r = *c__ * cx[i__2].r, q__2.i = *c__ * cx[i__2].i;
- i__3 = i__;
- q__3.r = *s * cy[i__3].r, q__3.i = *s * cy[i__3].i;
- q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
- ctemp.r = q__1.r, ctemp.i = q__1.i;
- i__2 = i__;
- i__3 = i__;
- q__2.r = *c__ * cy[i__3].r, q__2.i = *c__ * cy[i__3].i;
- i__4 = i__;
- q__3.r = *s * cx[i__4].r, q__3.i = *s * cx[i__4].i;
- q__1.r = q__2.r - q__3.r, q__1.i = q__2.i - q__3.i;
- cy[i__2].r = q__1.r, cy[i__2].i = q__1.i;
- i__2 = i__;
- cx[i__2].r = ctemp.r, cx[i__2].i = ctemp.i;
-/* L30: */
- }
- return 0;
-} /* csrot_ */
-
-/* Subroutine */ int csscal_(integer *n, real *sa, complex *cx, integer *incx)
-{
- /* System generated locals */
- integer i__1, i__2, i__3, i__4;
- real r__1, r__2;
- complex q__1;
-
- /* Builtin functions */
- double r_imag(complex *);
-
- /* Local variables */
- static integer i__, nincx;
-
-
-/* scales a complex vector by a real constant. */
-/* jack dongarra, linpack, 3/11/78. */
-/* modified 3/93 to return if incx .le. 0. */
-/* modified 12/3/93, array(1) declarations changed to array(*) */
-
-
- /* Parameter adjustments */
- --cx;
-
- /* Function Body */
- if (*n <= 0 || *incx <= 0) {
- return 0;
- }
- if (*incx == 1) {
- goto L20;
- }
-
-/* code for increment not equal to 1 */
-
- nincx = *n * *incx;
- i__1 = nincx;
- i__2 = *incx;
- for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
- i__3 = i__;
- i__4 = i__;
- r__1 = *sa * cx[i__4].r;
- r__2 = *sa * r_imag(&cx[i__]);
- q__1.r = r__1, q__1.i = r__2;
- cx[i__3].r = q__1.r, cx[i__3].i = q__1.i;
-/* L10: */
- }
- return 0;
-
-/* code for increment equal to 1 */
-
-L20:
- i__2 = *n;
- for (i__ = 1; i__ <= i__2; ++i__) {
- i__1 = i__;
- i__3 = i__;
- r__1 = *sa * cx[i__3].r;
- r__2 = *sa * r_imag(&cx[i__]);
- q__1.r = r__1, q__1.i = r__2;
- cx[i__1].r = q__1.r, cx[i__1].i = q__1.i;
-/* L30: */
- }
- return 0;
-} /* csscal_ */
-
-/* Subroutine */ int cswap_(integer *n, complex *cx, integer *incx, complex *
- cy, integer *incy)
-{
- /* System generated locals */
- integer i__1, i__2, i__3;
-
- /* Local variables */
- static integer i__, ix, iy;
- static complex ctemp;
-
-
-/* interchanges two vectors. */
-/* jack dongarra, linpack, 3/11/78. */
-/* modified 12/3/93, array(1) declarations changed to array(*) */
-
-
- /* Parameter adjustments */
- --cy;
- --cx;
-
- /* Function Body */
- if (*n <= 0) {
- return 0;
- }
- if (*incx == 1 && *incy == 1) {
- goto L20;
- }
-
-/* code for unequal increments or equal increments not equal */
-/* to 1 */
-
- ix = 1;
- iy = 1;
- if (*incx < 0) {
- ix = (-(*n) + 1) * *incx + 1;
- }
- if (*incy < 0) {
- iy = (-(*n) + 1) * *incy + 1;
- }
- i__1 = *n;
- for (i__ = 1; i__ <= i__1; ++i__) {
- i__2 = ix;
- ctemp.r = cx[i__2].r, ctemp.i = cx[i__2].i;
- i__2 = ix;
- i__3 = iy;
- cx[i__2].r = cy[i__3].r, cx[i__2].i = cy[i__3].i;
- i__2 = iy;
- cy[i__2].r = ctemp.r, cy[i__2].i = ctemp.i;
- ix += *incx;
- iy += *incy;
-/* L10: */
- }
- return 0;
-
-/* code for both increments equal to 1 */
-L20:
- i__1 = *n;
- for (i__ = 1; i__ <= i__1; ++i__) {
- i__2 = i__;
- ctemp.r = cx[i__2].r, ctemp.i = cx[i__2].i;
- i__2 = i__;
- i__3 = i__;
- cx[i__2].r = cy[i__3].r, cx[i__2].i = cy[i__3].i;
- i__2 = i__;
- cy[i__2].r = ctemp.r, cy[i__2].i = ctemp.i;
-/* L30: */
- }
- return 0;
-} /* cswap_ */
-
-/* Subroutine */ int csymm_(char *side, char *uplo, integer *m, integer *n,
- complex *alpha, complex *a, integer *lda, complex *b, integer *ldb,
- complex *beta, complex *c__, integer *ldc, ftnlen side_len, ftnlen
- uplo_len)
-{
- /* System generated locals */
- integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2,
- i__3, i__4, i__5, i__6;
- complex q__1, q__2, q__3, q__4, q__5;
-
- /* Local variables */
- static integer i__, j, k, info;
- static complex temp1, temp2;
- extern logical lsame_(char *, char *, ftnlen, ftnlen);
- static integer nrowa;
- static logical upper;
- extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen);
-
-/* .. Scalar Arguments .. */
-/* .. Array Arguments .. */
-/* .. */
-
-/* Purpose */
-/* ======= */
-
-/* CSYMM performs one of the matrix-matrix operations */
-
-/* C := alpha*A*B + beta*C, */
-
-/* or */
-
-/* C := alpha*B*A + beta*C, */
-
-/* where alpha and beta are scalars, A is a symmetric matrix and B and */
-/* C are m by n matrices. */
-
-/* Parameters */
-/* ========== */
-
-/* SIDE - CHARACTER*1. */
-/* On entry, SIDE specifies whether the symmetric matrix A */
-/* appears on the left or right in the operation as follows: */
-
-/* SIDE = 'L' or 'l' C := alpha*A*B + beta*C, */
-
-/* SIDE = 'R' or 'r' C := alpha*B*A + beta*C, */
-
-/* Unchanged on exit. */
-
-/* UPLO - CHARACTER*1. */
-/* On entry, UPLO specifies whether the upper or lower */
-/* triangular part of the symmetric matrix A is to be */
-/* referenced as follows: */
-
-/* UPLO = 'U' or 'u' Only the upper triangular part of the */
-/* symmetric matrix is to be referenced. */
-
-/* UPLO = 'L' or 'l' Only the lower triangular part of the */
-/* symmetric matrix is to be referenced. */
-
-/* Unchanged on exit. */
-
-/* M - INTEGER. */
-/* On entry, M specifies the number of rows of the matrix C. */
-/* M must be at least zero. */
-/* Unchanged on exit. */
-
-/* N - INTEGER. */
-/* On entry, N specifies the number of columns of the matrix C. */
-/* N must be at least zero. */
-/* Unchanged on exit. */
-
-/* ALPHA - COMPLEX . */
-/* On entry, ALPHA specifies the scalar alpha. */
-/* Unchanged on exit. */
-
-/* A - COMPLEX array of DIMENSION ( LDA, ka ), where ka is */
-/* m when SIDE = 'L' or 'l' and is n otherwise. */
-/* Before entry with SIDE = 'L' or 'l', the m by m part of */
-/* the array A must contain the symmetric matrix, such that */
-/* when UPLO = 'U' or 'u', the leading m by m upper triangular */
-/* part of the array A must contain the upper triangular part */
-/* of the symmetric matrix and the strictly lower triangular */
-/* part of A is not referenced, and when UPLO = 'L' or 'l', */
-/* the leading m by m lower triangular part of the array A */
-/* must contain the lower triangular part of the symmetric */
-/* matrix and the strictly upper triangular part of A is not */
-/* referenced. */
-/* Before entry with SIDE = 'R' or 'r', the n by n part of */
-/* the array A must contain the symmetric matrix, such that */
-/* when UPLO = 'U' or 'u', the leading n by n upper triangular */
-/* part of the array A must contain the upper triangular part */
-/* of the symmetric matrix and the strictly lower triangular */
-/* part of A is not referenced, and when UPLO = 'L' or 'l', */
-/* the leading n by n lower triangular part of the array A */
-/* must contain the lower triangular part of the symmetric */
-/* matrix and the strictly upper triangular part of A is not */
-/* referenced. */
-/* Unchanged on exit. */
-
-/* LDA - INTEGER. */
-/* On entry, LDA specifies the first dimension of A as declared */
-/* in the calling (sub) program. When SIDE = 'L' or 'l' then */
-/* LDA must be at least max( 1, m ), otherwise LDA must be at */
-/* least max( 1, n ). */
-/* Unchanged on exit. */
-
-/* B - COMPLEX array of DIMENSION ( LDB, n ). */
-/* Before entry, the leading m by n part of the array B must */
-/* contain the matrix B. */
-/* Unchanged on exit. */
-
-/* LDB - INTEGER. */
-/* On entry, LDB specifies the first dimension of B as declared */
-/* in the calling (sub) program. LDB must be at least */
-/* max( 1, m ). */
-/* Unchanged on exit. */
-
-/* BETA - COMPLEX . */
-/* On entry, BETA specifies the scalar beta. When BETA is */
-/* supplied as zero then C need not be set on input. */
-/* Unchanged on exit. */
-
-/* C - COMPLEX array of DIMENSION ( LDC, n ). */
-/* Before entry, the leading m by n part of the array C must */
-/* contain the matrix C, except when beta is zero, in which */
-/* case C need not be set on entry. */
-/* On exit, the array C is overwritten by the m by n updated */
-/* matrix. */
-
-/* LDC - INTEGER. */
-/* On entry, LDC specifies the first dimension of C as declared */
-/* in the calling (sub) program. LDC must be at least */
-/* max( 1, m ). */
-/* Unchanged on exit. */
-
-
-/* Level 3 Blas routine. */
-
-/* -- Written on 8-February-1989. */
-/* Jack Dongarra, Argonne National Laboratory. */
-/* Iain Duff, AERE Harwell. */
-/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */
-/* Sven Hammarling, Numerical Algorithms Group Ltd. */
-
-
-/* .. External Functions .. */
-/* .. External Subroutines .. */
-/* .. Intrinsic Functions .. */
-/* .. Local Scalars .. */
-/* .. Parameters .. */
-/* .. */
-/* .. Executable Statements .. */
-
-/* Set NROWA as the number of rows of A. */
-
- /* Parameter adjustments */
- a_dim1 = *lda;
- a_offset = 1 + a_dim1 * 1;
- a -= a_offset;
- b_dim1 = *ldb;
- b_offset = 1 + b_dim1 * 1;
- b -= b_offset;
- c_dim1 = *ldc;
- c_offset = 1 + c_dim1 * 1;
- c__ -= c_offset;
-
- /* Function Body */
- if (lsame_(side, "L", (ftnlen)1, (ftnlen)1)) {
- nrowa = *m;
- } else {
- nrowa = *n;
- }
- upper = lsame_(uplo, "U", (ftnlen)1, (ftnlen)1);
-
-/* Test the input parameters. */
-
- info = 0;
- if (! lsame_(side, "L", (ftnlen)1, (ftnlen)1) && ! lsame_(side, "R", (
- ftnlen)1, (ftnlen)1)) {
- info = 1;
- } else if (! upper && ! lsame_(uplo, "L", (ftnlen)1, (ftnlen)1)) {
- info = 2;
- } else if (*m < 0) {
- info = 3;
- } else if (*n < 0) {
- info = 4;
- } else if (*lda < max(1,nrowa)) {
- info = 7;
- } else if (*ldb < max(1,*m)) {
- info = 9;
- } else if (*ldc < max(1,*m)) {
- info = 12;
- }
- if (info != 0) {
- xerbla_("CSYMM ", &info, (ftnlen)6);
- return 0;
- }
-
-/* Quick return if possible. */
-
- if (*m == 0 || *n == 0 || alpha->r == 0.f && alpha->i == 0.f && (beta->r
- == 1.f && beta->i == 0.f)) {
- return 0;
- }
-
-/* And when alpha.eq.zero. */
-
- if (alpha->r == 0.f && alpha->i == 0.f) {
- if (beta->r == 0.f && beta->i == 0.f) {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- i__2 = *m;
- for (i__ = 1; i__ <= i__2; ++i__) {
- i__3 = i__ + j * c_dim1;
- c__[i__3].r = 0.f, c__[i__3].i = 0.f;
-/* L10: */
- }
-/* L20: */
- }
- } else {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- i__2 = *m;
- for (i__ = 1; i__ <= i__2; ++i__) {
- i__3 = i__ + j * c_dim1;
- i__4 = i__ + j * c_dim1;
- q__1.r = beta->r * c__[i__4].r - beta->i * c__[i__4].i,
- q__1.i = beta->r * c__[i__4].i + beta->i * c__[
- i__4].r;
- c__[i__3].r = q__1.r, c__[i__3].i = q__1.i;
-/* L30: */
- }
-/* L40: */
- }
- }
- return 0;
- }
-
-/* Start the operations. */
-
- if (lsame_(side, "L", (ftnlen)1, (ftnlen)1)) {
-
-/* Form C := alpha*A*B + beta*C. */
-
- if (upper) {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- i__2 = *m;
- for (i__ = 1; i__ <= i__2; ++i__) {
- i__3 = i__ + j * b_dim1;
- q__1.r = alpha->r * b[i__3].r - alpha->i * b[i__3].i,
- q__1.i = alpha->r * b[i__3].i + alpha->i * b[i__3]
- .r;
- temp1.r = q__1.r, temp1.i = q__1.i;
- temp2.r = 0.f, temp2.i = 0.f;
- i__3 = i__ - 1;
- for (k = 1; k <= i__3; ++k) {
- i__4 = k + j * c_dim1;
- i__5 = k + j * c_dim1;
- i__6 = k + i__ * a_dim1;
- q__2.r = temp1.r * a[i__6].r - temp1.i * a[i__6].i,
- q__2.i = temp1.r * a[i__6].i + temp1.i * a[
- i__6].r;
- q__1.r = c__[i__5].r + q__2.r, q__1.i = c__[i__5].i +
- q__2.i;
- c__[i__4].r = q__1.r, c__[i__4].i = q__1.i;
- i__4 = k + j * b_dim1;
- i__5 = k + i__ * a_dim1;
- q__2.r = b[i__4].r * a[i__5].r - b[i__4].i * a[i__5]
- .i, q__2.i = b[i__4].r * a[i__5].i + b[i__4]
- .i * a[i__5].r;
- q__1.r = temp2.r + q__2.r, q__1.i = temp2.i + q__2.i;
- temp2.r = q__1.r, temp2.i = q__1.i;
-/* L50: */
- }
- if (beta->r == 0.f && beta->i == 0.f) {
- i__3 = i__ + j * c_dim1;
- i__4 = i__ + i__ * a_dim1;
- q__2.r = temp1.r * a[i__4].r - temp1.i * a[i__4].i,
- q__2.i = temp1.r * a[i__4].i + temp1.i * a[
- i__4].r;
- q__3.r = alpha->r * temp2.r - alpha->i * temp2.i,
- q__3.i = alpha->r * temp2.i + alpha->i *
- temp2.r;
- q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
- c__[i__3].r = q__1.r, c__[i__3].i = q__1.i;
- } else {
- i__3 = i__ + j * c_dim1;
- i__4 = i__ + j * c_dim1;
- q__3.r = beta->r * c__[i__4].r - beta->i * c__[i__4]
- .i, q__3.i = beta->r * c__[i__4].i + beta->i *
- c__[i__4].r;
- i__5 = i__ + i__ * a_dim1;
- q__4.r = temp1.r * a[i__5].r - temp1.i * a[i__5].i,
- q__4.i = temp1.r * a[i__5].i + temp1.i * a[
- i__5].r;
- q__2.r = q__3.r + q__4.r, q__2.i = q__3.i + q__4.i;
- q__5.r = alpha->r * temp2.r - alpha->i * temp2.i,
- q__5.i = alpha->r * temp2.i + alpha->i *
- temp2.r;
- q__1.r = q__2.r + q__5.r, q__1.i = q__2.i + q__5.i;
- c__[i__3].r = q__1.r, c__[i__3].i = q__1.i;
- }
-/* L60: */
- }
-/* L70: */
- }
- } else {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- for (i__ = *m; i__ >= 1; --i__) {
- i__2 = i__ + j * b_dim1;
- q__1.r = alpha->r * b[i__2].r - alpha->i * b[i__2].i,
- q__1.i = alpha->r * b[i__2].i + alpha->i * b[i__2]
- .r;
- temp1.r = q__1.r, temp1.i = q__1.i;
- temp2.r = 0.f, temp2.i = 0.f;
- i__2 = *m;
- for (k = i__ + 1; k <= i__2; ++k) {
- i__3 = k + j * c_dim1;
- i__4 = k + j * c_dim1;
- i__5 = k + i__ * a_dim1;
- q__2.r = temp1.r * a[i__5].r - temp1.i * a[i__5].i,
- q__2.i = temp1.r * a[i__5].i + temp1.i * a[
- i__5].r;
- q__1.r = c__[i__4].r + q__2.r, q__1.i = c__[i__4].i +
- q__2.i;
- c__[i__3].r = q__1.r, c__[i__3].i = q__1.i;
- i__3 = k + j * b_dim1;
- i__4 = k + i__ * a_dim1;
- q__2.r = b[i__3].r * a[i__4].r - b[i__3].i * a[i__4]
- .i, q__2.i = b[i__3].r * a[i__4].i + b[i__3]
- .i * a[i__4].r;
- q__1.r = temp2.r + q__2.r, q__1.i = temp2.i + q__2.i;
- temp2.r = q__1.r, temp2.i = q__1.i;
-/* L80: */
- }
- if (beta->r == 0.f && beta->i == 0.f) {
- i__2 = i__ + j * c_dim1;
- i__3 = i__ + i__ * a_dim1;
- q__2.r = temp1.r * a[i__3].r - temp1.i * a[i__3].i,
- q__2.i = temp1.r * a[i__3].i + temp1.i * a[
- i__3].r;
- q__3.r = alpha->r * temp2.r - alpha->i * temp2.i,
- q__3.i = alpha->r * temp2.i + alpha->i *
- temp2.r;
- q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
- c__[i__2].r = q__1.r, c__[i__2].i = q__1.i;
- } else {
- i__2 = i__ + j * c_dim1;
- i__3 = i__ + j * c_dim1;
- q__3.r = beta->r * c__[i__3].r - beta->i * c__[i__3]
- .i, q__3.i = beta->r * c__[i__3].i + beta->i *
- c__[i__3].r;
- i__4 = i__ + i__ * a_dim1;
- q__4.r = temp1.r * a[i__4].r - temp1.i * a[i__4].i,
- q__4.i = temp1.r * a[i__4].i + temp1.i * a[
- i__4].r;
- q__2.r = q__3.r + q__4.r, q__2.i = q__3.i + q__4.i;
- q__5.r = alpha->r * temp2.r - alpha->i * temp2.i,
- q__5.i = alpha->r * temp2.i + alpha->i *
- temp2.r;
- q__1.r = q__2.r + q__5.r, q__1.i = q__2.i + q__5.i;
- c__[i__2].r = q__1.r, c__[i__2].i = q__1.i;
- }
-/* L90: */
- }
-/* L100: */
- }
- }
- } else {
-
-/* Form C := alpha*B*A + beta*C. */
-
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- i__2 = j + j * a_dim1;
- q__1.r = alpha->r * a[i__2].r - alpha->i * a[i__2].i, q__1.i =
- alpha->r * a[i__2].i + alpha->i * a[i__2].r;
- temp1.r = q__1.r, temp1.i = q__1.i;
- if (beta->r == 0.f && beta->i == 0.f) {
- i__2 = *m;
- for (i__ = 1; i__ <= i__2; ++i__) {
- i__3 = i__ + j * c_dim1;
- i__4 = i__ + j * b_dim1;
- q__1.r = temp1.r * b[i__4].r - temp1.i * b[i__4].i,
- q__1.i = temp1.r * b[i__4].i + temp1.i * b[i__4]
- .r;
- c__[i__3].r = q__1.r, c__[i__3].i = q__1.i;
-/* L110: */
- }
- } else {
- i__2 = *m;
- for (i__ = 1; i__ <= i__2; ++i__) {
- i__3 = i__ + j * c_dim1;
- i__4 = i__ + j * c_dim1;
- q__2.r = beta->r * c__[i__4].r - beta->i * c__[i__4].i,
- q__2.i = beta->r * c__[i__4].i + beta->i * c__[
- i__4].r;
- i__5 = i__ + j * b_dim1;
- q__3.r = temp1.r * b[i__5].r - temp1.i * b[i__5].i,
- q__3.i = temp1.r * b[i__5].i + temp1.i * b[i__5]
- .r;
- q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
- c__[i__3].r = q__1.r, c__[i__3].i = q__1.i;
-/* L120: */
- }
- }
- i__2 = j - 1;
- for (k = 1; k <= i__2; ++k) {
- if (upper) {
- i__3 = k + j * a_dim1;
- q__1.r = alpha->r * a[i__3].r - alpha->i * a[i__3].i,
- q__1.i = alpha->r * a[i__3].i + alpha->i * a[i__3]
- .r;
- temp1.r = q__1.r, temp1.i = q__1.i;
- } else {
- i__3 = j + k * a_dim1;
- q__1.r = alpha->r * a[i__3].r - alpha->i * a[i__3].i,
- q__1.i = alpha->r * a[i__3].i + alpha->i * a[i__3]
- .r;
- temp1.r = q__1.r, temp1.i = q__1.i;
- }
- i__3 = *m;
- for (i__ = 1; i__ <= i__3; ++i__) {
- i__4 = i__ + j * c_dim1;
- i__5 = i__ + j * c_dim1;
- i__6 = i__ + k * b_dim1;
- q__2.r = temp1.r * b[i__6].r - temp1.i * b[i__6].i,
- q__2.i = temp1.r * b[i__6].i + temp1.i * b[i__6]
- .r;
- q__1.r = c__[i__5].r + q__2.r, q__1.i = c__[i__5].i +
- q__2.i;
- c__[i__4].r = q__1.r, c__[i__4].i = q__1.i;
-/* L130: */
- }
-/* L140: */
- }
- i__2 = *n;
- for (k = j + 1; k <= i__2; ++k) {
- if (upper) {
- i__3 = j + k * a_dim1;
- q__1.r = alpha->r * a[i__3].r - alpha->i * a[i__3].i,
- q__1.i = alpha->r * a[i__3].i + alpha->i * a[i__3]
- .r;
- temp1.r = q__1.r, temp1.i = q__1.i;
- } else {
- i__3 = k + j * a_dim1;
- q__1.r = alpha->r * a[i__3].r - alpha->i * a[i__3].i,
- q__1.i = alpha->r * a[i__3].i + alpha->i * a[i__3]
- .r;
- temp1.r = q__1.r, temp1.i = q__1.i;
- }
- i__3 = *m;
- for (i__ = 1; i__ <= i__3; ++i__) {
- i__4 = i__ + j * c_dim1;
- i__5 = i__ + j * c_dim1;
- i__6 = i__ + k * b_dim1;
- q__2.r = temp1.r * b[i__6].r - temp1.i * b[i__6].i,
- q__2.i = temp1.r * b[i__6].i + temp1.i * b[i__6]
- .r;
- q__1.r = c__[i__5].r + q__2.r, q__1.i = c__[i__5].i +
- q__2.i;
- c__[i__4].r = q__1.r, c__[i__4].i = q__1.i;
-/* L150: */
- }
-/* L160: */
- }
-/* L170: */
- }
- }
-
- return 0;
-
-/* End of CSYMM . */
-
-} /* csymm_ */
-
-/* Subroutine */ int csyr2k_(char *uplo, char *trans, integer *n, integer *k,
- complex *alpha, complex *a, integer *lda, complex *b, integer *ldb,
- complex *beta, complex *c__, integer *ldc, ftnlen uplo_len, ftnlen
- trans_len)
-{
- /* System generated locals */
- integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2,
- i__3, i__4, i__5, i__6, i__7;
- complex q__1, q__2, q__3, q__4, q__5;
-
- /* Local variables */
- static integer i__, j, l, info;
- static complex temp1, temp2;
- extern logical lsame_(char *, char *, ftnlen, ftnlen);
- static integer nrowa;
- static logical upper;
- extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen);
-
-/* .. Scalar Arguments .. */
-/* .. Array Arguments .. */
-/* .. */
-
-/* Purpose */
-/* ======= */
-
-/* CSYR2K performs one of the symmetric rank 2k operations */
-
-/* C := alpha*A*B' + alpha*B*A' + beta*C, */
-
-/* or */
-
-/* C := alpha*A'*B + alpha*B'*A + beta*C, */
-
-/* where alpha and beta are scalars, C is an n by n symmetric matrix */
-/* and A and B are n by k matrices in the first case and k by n */
-/* matrices in the second case. */
-
-/* Parameters */
-/* ========== */
-
-/* UPLO - CHARACTER*1. */
-/* On entry, UPLO specifies whether the upper or lower */
-/* triangular part of the array C is to be referenced as */
-/* follows: */
-
-/* UPLO = 'U' or 'u' Only the upper triangular part of C */
-/* is to be referenced. */
-
-/* UPLO = 'L' or 'l' Only the lower triangular part of C */
-/* is to be referenced. */
-
-/* Unchanged on exit. */
-
-/* TRANS - CHARACTER*1. */
-/* On entry, TRANS specifies the operation to be performed as */
-/* follows: */
-
-/* TRANS = 'N' or 'n' C := alpha*A*B' + alpha*B*A' + */
-/* beta*C. */
-
-/* TRANS = 'T' or 't' C := alpha*A'*B + alpha*B'*A + */
-/* beta*C. */
-
-/* Unchanged on exit. */
-
-/* N - INTEGER. */
-/* On entry, N specifies the order of the matrix C. N must be */
-/* at least zero. */
-/* Unchanged on exit. */
-
-/* K - INTEGER. */
-/* On entry with TRANS = 'N' or 'n', K specifies the number */
-/* of columns of the matrices A and B, and on entry with */
-/* TRANS = 'T' or 't', K specifies the number of rows of the */
-/* matrices A and B. K must be at least zero. */
-/* Unchanged on exit. */
-
-/* ALPHA - COMPLEX . */
-/* On entry, ALPHA specifies the scalar alpha. */
-/* Unchanged on exit. */
-
-/* A - COMPLEX array of DIMENSION ( LDA, ka ), where ka is */
-/* k when TRANS = 'N' or 'n', and is n otherwise. */
-/* Before entry with TRANS = 'N' or 'n', the leading n by k */
-/* part of the array A must contain the matrix A, otherwise */
-/* the leading k by n part of the array A must contain the */
-/* matrix A. */
-/* Unchanged on exit. */
-
-/* LDA - INTEGER. */
-/* On entry, LDA specifies the first dimension of A as declared */
-/* in the calling (sub) program. When TRANS = 'N' or 'n' */
-/* then LDA must be at least max( 1, n ), otherwise LDA must */
-/* be at least max( 1, k ). */
-/* Unchanged on exit. */
-
-/* B - COMPLEX array of DIMENSION ( LDB, kb ), where kb is */
-/* k when TRANS = 'N' or 'n', and is n otherwise. */
-/* Before entry with TRANS = 'N' or 'n', the leading n by k */
-/* part of the array B must contain the matrix B, otherwise */
-/* the leading k by n part of the array B must contain the */
-/* matrix B. */
-/* Unchanged on exit. */
-
-/* LDB - INTEGER. */
-/* On entry, LDB specifies the first dimension of B as declared */
-/* in the calling (sub) program. When TRANS = 'N' or 'n' */
-/* then LDB must be at least max( 1, n ), otherwise LDB must */
-/* be at least max( 1, k ). */
-/* Unchanged on exit. */
-
-/* BETA - COMPLEX . */
-/* On entry, BETA specifies the scalar beta. */
-/* Unchanged on exit. */
-
-/* C - COMPLEX array of DIMENSION ( LDC, n ). */
-/* Before entry with UPLO = 'U' or 'u', the leading n by n */
-/* upper triangular part of the array C must contain the upper */
-/* triangular part of the symmetric matrix and the strictly */
-/* lower triangular part of C is not referenced. On exit, the */
-/* upper triangular part of the array C is overwritten by the */
-/* upper triangular part of the updated matrix. */
-/* Before entry with UPLO = 'L' or 'l', the leading n by n */
-/* lower triangular part of the array C must contain the lower */
-/* triangular part of the symmetric matrix and the strictly */
-/* upper triangular part of C is not referenced. On exit, the */
-/* lower triangular part of the array C is overwritten by the */
-/* lower triangular part of the updated matrix. */
-
-/* LDC - INTEGER. */
-/* On entry, LDC specifies the first dimension of C as declared */
-/* in the calling (sub) program. LDC must be at least */
-/* max( 1, n ). */
-/* Unchanged on exit. */
-
-
-/* Level 3 Blas routine. */
-
-/* -- Written on 8-February-1989. */
-/* Jack Dongarra, Argonne National Laboratory. */
-/* Iain Duff, AERE Harwell. */
-/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */
-/* Sven Hammarling, Numerical Algorithms Group Ltd. */
-
-
-/* .. External Functions .. */
-/* .. External Subroutines .. */
-/* .. Intrinsic Functions .. */
-/* .. Local Scalars .. */
-/* .. Parameters .. */
-/* .. */
-/* .. Executable Statements .. */
-
-/* Test the input parameters. */
-
- /* Parameter adjustments */
- a_dim1 = *lda;
- a_offset = 1 + a_dim1 * 1;
- a -= a_offset;
- b_dim1 = *ldb;
- b_offset = 1 + b_dim1 * 1;
- b -= b_offset;
- c_dim1 = *ldc;
- c_offset = 1 + c_dim1 * 1;
- c__ -= c_offset;
-
- /* Function Body */
- if (lsame_(trans, "N", (ftnlen)1, (ftnlen)1)) {
- nrowa = *n;
- } else {
- nrowa = *k;
- }
- upper = lsame_(uplo, "U", (ftnlen)1, (ftnlen)1);
-
- info = 0;
- if (! upper && ! lsame_(uplo, "L", (ftnlen)1, (ftnlen)1)) {
- info = 1;
- } else if (! lsame_(trans, "N", (ftnlen)1, (ftnlen)1) && ! lsame_(trans,
- "T", (ftnlen)1, (ftnlen)1)) {
- info = 2;
- } else if (*n < 0) {
- info = 3;
- } else if (*k < 0) {
- info = 4;
- } else if (*lda < max(1,nrowa)) {
- info = 7;
- } else if (*ldb < max(1,nrowa)) {
- info = 9;
- } else if (*ldc < max(1,*n)) {
- info = 12;
- }
- if (info != 0) {
- xerbla_("CSYR2K", &info, (ftnlen)6);
- return 0;
- }
-
-/* Quick return if possible. */
-
- if (*n == 0 || (alpha->r == 0.f && alpha->i == 0.f || *k == 0) && (
- beta->r == 1.f && beta->i == 0.f)) {
- return 0;
- }
-
-/* And when alpha.eq.zero. */
-
- if (alpha->r == 0.f && alpha->i == 0.f) {
- if (upper) {
- if (beta->r == 0.f && beta->i == 0.f) {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- i__2 = j;
- for (i__ = 1; i__ <= i__2; ++i__) {
- i__3 = i__ + j * c_dim1;
- c__[i__3].r = 0.f, c__[i__3].i = 0.f;
-/* L10: */
- }
-/* L20: */
- }
- } else {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- i__2 = j;
- for (i__ = 1; i__ <= i__2; ++i__) {
- i__3 = i__ + j * c_dim1;
- i__4 = i__ + j * c_dim1;
- q__1.r = beta->r * c__[i__4].r - beta->i * c__[i__4]
- .i, q__1.i = beta->r * c__[i__4].i + beta->i *
- c__[i__4].r;
- c__[i__3].r = q__1.r, c__[i__3].i = q__1.i;
-/* L30: */
- }
-/* L40: */
- }
- }
- } else {
- if (beta->r == 0.f && beta->i == 0.f) {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- i__2 = *n;
- for (i__ = j; i__ <= i__2; ++i__) {
- i__3 = i__ + j * c_dim1;
- c__[i__3].r = 0.f, c__[i__3].i = 0.f;
-/* L50: */
- }
-/* L60: */
- }
- } else {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- i__2 = *n;
- for (i__ = j; i__ <= i__2; ++i__) {
- i__3 = i__ + j * c_dim1;
- i__4 = i__ + j * c_dim1;
- q__1.r = beta->r * c__[i__4].r - beta->i * c__[i__4]
- .i, q__1.i = beta->r * c__[i__4].i + beta->i *
- c__[i__4].r;
- c__[i__3].r = q__1.r, c__[i__3].i = q__1.i;
-/* L70: */
- }
-/* L80: */
- }
- }
- }
- return 0;
- }
-
-/* Start the operations. */
-
- if (lsame_(trans, "N", (ftnlen)1, (ftnlen)1)) {
-
-/* Form C := alpha*A*B' + alpha*B*A' + C. */
-
- if (upper) {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- if (beta->r == 0.f && beta->i == 0.f) {
- i__2 = j;
- for (i__ = 1; i__ <= i__2; ++i__) {
- i__3 = i__ + j * c_dim1;
- c__[i__3].r = 0.f, c__[i__3].i = 0.f;
-/* L90: */
- }
- } else if (beta->r != 1.f || beta->i != 0.f) {
- i__2 = j;
- for (i__ = 1; i__ <= i__2; ++i__) {
- i__3 = i__ + j * c_dim1;
- i__4 = i__ + j * c_dim1;
- q__1.r = beta->r * c__[i__4].r - beta->i * c__[i__4]
- .i, q__1.i = beta->r * c__[i__4].i + beta->i *
- c__[i__4].r;
- c__[i__3].r = q__1.r, c__[i__3].i = q__1.i;
-/* L100: */
- }
- }
- i__2 = *k;
- for (l = 1; l <= i__2; ++l) {
- i__3 = j + l * a_dim1;
- i__4 = j + l * b_dim1;
- if (a[i__3].r != 0.f || a[i__3].i != 0.f || (b[i__4].r !=
- 0.f || b[i__4].i != 0.f)) {
- i__3 = j + l * b_dim1;
- q__1.r = alpha->r * b[i__3].r - alpha->i * b[i__3].i,
- q__1.i = alpha->r * b[i__3].i + alpha->i * b[
- i__3].r;
- temp1.r = q__1.r, temp1.i = q__1.i;
- i__3 = j + l * a_dim1;
- q__1.r = alpha->r * a[i__3].r - alpha->i * a[i__3].i,
- q__1.i = alpha->r * a[i__3].i + alpha->i * a[
- i__3].r;
- temp2.r = q__1.r, temp2.i = q__1.i;
- i__3 = j;
- for (i__ = 1; i__ <= i__3; ++i__) {
- i__4 = i__ + j * c_dim1;
- i__5 = i__ + j * c_dim1;
- i__6 = i__ + l * a_dim1;
- q__3.r = a[i__6].r * temp1.r - a[i__6].i *
- temp1.i, q__3.i = a[i__6].r * temp1.i + a[
- i__6].i * temp1.r;
- q__2.r = c__[i__5].r + q__3.r, q__2.i = c__[i__5]
- .i + q__3.i;
- i__7 = i__ + l * b_dim1;
- q__4.r = b[i__7].r * temp2.r - b[i__7].i *
- temp2.i, q__4.i = b[i__7].r * temp2.i + b[
- i__7].i * temp2.r;
- q__1.r = q__2.r + q__4.r, q__1.i = q__2.i +
- q__4.i;
- c__[i__4].r = q__1.r, c__[i__4].i = q__1.i;
-/* L110: */
- }
- }
-/* L120: */
- }
-/* L130: */
- }
- } else {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- if (beta->r == 0.f && beta->i == 0.f) {
- i__2 = *n;
- for (i__ = j; i__ <= i__2; ++i__) {
- i__3 = i__ + j * c_dim1;
- c__[i__3].r = 0.f, c__[i__3].i = 0.f;
-/* L140: */
- }
- } else if (beta->r != 1.f || beta->i != 0.f) {
- i__2 = *n;
- for (i__ = j; i__ <= i__2; ++i__) {
- i__3 = i__ + j * c_dim1;
- i__4 = i__ + j * c_dim1;
- q__1.r = beta->r * c__[i__4].r - beta->i * c__[i__4]
- .i, q__1.i = beta->r * c__[i__4].i + beta->i *
- c__[i__4].r;
- c__[i__3].r = q__1.r, c__[i__3].i = q__1.i;
-/* L150: */
- }
- }
- i__2 = *k;
- for (l = 1; l <= i__2; ++l) {
- i__3 = j + l * a_dim1;
- i__4 = j + l * b_dim1;
- if (a[i__3].r != 0.f || a[i__3].i != 0.f || (b[i__4].r !=
- 0.f || b[i__4].i != 0.f)) {
- i__3 = j + l * b_dim1;
- q__1.r = alpha->r * b[i__3].r - alpha->i * b[i__3].i,
- q__1.i = alpha->r * b[i__3].i + alpha->i * b[
- i__3].r;
- temp1.r = q__1.r, temp1.i = q__1.i;
- i__3 = j + l * a_dim1;
- q__1.r = alpha->r * a[i__3].r - alpha->i * a[i__3].i,
- q__1.i = alpha->r * a[i__3].i + alpha->i * a[
- i__3].r;
- temp2.r = q__1.r, temp2.i = q__1.i;
- i__3 = *n;
- for (i__ = j; i__ <= i__3; ++i__) {
- i__4 = i__ + j * c_dim1;
- i__5 = i__ + j * c_dim1;
- i__6 = i__ + l * a_dim1;
- q__3.r = a[i__6].r * temp1.r - a[i__6].i *
- temp1.i, q__3.i = a[i__6].r * temp1.i + a[
- i__6].i * temp1.r;
- q__2.r = c__[i__5].r + q__3.r, q__2.i = c__[i__5]
- .i + q__3.i;
- i__7 = i__ + l * b_dim1;
- q__4.r = b[i__7].r * temp2.r - b[i__7].i *
- temp2.i, q__4.i = b[i__7].r * temp2.i + b[
- i__7].i * temp2.r;
- q__1.r = q__2.r + q__4.r, q__1.i = q__2.i +
- q__4.i;
- c__[i__4].r = q__1.r, c__[i__4].i = q__1.i;
-/* L160: */
- }
- }
-/* L170: */
- }
-/* L180: */
- }
- }
- } else {
-
-/* Form C := alpha*A'*B + alpha*B'*A + C. */
-
- if (upper) {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- i__2 = j;
- for (i__ = 1; i__ <= i__2; ++i__) {
- temp1.r = 0.f, temp1.i = 0.f;
- temp2.r = 0.f, temp2.i = 0.f;
- i__3 = *k;
- for (l = 1; l <= i__3; ++l) {
- i__4 = l + i__ * a_dim1;
- i__5 = l + j * b_dim1;
- q__2.r = a[i__4].r * b[i__5].r - a[i__4].i * b[i__5]
- .i, q__2.i = a[i__4].r * b[i__5].i + a[i__4]
- .i * b[i__5].r;
- q__1.r = temp1.r + q__2.r, q__1.i = temp1.i + q__2.i;
- temp1.r = q__1.r, temp1.i = q__1.i;
- i__4 = l + i__ * b_dim1;
- i__5 = l + j * a_dim1;
- q__2.r = b[i__4].r * a[i__5].r - b[i__4].i * a[i__5]
- .i, q__2.i = b[i__4].r * a[i__5].i + b[i__4]
- .i * a[i__5].r;
- q__1.r = temp2.r + q__2.r, q__1.i = temp2.i + q__2.i;
- temp2.r = q__1.r, temp2.i = q__1.i;
-/* L190: */
- }
- if (beta->r == 0.f && beta->i == 0.f) {
- i__3 = i__ + j * c_dim1;
- q__2.r = alpha->r * temp1.r - alpha->i * temp1.i,
- q__2.i = alpha->r * temp1.i + alpha->i *
- temp1.r;
- q__3.r = alpha->r * temp2.r - alpha->i * temp2.i,
- q__3.i = alpha->r * temp2.i + alpha->i *
- temp2.r;
- q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
- c__[i__3].r = q__1.r, c__[i__3].i = q__1.i;
- } else {
- i__3 = i__ + j * c_dim1;
- i__4 = i__ + j * c_dim1;
- q__3.r = beta->r * c__[i__4].r - beta->i * c__[i__4]
- .i, q__3.i = beta->r * c__[i__4].i + beta->i *
- c__[i__4].r;
- q__4.r = alpha->r * temp1.r - alpha->i * temp1.i,
- q__4.i = alpha->r * temp1.i + alpha->i *
- temp1.r;
- q__2.r = q__3.r + q__4.r, q__2.i = q__3.i + q__4.i;
- q__5.r = alpha->r * temp2.r - alpha->i * temp2.i,
- q__5.i = alpha->r * temp2.i + alpha->i *
- temp2.r;
- q__1.r = q__2.r + q__5.r, q__1.i = q__2.i + q__5.i;
- c__[i__3].r = q__1.r, c__[i__3].i = q__1.i;
- }
-/* L200: */
- }
-/* L210: */
- }
- } else {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- i__2 = *n;
- for (i__ = j; i__ <= i__2; ++i__) {
- temp1.r = 0.f, temp1.i = 0.f;
- temp2.r = 0.f, temp2.i = 0.f;
- i__3 = *k;
- for (l = 1; l <= i__3; ++l) {
- i__4 = l + i__ * a_dim1;
- i__5 = l + j * b_dim1;
- q__2.r = a[i__4].r * b[i__5].r - a[i__4].i * b[i__5]
- .i, q__2.i = a[i__4].r * b[i__5].i + a[i__4]
- .i * b[i__5].r;
- q__1.r = temp1.r + q__2.r, q__1.i = temp1.i + q__2.i;
- temp1.r = q__1.r, temp1.i = q__1.i;
- i__4 = l + i__ * b_dim1;
- i__5 = l + j * a_dim1;
- q__2.r = b[i__4].r * a[i__5].r - b[i__4].i * a[i__5]
- .i, q__2.i = b[i__4].r * a[i__5].i + b[i__4]
- .i * a[i__5].r;
- q__1.r = temp2.r + q__2.r, q__1.i = temp2.i + q__2.i;
- temp2.r = q__1.r, temp2.i = q__1.i;
-/* L220: */
- }
- if (beta->r == 0.f && beta->i == 0.f) {
- i__3 = i__ + j * c_dim1;
- q__2.r = alpha->r * temp1.r - alpha->i * temp1.i,
- q__2.i = alpha->r * temp1.i + alpha->i *
- temp1.r;
- q__3.r = alpha->r * temp2.r - alpha->i * temp2.i,
- q__3.i = alpha->r * temp2.i + alpha->i *
- temp2.r;
- q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
- c__[i__3].r = q__1.r, c__[i__3].i = q__1.i;
- } else {
- i__3 = i__ + j * c_dim1;
- i__4 = i__ + j * c_dim1;
- q__3.r = beta->r * c__[i__4].r - beta->i * c__[i__4]
- .i, q__3.i = beta->r * c__[i__4].i + beta->i *
- c__[i__4].r;
- q__4.r = alpha->r * temp1.r - alpha->i * temp1.i,
- q__4.i = alpha->r * temp1.i + alpha->i *
- temp1.r;
- q__2.r = q__3.r + q__4.r, q__2.i = q__3.i + q__4.i;
- q__5.r = alpha->r * temp2.r - alpha->i * temp2.i,
- q__5.i = alpha->r * temp2.i + alpha->i *
- temp2.r;
- q__1.r = q__2.r + q__5.r, q__1.i = q__2.i + q__5.i;
- c__[i__3].r = q__1.r, c__[i__3].i = q__1.i;
- }
-/* L230: */
- }
-/* L240: */
- }
- }
- }
-
- return 0;
-
-/* End of CSYR2K. */
-
-} /* csyr2k_ */
-
-/* Subroutine */ int csyrk_(char *uplo, char *trans, integer *n, integer *k,
- complex *alpha, complex *a, integer *lda, complex *beta, complex *c__,
- integer *ldc, ftnlen uplo_len, ftnlen trans_len)
-{
- /* System generated locals */
- integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2, i__3, i__4, i__5,
- i__6;
- complex q__1, q__2, q__3;
-
- /* Local variables */
- static integer i__, j, l, info;
- static complex temp;
- extern logical lsame_(char *, char *, ftnlen, ftnlen);
- static integer nrowa;
- static logical upper;
- extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen);
-
-/* .. Scalar Arguments .. */
-/* .. Array Arguments .. */
-/* .. */
-
-/* Purpose */
-/* ======= */
-
-/* CSYRK performs one of the symmetric rank k operations */
-
-/* C := alpha*A*A' + beta*C, */
-
-/* or */
-
-/* C := alpha*A'*A + beta*C, */
-
-/* where alpha and beta are scalars, C is an n by n symmetric matrix */
-/* and A is an n by k matrix in the first case and a k by n matrix */
-/* in the second case. */
-
-/* Parameters */
-/* ========== */
-
-/* UPLO - CHARACTER*1. */
-/* On entry, UPLO specifies whether the upper or lower */
-/* triangular part of the array C is to be referenced as */
-/* follows: */
-
-/* UPLO = 'U' or 'u' Only the upper triangular part of C */
-/* is to be referenced. */
-
-/* UPLO = 'L' or 'l' Only the lower triangular part of C */
-/* is to be referenced. */
-
-/* Unchanged on exit. */
-
-/* TRANS - CHARACTER*1. */
-/* On entry, TRANS specifies the operation to be performed as */
-/* follows: */
-
-/* TRANS = 'N' or 'n' C := alpha*A*A' + beta*C. */
-
-/* TRANS = 'T' or 't' C := alpha*A'*A + beta*C. */
-
-/* Unchanged on exit. */
-
-/* N - INTEGER. */
-/* On entry, N specifies the order of the matrix C. N must be */
-/* at least zero. */
-/* Unchanged on exit. */
-
-/* K - INTEGER. */
-/* On entry with TRANS = 'N' or 'n', K specifies the number */
-/* of columns of the matrix A, and on entry with */
-/* TRANS = 'T' or 't', K specifies the number of rows of the */
-/* matrix A. K must be at least zero. */
-/* Unchanged on exit. */
-
-/* ALPHA - COMPLEX . */
-/* On entry, ALPHA specifies the scalar alpha. */
-/* Unchanged on exit. */
-
-/* A - COMPLEX array of DIMENSION ( LDA, ka ), where ka is */
-/* k when TRANS = 'N' or 'n', and is n otherwise. */
-/* Before entry with TRANS = 'N' or 'n', the leading n by k */
-/* part of the array A must contain the matrix A, otherwise */
-/* the leading k by n part of the array A must contain the */
-/* matrix A. */
-/* Unchanged on exit. */
-
-/* LDA - INTEGER. */
-/* On entry, LDA specifies the first dimension of A as declared */
-/* in the calling (sub) program. When TRANS = 'N' or 'n' */
-/* then LDA must be at least max( 1, n ), otherwise LDA must */
-/* be at least max( 1, k ). */
-/* Unchanged on exit. */
-
-/* BETA - COMPLEX . */
-/* On entry, BETA specifies the scalar beta. */
-/* Unchanged on exit. */
-
-/* C - COMPLEX array of DIMENSION ( LDC, n ). */
-/* Before entry with UPLO = 'U' or 'u', the leading n by n */
-/* upper triangular part of the array C must contain the upper */
-/* triangular part of the symmetric matrix and the strictly */
-/* lower triangular part of C is not referenced. On exit, the */
-/* upper triangular part of the array C is overwritten by the */
-/* upper triangular part of the updated matrix. */
-/* Before entry with UPLO = 'L' or 'l', the leading n by n */
-/* lower triangular part of the array C must contain the lower */
-/* triangular part of the symmetric matrix and the strictly */
-/* upper triangular part of C is not referenced. On exit, the */
-/* lower triangular part of the array C is overwritten by the */
-/* lower triangular part of the updated matrix. */
-
-/* LDC - INTEGER. */
-/* On entry, LDC specifies the first dimension of C as declared */
-/* in the calling (sub) program. LDC must be at least */
-/* max( 1, n ). */
-/* Unchanged on exit. */
-
-
-/* Level 3 Blas routine. */
-
-/* -- Written on 8-February-1989. */
-/* Jack Dongarra, Argonne National Laboratory. */
-/* Iain Duff, AERE Harwell. */
-/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */
-/* Sven Hammarling, Numerical Algorithms Group Ltd. */
-
-
-/* .. External Functions .. */
-/* .. External Subroutines .. */
-/* .. Intrinsic Functions .. */
-/* .. Local Scalars .. */
-/* .. Parameters .. */
-/* .. */
-/* .. Executable Statements .. */
-
-/* Test the input parameters. */
-
- /* Parameter adjustments */
- a_dim1 = *lda;
- a_offset = 1 + a_dim1 * 1;
- a -= a_offset;
- c_dim1 = *ldc;
- c_offset = 1 + c_dim1 * 1;
- c__ -= c_offset;
-
- /* Function Body */
- if (lsame_(trans, "N", (ftnlen)1, (ftnlen)1)) {
- nrowa = *n;
- } else {
- nrowa = *k;
- }
- upper = lsame_(uplo, "U", (ftnlen)1, (ftnlen)1);
-
- info = 0;
- if (! upper && ! lsame_(uplo, "L", (ftnlen)1, (ftnlen)1)) {
- info = 1;
- } else if (! lsame_(trans, "N", (ftnlen)1, (ftnlen)1) && ! lsame_(trans,
- "T", (ftnlen)1, (ftnlen)1)) {
- info = 2;
- } else if (*n < 0) {
- info = 3;
- } else if (*k < 0) {
- info = 4;
- } else if (*lda < max(1,nrowa)) {
- info = 7;
- } else if (*ldc < max(1,*n)) {
- info = 10;
- }
- if (info != 0) {
- xerbla_("CSYRK ", &info, (ftnlen)6);
- return 0;
- }
-
-/* Quick return if possible. */
-
- if (*n == 0 || (alpha->r == 0.f && alpha->i == 0.f || *k == 0) && (
- beta->r == 1.f && beta->i == 0.f)) {
- return 0;
- }
-
-/* And when alpha.eq.zero. */
-
- if (alpha->r == 0.f && alpha->i == 0.f) {
- if (upper) {
- if (beta->r == 0.f && beta->i == 0.f) {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- i__2 = j;
- for (i__ = 1; i__ <= i__2; ++i__) {
- i__3 = i__ + j * c_dim1;
- c__[i__3].r = 0.f, c__[i__3].i = 0.f;
-/* L10: */
- }
-/* L20: */
- }
- } else {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- i__2 = j;
- for (i__ = 1; i__ <= i__2; ++i__) {
- i__3 = i__ + j * c_dim1;
- i__4 = i__ + j * c_dim1;
- q__1.r = beta->r * c__[i__4].r - beta->i * c__[i__4]
- .i, q__1.i = beta->r * c__[i__4].i + beta->i *
- c__[i__4].r;
- c__[i__3].r = q__1.r, c__[i__3].i = q__1.i;
-/* L30: */
- }
-/* L40: */
- }
- }
- } else {
- if (beta->r == 0.f && beta->i == 0.f) {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- i__2 = *n;
- for (i__ = j; i__ <= i__2; ++i__) {
- i__3 = i__ + j * c_dim1;
- c__[i__3].r = 0.f, c__[i__3].i = 0.f;
-/* L50: */
- }
-/* L60: */
- }
- } else {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- i__2 = *n;
- for (i__ = j; i__ <= i__2; ++i__) {
- i__3 = i__ + j * c_dim1;
- i__4 = i__ + j * c_dim1;
- q__1.r = beta->r * c__[i__4].r - beta->i * c__[i__4]
- .i, q__1.i = beta->r * c__[i__4].i + beta->i *
- c__[i__4].r;
- c__[i__3].r = q__1.r, c__[i__3].i = q__1.i;
-/* L70: */
- }
-/* L80: */
- }
- }
- }
- return 0;
- }
-
-/* Start the operations. */
-
- if (lsame_(trans, "N", (ftnlen)1, (ftnlen)1)) {
-
-/* Form C := alpha*A*A' + beta*C. */
-
- if (upper) {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- if (beta->r == 0.f && beta->i == 0.f) {
- i__2 = j;
- for (i__ = 1; i__ <= i__2; ++i__) {
- i__3 = i__ + j * c_dim1;
- c__[i__3].r = 0.f, c__[i__3].i = 0.f;
-/* L90: */
- }
- } else if (beta->r != 1.f || beta->i != 0.f) {
- i__2 = j;
- for (i__ = 1; i__ <= i__2; ++i__) {
- i__3 = i__ + j * c_dim1;
- i__4 = i__ + j * c_dim1;
- q__1.r = beta->r * c__[i__4].r - beta->i * c__[i__4]
- .i, q__1.i = beta->r * c__[i__4].i + beta->i *
- c__[i__4].r;
- c__[i__3].r = q__1.r, c__[i__3].i = q__1.i;
-/* L100: */
- }
- }
- i__2 = *k;
- for (l = 1; l <= i__2; ++l) {
- i__3 = j + l * a_dim1;
- if (a[i__3].r != 0.f || a[i__3].i != 0.f) {
- i__3 = j + l * a_dim1;
- q__1.r = alpha->r * a[i__3].r - alpha->i * a[i__3].i,
- q__1.i = alpha->r * a[i__3].i + alpha->i * a[
- i__3].r;
- temp.r = q__1.r, temp.i = q__1.i;
- i__3 = j;
- for (i__ = 1; i__ <= i__3; ++i__) {
- i__4 = i__ + j * c_dim1;
- i__5 = i__ + j * c_dim1;
- i__6 = i__ + l * a_dim1;
- q__2.r = temp.r * a[i__6].r - temp.i * a[i__6].i,
- q__2.i = temp.r * a[i__6].i + temp.i * a[
- i__6].r;
- q__1.r = c__[i__5].r + q__2.r, q__1.i = c__[i__5]
- .i + q__2.i;
- c__[i__4].r = q__1.r, c__[i__4].i = q__1.i;
-/* L110: */
- }
- }
-/* L120: */
- }
-/* L130: */
- }
- } else {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- if (beta->r == 0.f && beta->i == 0.f) {
- i__2 = *n;
- for (i__ = j; i__ <= i__2; ++i__) {
- i__3 = i__ + j * c_dim1;
- c__[i__3].r = 0.f, c__[i__3].i = 0.f;
-/* L140: */
- }
- } else if (beta->r != 1.f || beta->i != 0.f) {
- i__2 = *n;
- for (i__ = j; i__ <= i__2; ++i__) {
- i__3 = i__ + j * c_dim1;
- i__4 = i__ + j * c_dim1;
- q__1.r = beta->r * c__[i__4].r - beta->i * c__[i__4]
- .i, q__1.i = beta->r * c__[i__4].i + beta->i *
- c__[i__4].r;
- c__[i__3].r = q__1.r, c__[i__3].i = q__1.i;
-/* L150: */
- }
- }
- i__2 = *k;
- for (l = 1; l <= i__2; ++l) {
- i__3 = j + l * a_dim1;
- if (a[i__3].r != 0.f || a[i__3].i != 0.f) {
- i__3 = j + l * a_dim1;
- q__1.r = alpha->r * a[i__3].r - alpha->i * a[i__3].i,
- q__1.i = alpha->r * a[i__3].i + alpha->i * a[
- i__3].r;
- temp.r = q__1.r, temp.i = q__1.i;
- i__3 = *n;
- for (i__ = j; i__ <= i__3; ++i__) {
- i__4 = i__ + j * c_dim1;
- i__5 = i__ + j * c_dim1;
- i__6 = i__ + l * a_dim1;
- q__2.r = temp.r * a[i__6].r - temp.i * a[i__6].i,
- q__2.i = temp.r * a[i__6].i + temp.i * a[
- i__6].r;
- q__1.r = c__[i__5].r + q__2.r, q__1.i = c__[i__5]
- .i + q__2.i;
- c__[i__4].r = q__1.r, c__[i__4].i = q__1.i;
-/* L160: */
- }
- }
-/* L170: */
- }
-/* L180: */
- }
- }
- } else {
-
-/* Form C := alpha*A'*A + beta*C. */
-
- if (upper) {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- i__2 = j;
- for (i__ = 1; i__ <= i__2; ++i__) {
- temp.r = 0.f, temp.i = 0.f;
- i__3 = *k;
- for (l = 1; l <= i__3; ++l) {
- i__4 = l + i__ * a_dim1;
- i__5 = l + j * a_dim1;
- q__2.r = a[i__4].r * a[i__5].r - a[i__4].i * a[i__5]
- .i, q__2.i = a[i__4].r * a[i__5].i + a[i__4]
- .i * a[i__5].r;
- q__1.r = temp.r + q__2.r, q__1.i = temp.i + q__2.i;
- temp.r = q__1.r, temp.i = q__1.i;
-/* L190: */
- }
- if (beta->r == 0.f && beta->i == 0.f) {
- i__3 = i__ + j * c_dim1;
- q__1.r = alpha->r * temp.r - alpha->i * temp.i,
- q__1.i = alpha->r * temp.i + alpha->i *
- temp.r;
- c__[i__3].r = q__1.r, c__[i__3].i = q__1.i;
- } else {
- i__3 = i__ + j * c_dim1;
- q__2.r = alpha->r * temp.r - alpha->i * temp.i,
- q__2.i = alpha->r * temp.i + alpha->i *
- temp.r;
- i__4 = i__ + j * c_dim1;
- q__3.r = beta->r * c__[i__4].r - beta->i * c__[i__4]
- .i, q__3.i = beta->r * c__[i__4].i + beta->i *
- c__[i__4].r;
- q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
- c__[i__3].r = q__1.r, c__[i__3].i = q__1.i;
- }
-/* L200: */
- }
-/* L210: */
- }
- } else {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- i__2 = *n;
- for (i__ = j; i__ <= i__2; ++i__) {
- temp.r = 0.f, temp.i = 0.f;
- i__3 = *k;
- for (l = 1; l <= i__3; ++l) {
- i__4 = l + i__ * a_dim1;
- i__5 = l + j * a_dim1;
- q__2.r = a[i__4].r * a[i__5].r - a[i__4].i * a[i__5]
- .i, q__2.i = a[i__4].r * a[i__5].i + a[i__4]
- .i * a[i__5].r;
- q__1.r = temp.r + q__2.r, q__1.i = temp.i + q__2.i;
- temp.r = q__1.r, temp.i = q__1.i;
-/* L220: */
- }
- if (beta->r == 0.f && beta->i == 0.f) {
- i__3 = i__ + j * c_dim1;
- q__1.r = alpha->r * temp.r - alpha->i * temp.i,
- q__1.i = alpha->r * temp.i + alpha->i *
- temp.r;
- c__[i__3].r = q__1.r, c__[i__3].i = q__1.i;
- } else {
- i__3 = i__ + j * c_dim1;
- q__2.r = alpha->r * temp.r - alpha->i * temp.i,
- q__2.i = alpha->r * temp.i + alpha->i *
- temp.r;
- i__4 = i__ + j * c_dim1;
- q__3.r = beta->r * c__[i__4].r - beta->i * c__[i__4]
- .i, q__3.i = beta->r * c__[i__4].i + beta->i *
- c__[i__4].r;
- q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
- c__[i__3].r = q__1.r, c__[i__3].i = q__1.i;
- }
-/* L230: */
- }
-/* L240: */
- }
- }
- }
-
- return 0;
-
-/* End of CSYRK . */
-
-} /* csyrk_ */
-
-/* Subroutine */ int ctbmv_(char *uplo, char *trans, char *diag, integer *n,
- integer *k, complex *a, integer *lda, complex *x, integer *incx,
- ftnlen uplo_len, ftnlen trans_len, ftnlen diag_len)
-{
- /* System generated locals */
- integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5;
- complex q__1, q__2, q__3;
-
- /* Builtin functions */
- void r_cnjg(complex *, complex *);
-
- /* Local variables */
- static integer i__, j, l, ix, jx, kx, info;
- static complex temp;
- extern logical lsame_(char *, char *, ftnlen, ftnlen);
- static integer kplus1;
- extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen);
- static logical noconj, nounit;
-
-/* .. Scalar Arguments .. */
-/* .. Array Arguments .. */
-/* .. */
-
-/* Purpose */
-/* ======= */
-
-/* CTBMV performs one of the matrix-vector operations */
-
-/* x := A*x, or x := A'*x, or x := conjg( A' )*x, */
-
-/* where x is an n element vector and A is an n by n unit, or non-unit, */
-/* upper or lower triangular band matrix, with ( k + 1 ) diagonals. */
-
-/* Parameters */
-/* ========== */
-
-/* UPLO - CHARACTER*1. */
-/* On entry, UPLO specifies whether the matrix is an upper or */
-/* lower triangular matrix as follows: */
-
-/* UPLO = 'U' or 'u' A is an upper triangular matrix. */
-
-/* UPLO = 'L' or 'l' A is a lower triangular matrix. */
-
-/* Unchanged on exit. */
-
-/* TRANS - CHARACTER*1. */
-/* On entry, TRANS specifies the operation to be performed as */
-/* follows: */
-
-/* TRANS = 'N' or 'n' x := A*x. */
-
-/* TRANS = 'T' or 't' x := A'*x. */
-
-/* TRANS = 'C' or 'c' x := conjg( A' )*x. */
-
-/* Unchanged on exit. */
-
-/* DIAG - CHARACTER*1. */
-/* On entry, DIAG specifies whether or not A is unit */
-/* triangular as follows: */
-
-/* DIAG = 'U' or 'u' A is assumed to be unit triangular. */
-
-/* DIAG = 'N' or 'n' A is not assumed to be unit */
-/* triangular. */
-
-/* Unchanged on exit. */
-
-/* N - INTEGER. */
-/* On entry, N specifies the order of the matrix A. */
-/* N must be at least zero. */
-/* Unchanged on exit. */
-
-/* K - INTEGER. */
-/* On entry with UPLO = 'U' or 'u', K specifies the number of */
-/* super-diagonals of the matrix A. */
-/* On entry with UPLO = 'L' or 'l', K specifies the number of */
-/* sub-diagonals of the matrix A. */
-/* K must satisfy 0 .le. K. */
-/* Unchanged on exit. */
-
-/* A - COMPLEX array of DIMENSION ( LDA, n ). */
-/* Before entry with UPLO = 'U' or 'u', the leading ( k + 1 ) */
-/* by n part of the array A must contain the upper triangular */
-/* band part of the matrix of coefficients, supplied column by */
-/* column, with the leading diagonal of the matrix in row */
-/* ( k + 1 ) of the array, the first super-diagonal starting at */
-/* position 2 in row k, and so on. The top left k by k triangle */
-/* of the array A is not referenced. */
-/* The following program segment will transfer an upper */
-/* triangular band matrix from conventional full matrix storage */
-/* to band storage: */
-
-/* DO 20, J = 1, N */
-/* M = K + 1 - J */
-/* DO 10, I = MAX( 1, J - K ), J */
-/* A( M + I, J ) = matrix( I, J ) */
-/* 10 CONTINUE */
-/* 20 CONTINUE */
-
-/* Before entry with UPLO = 'L' or 'l', the leading ( k + 1 ) */
-/* by n part of the array A must contain the lower triangular */
-/* band part of the matrix of coefficients, supplied column by */
-/* column, with the leading diagonal of the matrix in row 1 of */
-/* the array, the first sub-diagonal starting at position 1 in */
-/* row 2, and so on. The bottom right k by k triangle of the */
-/* array A is not referenced. */
-/* The following program segment will transfer a lower */
-/* triangular band matrix from conventional full matrix storage */
-/* to band storage: */
-
-/* DO 20, J = 1, N */
-/* M = 1 - J */
-/* DO 10, I = J, MIN( N, J + K ) */
-/* A( M + I, J ) = matrix( I, J ) */
-/* 10 CONTINUE */
-/* 20 CONTINUE */
-
-/* Note that when DIAG = 'U' or 'u' the elements of the array A */
-/* corresponding to the diagonal elements of the matrix are not */
-/* referenced, but are assumed to be unity. */
-/* Unchanged on exit. */
-
-/* LDA - INTEGER. */
-/* On entry, LDA specifies the first dimension of A as declared */
-/* in the calling (sub) program. LDA must be at least */
-/* ( k + 1 ). */
-/* Unchanged on exit. */
-
-/* X - COMPLEX array of dimension at least */
-/* ( 1 + ( n - 1 )*abs( INCX ) ). */
-/* Before entry, the incremented array X must contain the n */
-/* element vector x. On exit, X is overwritten with the */
-/* tranformed vector x. */
-
-/* INCX - INTEGER. */
-/* On entry, INCX specifies the increment for the elements of */
-/* X. INCX must not be zero. */
-/* Unchanged on exit. */
-
-
-/* Level 2 Blas routine. */
-
-/* -- Written on 22-October-1986. */
-/* Jack Dongarra, Argonne National Lab. */
-/* Jeremy Du Croz, Nag Central Office. */
-/* Sven Hammarling, Nag Central Office. */
-/* Richard Hanson, Sandia National Labs. */
-
-
-/* .. Parameters .. */
-/* .. Local Scalars .. */
-/* .. External Functions .. */
-/* .. External Subroutines .. */
-/* .. Intrinsic Functions .. */
-/* .. */
-/* .. Executable Statements .. */
-
-/* Test the input parameters. */
-
- /* Parameter adjustments */
- a_dim1 = *lda;
- a_offset = 1 + a_dim1 * 1;
- a -= a_offset;
- --x;
-
- /* Function Body */
- info = 0;
- if (! lsame_(uplo, "U", (ftnlen)1, (ftnlen)1) && ! lsame_(uplo, "L", (
- ftnlen)1, (ftnlen)1)) {
- info = 1;
- } else if (! lsame_(trans, "N", (ftnlen)1, (ftnlen)1) && ! lsame_(trans,
- "T", (ftnlen)1, (ftnlen)1) && ! lsame_(trans, "C", (ftnlen)1, (
- ftnlen)1)) {
- info = 2;
- } else if (! lsame_(diag, "U", (ftnlen)1, (ftnlen)1) && ! lsame_(diag,
- "N", (ftnlen)1, (ftnlen)1)) {
- info = 3;
- } else if (*n < 0) {
- info = 4;
- } else if (*k < 0) {
- info = 5;
- } else if (*lda < *k + 1) {
- info = 7;
- } else if (*incx == 0) {
- info = 9;
- }
- if (info != 0) {
- xerbla_("CTBMV ", &info, (ftnlen)6);
- return 0;
- }
-
-/* Quick return if possible. */
-
- if (*n == 0) {
- return 0;
- }
-
- noconj = lsame_(trans, "T", (ftnlen)1, (ftnlen)1);
- nounit = lsame_(diag, "N", (ftnlen)1, (ftnlen)1);
-
-/* Set up the start point in X if the increment is not unity. This */
-/* will be ( N - 1 )*INCX too small for descending loops. */
-
- if (*incx <= 0) {
- kx = 1 - (*n - 1) * *incx;
- } else if (*incx != 1) {
- kx = 1;
- }
-
-/* Start the operations. In this version the elements of A are */
-/* accessed sequentially with one pass through A. */
-
- if (lsame_(trans, "N", (ftnlen)1, (ftnlen)1)) {
-
-/* Form x := A*x. */
-
- if (lsame_(uplo, "U", (ftnlen)1, (ftnlen)1)) {
- kplus1 = *k + 1;
- if (*incx == 1) {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- i__2 = j;
- if (x[i__2].r != 0.f || x[i__2].i != 0.f) {
- i__2 = j;
- temp.r = x[i__2].r, temp.i = x[i__2].i;
- l = kplus1 - j;
-/* Computing MAX */
- i__2 = 1, i__3 = j - *k;
- i__4 = j - 1;
- for (i__ = max(i__2,i__3); i__ <= i__4; ++i__) {
- i__2 = i__;
- i__3 = i__;
- i__5 = l + i__ + j * a_dim1;
- q__2.r = temp.r * a[i__5].r - temp.i * a[i__5].i,
- q__2.i = temp.r * a[i__5].i + temp.i * a[
- i__5].r;
- q__1.r = x[i__3].r + q__2.r, q__1.i = x[i__3].i +
- q__2.i;
- x[i__2].r = q__1.r, x[i__2].i = q__1.i;
-/* L10: */
- }
- if (nounit) {
- i__4 = j;
- i__2 = j;
- i__3 = kplus1 + j * a_dim1;
- q__1.r = x[i__2].r * a[i__3].r - x[i__2].i * a[
- i__3].i, q__1.i = x[i__2].r * a[i__3].i +
- x[i__2].i * a[i__3].r;
- x[i__4].r = q__1.r, x[i__4].i = q__1.i;
- }
- }
-/* L20: */
- }
- } else {
- jx = kx;
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- i__4 = jx;
- if (x[i__4].r != 0.f || x[i__4].i != 0.f) {
- i__4 = jx;
- temp.r = x[i__4].r, temp.i = x[i__4].i;
- ix = kx;
- l = kplus1 - j;
-/* Computing MAX */
- i__4 = 1, i__2 = j - *k;
- i__3 = j - 1;
- for (i__ = max(i__4,i__2); i__ <= i__3; ++i__) {
- i__4 = ix;
- i__2 = ix;
- i__5 = l + i__ + j * a_dim1;
- q__2.r = temp.r * a[i__5].r - temp.i * a[i__5].i,
- q__2.i = temp.r * a[i__5].i + temp.i * a[
- i__5].r;
- q__1.r = x[i__2].r + q__2.r, q__1.i = x[i__2].i +
- q__2.i;
- x[i__4].r = q__1.r, x[i__4].i = q__1.i;
- ix += *incx;
-/* L30: */
- }
- if (nounit) {
- i__3 = jx;
- i__4 = jx;
- i__2 = kplus1 + j * a_dim1;
- q__1.r = x[i__4].r * a[i__2].r - x[i__4].i * a[
- i__2].i, q__1.i = x[i__4].r * a[i__2].i +
- x[i__4].i * a[i__2].r;
- x[i__3].r = q__1.r, x[i__3].i = q__1.i;
- }
- }
- jx += *incx;
- if (j > *k) {
- kx += *incx;
- }
-/* L40: */
- }
- }
- } else {
- if (*incx == 1) {
- for (j = *n; j >= 1; --j) {
- i__1 = j;
- if (x[i__1].r != 0.f || x[i__1].i != 0.f) {
- i__1 = j;
- temp.r = x[i__1].r, temp.i = x[i__1].i;
- l = 1 - j;
-/* Computing MIN */
- i__1 = *n, i__3 = j + *k;
- i__4 = j + 1;
- for (i__ = min(i__1,i__3); i__ >= i__4; --i__) {
- i__1 = i__;
- i__3 = i__;
- i__2 = l + i__ + j * a_dim1;
- q__2.r = temp.r * a[i__2].r - temp.i * a[i__2].i,
- q__2.i = temp.r * a[i__2].i + temp.i * a[
- i__2].r;
- q__1.r = x[i__3].r + q__2.r, q__1.i = x[i__3].i +
- q__2.i;
- x[i__1].r = q__1.r, x[i__1].i = q__1.i;
-/* L50: */
- }
- if (nounit) {
- i__4 = j;
- i__1 = j;
- i__3 = j * a_dim1 + 1;
- q__1.r = x[i__1].r * a[i__3].r - x[i__1].i * a[
- i__3].i, q__1.i = x[i__1].r * a[i__3].i +
- x[i__1].i * a[i__3].r;
- x[i__4].r = q__1.r, x[i__4].i = q__1.i;
- }
- }
-/* L60: */
- }
- } else {
- kx += (*n - 1) * *incx;
- jx = kx;
- for (j = *n; j >= 1; --j) {
- i__4 = jx;
- if (x[i__4].r != 0.f || x[i__4].i != 0.f) {
- i__4 = jx;
- temp.r = x[i__4].r, temp.i = x[i__4].i;
- ix = kx;
- l = 1 - j;
-/* Computing MIN */
- i__4 = *n, i__1 = j + *k;
- i__3 = j + 1;
- for (i__ = min(i__4,i__1); i__ >= i__3; --i__) {
- i__4 = ix;
- i__1 = ix;
- i__2 = l + i__ + j * a_dim1;
- q__2.r = temp.r * a[i__2].r - temp.i * a[i__2].i,
- q__2.i = temp.r * a[i__2].i + temp.i * a[
- i__2].r;
- q__1.r = x[i__1].r + q__2.r, q__1.i = x[i__1].i +
- q__2.i;
- x[i__4].r = q__1.r, x[i__4].i = q__1.i;
- ix -= *incx;
-/* L70: */
- }
- if (nounit) {
- i__3 = jx;
- i__4 = jx;
- i__1 = j * a_dim1 + 1;
- q__1.r = x[i__4].r * a[i__1].r - x[i__4].i * a[
- i__1].i, q__1.i = x[i__4].r * a[i__1].i +
- x[i__4].i * a[i__1].r;
- x[i__3].r = q__1.r, x[i__3].i = q__1.i;
- }
- }
- jx -= *incx;
- if (*n - j >= *k) {
- kx -= *incx;
- }
-/* L80: */
- }
- }
- }
- } else {
-
-/* Form x := A'*x or x := conjg( A' )*x. */
-
- if (lsame_(uplo, "U", (ftnlen)1, (ftnlen)1)) {
- kplus1 = *k + 1;
- if (*incx == 1) {
- for (j = *n; j >= 1; --j) {
- i__3 = j;
- temp.r = x[i__3].r, temp.i = x[i__3].i;
- l = kplus1 - j;
- if (noconj) {
- if (nounit) {
- i__3 = kplus1 + j * a_dim1;
- q__1.r = temp.r * a[i__3].r - temp.i * a[i__3].i,
- q__1.i = temp.r * a[i__3].i + temp.i * a[
- i__3].r;
- temp.r = q__1.r, temp.i = q__1.i;
- }
-/* Computing MAX */
- i__4 = 1, i__1 = j - *k;
- i__3 = max(i__4,i__1);
- for (i__ = j - 1; i__ >= i__3; --i__) {
- i__4 = l + i__ + j * a_dim1;
- i__1 = i__;
- q__2.r = a[i__4].r * x[i__1].r - a[i__4].i * x[
- i__1].i, q__2.i = a[i__4].r * x[i__1].i +
- a[i__4].i * x[i__1].r;
- q__1.r = temp.r + q__2.r, q__1.i = temp.i +
- q__2.i;
- temp.r = q__1.r, temp.i = q__1.i;
-/* L90: */
- }
- } else {
- if (nounit) {
- r_cnjg(&q__2, &a[kplus1 + j * a_dim1]);
- q__1.r = temp.r * q__2.r - temp.i * q__2.i,
- q__1.i = temp.r * q__2.i + temp.i *
- q__2.r;
- temp.r = q__1.r, temp.i = q__1.i;
- }
-/* Computing MAX */
- i__4 = 1, i__1 = j - *k;
- i__3 = max(i__4,i__1);
- for (i__ = j - 1; i__ >= i__3; --i__) {
- r_cnjg(&q__3, &a[l + i__ + j * a_dim1]);
- i__4 = i__;
- q__2.r = q__3.r * x[i__4].r - q__3.i * x[i__4].i,
- q__2.i = q__3.r * x[i__4].i + q__3.i * x[
- i__4].r;
- q__1.r = temp.r + q__2.r, q__1.i = temp.i +
- q__2.i;
- temp.r = q__1.r, temp.i = q__1.i;
-/* L100: */
- }
- }
- i__3 = j;
- x[i__3].r = temp.r, x[i__3].i = temp.i;
-/* L110: */
- }
- } else {
- kx += (*n - 1) * *incx;
- jx = kx;
- for (j = *n; j >= 1; --j) {
- i__3 = jx;
- temp.r = x[i__3].r, temp.i = x[i__3].i;
- kx -= *incx;
- ix = kx;
- l = kplus1 - j;
- if (noconj) {
- if (nounit) {
- i__3 = kplus1 + j * a_dim1;
- q__1.r = temp.r * a[i__3].r - temp.i * a[i__3].i,
- q__1.i = temp.r * a[i__3].i + temp.i * a[
- i__3].r;
- temp.r = q__1.r, temp.i = q__1.i;
- }
-/* Computing MAX */
- i__4 = 1, i__1 = j - *k;
- i__3 = max(i__4,i__1);
- for (i__ = j - 1; i__ >= i__3; --i__) {
- i__4 = l + i__ + j * a_dim1;
- i__1 = ix;
- q__2.r = a[i__4].r * x[i__1].r - a[i__4].i * x[
- i__1].i, q__2.i = a[i__4].r * x[i__1].i +
- a[i__4].i * x[i__1].r;
- q__1.r = temp.r + q__2.r, q__1.i = temp.i +
- q__2.i;
- temp.r = q__1.r, temp.i = q__1.i;
- ix -= *incx;
-/* L120: */
- }
- } else {
- if (nounit) {
- r_cnjg(&q__2, &a[kplus1 + j * a_dim1]);
- q__1.r = temp.r * q__2.r - temp.i * q__2.i,
- q__1.i = temp.r * q__2.i + temp.i *
- q__2.r;
- temp.r = q__1.r, temp.i = q__1.i;
- }
-/* Computing MAX */
- i__4 = 1, i__1 = j - *k;
- i__3 = max(i__4,i__1);
- for (i__ = j - 1; i__ >= i__3; --i__) {
- r_cnjg(&q__3, &a[l + i__ + j * a_dim1]);
- i__4 = ix;
- q__2.r = q__3.r * x[i__4].r - q__3.i * x[i__4].i,
- q__2.i = q__3.r * x[i__4].i + q__3.i * x[
- i__4].r;
- q__1.r = temp.r + q__2.r, q__1.i = temp.i +
- q__2.i;
- temp.r = q__1.r, temp.i = q__1.i;
- ix -= *incx;
-/* L130: */
- }
- }
- i__3 = jx;
- x[i__3].r = temp.r, x[i__3].i = temp.i;
- jx -= *incx;
-/* L140: */
- }
- }
- } else {
- if (*incx == 1) {
- i__3 = *n;
- for (j = 1; j <= i__3; ++j) {
- i__4 = j;
- temp.r = x[i__4].r, temp.i = x[i__4].i;
- l = 1 - j;
- if (noconj) {
- if (nounit) {
- i__4 = j * a_dim1 + 1;
- q__1.r = temp.r * a[i__4].r - temp.i * a[i__4].i,
- q__1.i = temp.r * a[i__4].i + temp.i * a[
- i__4].r;
- temp.r = q__1.r, temp.i = q__1.i;
- }
-/* Computing MIN */
- i__1 = *n, i__2 = j + *k;
- i__4 = min(i__1,i__2);
- for (i__ = j + 1; i__ <= i__4; ++i__) {
- i__1 = l + i__ + j * a_dim1;
- i__2 = i__;
- q__2.r = a[i__1].r * x[i__2].r - a[i__1].i * x[
- i__2].i, q__2.i = a[i__1].r * x[i__2].i +
- a[i__1].i * x[i__2].r;
- q__1.r = temp.r + q__2.r, q__1.i = temp.i +
- q__2.i;
- temp.r = q__1.r, temp.i = q__1.i;
-/* L150: */
- }
- } else {
- if (nounit) {
- r_cnjg(&q__2, &a[j * a_dim1 + 1]);
- q__1.r = temp.r * q__2.r - temp.i * q__2.i,
- q__1.i = temp.r * q__2.i + temp.i *
- q__2.r;
- temp.r = q__1.r, temp.i = q__1.i;
- }
-/* Computing MIN */
- i__1 = *n, i__2 = j + *k;
- i__4 = min(i__1,i__2);
- for (i__ = j + 1; i__ <= i__4; ++i__) {
- r_cnjg(&q__3, &a[l + i__ + j * a_dim1]);
- i__1 = i__;
- q__2.r = q__3.r * x[i__1].r - q__3.i * x[i__1].i,
- q__2.i = q__3.r * x[i__1].i + q__3.i * x[
- i__1].r;
- q__1.r = temp.r + q__2.r, q__1.i = temp.i +
- q__2.i;
- temp.r = q__1.r, temp.i = q__1.i;
-/* L160: */
- }
- }
- i__4 = j;
- x[i__4].r = temp.r, x[i__4].i = temp.i;
-/* L170: */
- }
- } else {
- jx = kx;
- i__3 = *n;
- for (j = 1; j <= i__3; ++j) {
- i__4 = jx;
- temp.r = x[i__4].r, temp.i = x[i__4].i;
- kx += *incx;
- ix = kx;
- l = 1 - j;
- if (noconj) {
- if (nounit) {
- i__4 = j * a_dim1 + 1;
- q__1.r = temp.r * a[i__4].r - temp.i * a[i__4].i,
- q__1.i = temp.r * a[i__4].i + temp.i * a[
- i__4].r;
- temp.r = q__1.r, temp.i = q__1.i;
- }
-/* Computing MIN */
- i__1 = *n, i__2 = j + *k;
- i__4 = min(i__1,i__2);
- for (i__ = j + 1; i__ <= i__4; ++i__) {
- i__1 = l + i__ + j * a_dim1;
- i__2 = ix;
- q__2.r = a[i__1].r * x[i__2].r - a[i__1].i * x[
- i__2].i, q__2.i = a[i__1].r * x[i__2].i +
- a[i__1].i * x[i__2].r;
- q__1.r = temp.r + q__2.r, q__1.i = temp.i +
- q__2.i;
- temp.r = q__1.r, temp.i = q__1.i;
- ix += *incx;
-/* L180: */
- }
- } else {
- if (nounit) {
- r_cnjg(&q__2, &a[j * a_dim1 + 1]);
- q__1.r = temp.r * q__2.r - temp.i * q__2.i,
- q__1.i = temp.r * q__2.i + temp.i *
- q__2.r;
- temp.r = q__1.r, temp.i = q__1.i;
- }
-/* Computing MIN */
- i__1 = *n, i__2 = j + *k;
- i__4 = min(i__1,i__2);
- for (i__ = j + 1; i__ <= i__4; ++i__) {
- r_cnjg(&q__3, &a[l + i__ + j * a_dim1]);
- i__1 = ix;
- q__2.r = q__3.r * x[i__1].r - q__3.i * x[i__1].i,
- q__2.i = q__3.r * x[i__1].i + q__3.i * x[
- i__1].r;
- q__1.r = temp.r + q__2.r, q__1.i = temp.i +
- q__2.i;
- temp.r = q__1.r, temp.i = q__1.i;
- ix += *incx;
-/* L190: */
- }
- }
- i__4 = jx;
- x[i__4].r = temp.r, x[i__4].i = temp.i;
- jx += *incx;
-/* L200: */
- }
- }
- }
- }
-
- return 0;
-
-/* End of CTBMV . */
-
-} /* ctbmv_ */
-
-/* Subroutine */ int ctbsv_(char *uplo, char *trans, char *diag, integer *n,
- integer *k, complex *a, integer *lda, complex *x, integer *incx,
- ftnlen uplo_len, ftnlen trans_len, ftnlen diag_len)
-{
- /* System generated locals */
- integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5;
- complex q__1, q__2, q__3;
-
- /* Builtin functions */
- void c_div(complex *, complex *, complex *), r_cnjg(complex *, complex *);
-
- /* Local variables */
- static integer i__, j, l, ix, jx, kx, info;
- static complex temp;
- extern logical lsame_(char *, char *, ftnlen, ftnlen);
- static integer kplus1;
- extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen);
- static logical noconj, nounit;
-
-/* .. Scalar Arguments .. */
-/* .. Array Arguments .. */
-/* .. */
-
-/* Purpose */
-/* ======= */
-
-/* CTBSV solves one of the systems of equations */
-
-/* A*x = b, or A'*x = b, or conjg( A' )*x = b, */
-
-/* where b and x are n element vectors and A is an n by n unit, or */
-/* non-unit, upper or lower triangular band matrix, with ( k + 1 ) */
-/* diagonals. */
-
-/* No test for singularity or near-singularity is included in this */
-/* routine. Such tests must be performed before calling this routine. */
-
-/* Parameters */
-/* ========== */
-
-/* UPLO - CHARACTER*1. */
-/* On entry, UPLO specifies whether the matrix is an upper or */
-/* lower triangular matrix as follows: */
-
-/* UPLO = 'U' or 'u' A is an upper triangular matrix. */
-
-/* UPLO = 'L' or 'l' A is a lower triangular matrix. */
-
-/* Unchanged on exit. */
-
-/* TRANS - CHARACTER*1. */
-/* On entry, TRANS specifies the equations to be solved as */
-/* follows: */
-
-/* TRANS = 'N' or 'n' A*x = b. */
-
-/* TRANS = 'T' or 't' A'*x = b. */
-
-/* TRANS = 'C' or 'c' conjg( A' )*x = b. */
-
-/* Unchanged on exit. */
-
-/* DIAG - CHARACTER*1. */
-/* On entry, DIAG specifies whether or not A is unit */
-/* triangular as follows: */
-
-/* DIAG = 'U' or 'u' A is assumed to be unit triangular. */
-
-/* DIAG = 'N' or 'n' A is not assumed to be unit */
-/* triangular. */
-
-/* Unchanged on exit. */
-
-/* N - INTEGER. */
-/* On entry, N specifies the order of the matrix A. */
-/* N must be at least zero. */
-/* Unchanged on exit. */
-
-/* K - INTEGER. */
-/* On entry with UPLO = 'U' or 'u', K specifies the number of */
-/* super-diagonals of the matrix A. */
-/* On entry with UPLO = 'L' or 'l', K specifies the number of */
-/* sub-diagonals of the matrix A. */
-/* K must satisfy 0 .le. K. */
-/* Unchanged on exit. */
-
-/* A - COMPLEX array of DIMENSION ( LDA, n ). */
-/* Before entry with UPLO = 'U' or 'u', the leading ( k + 1 ) */
-/* by n part of the array A must contain the upper triangular */
-/* band part of the matrix of coefficients, supplied column by */
-/* column, with the leading diagonal of the matrix in row */
-/* ( k + 1 ) of the array, the first super-diagonal starting at */
-/* position 2 in row k, and so on. The top left k by k triangle */
-/* of the array A is not referenced. */
-/* The following program segment will transfer an upper */
-/* triangular band matrix from conventional full matrix storage */
-/* to band storage: */
-
-/* DO 20, J = 1, N */
-/* M = K + 1 - J */
-/* DO 10, I = MAX( 1, J - K ), J */
-/* A( M + I, J ) = matrix( I, J ) */
-/* 10 CONTINUE */
-/* 20 CONTINUE */
-
-/* Before entry with UPLO = 'L' or 'l', the leading ( k + 1 ) */
-/* by n part of the array A must contain the lower triangular */
-/* band part of the matrix of coefficients, supplied column by */
-/* column, with the leading diagonal of the matrix in row 1 of */
-/* the array, the first sub-diagonal starting at position 1 in */
-/* row 2, and so on. The bottom right k by k triangle of the */
-/* array A is not referenced. */
-/* The following program segment will transfer a lower */
-/* triangular band matrix from conventional full matrix storage */
-/* to band storage: */
-
-/* DO 20, J = 1, N */
-/* M = 1 - J */
-/* DO 10, I = J, MIN( N, J + K ) */
-/* A( M + I, J ) = matrix( I, J ) */
-/* 10 CONTINUE */
-/* 20 CONTINUE */
-
-/* Note that when DIAG = 'U' or 'u' the elements of the array A */
-/* corresponding to the diagonal elements of the matrix are not */
-/* referenced, but are assumed to be unity. */
-/* Unchanged on exit. */
-
-/* LDA - INTEGER. */
-/* On entry, LDA specifies the first dimension of A as declared */
-/* in the calling (sub) program. LDA must be at least */
-/* ( k + 1 ). */
-/* Unchanged on exit. */
-
-/* X - COMPLEX array of dimension at least */
-/* ( 1 + ( n - 1 )*abs( INCX ) ). */
-/* Before entry, the incremented array X must contain the n */
-/* element right-hand side vector b. On exit, X is overwritten */
-/* with the solution vector x. */
-
-/* INCX - INTEGER. */
-/* On entry, INCX specifies the increment for the elements of */
-/* X. INCX must not be zero. */
-/* Unchanged on exit. */
-
-
-/* Level 2 Blas routine. */
-
-/* -- Written on 22-October-1986. */
-/* Jack Dongarra, Argonne National Lab. */
-/* Jeremy Du Croz, Nag Central Office. */
-/* Sven Hammarling, Nag Central Office. */
-/* Richard Hanson, Sandia National Labs. */
-
-
-/* .. Parameters .. */
-/* .. Local Scalars .. */
-/* .. External Functions .. */
-/* .. External Subroutines .. */
-/* .. Intrinsic Functions .. */
-/* .. */
-/* .. Executable Statements .. */
-
-/* Test the input parameters. */
-
- /* Parameter adjustments */
- a_dim1 = *lda;
- a_offset = 1 + a_dim1 * 1;
- a -= a_offset;
- --x;
-
- /* Function Body */
- info = 0;
- if (! lsame_(uplo, "U", (ftnlen)1, (ftnlen)1) && ! lsame_(uplo, "L", (
- ftnlen)1, (ftnlen)1)) {
- info = 1;
- } else if (! lsame_(trans, "N", (ftnlen)1, (ftnlen)1) && ! lsame_(trans,
- "T", (ftnlen)1, (ftnlen)1) && ! lsame_(trans, "C", (ftnlen)1, (
- ftnlen)1)) {
- info = 2;
- } else if (! lsame_(diag, "U", (ftnlen)1, (ftnlen)1) && ! lsame_(diag,
- "N", (ftnlen)1, (ftnlen)1)) {
- info = 3;
- } else if (*n < 0) {
- info = 4;
- } else if (*k < 0) {
- info = 5;
- } else if (*lda < *k + 1) {
- info = 7;
- } else if (*incx == 0) {
- info = 9;
- }
- if (info != 0) {
- xerbla_("CTBSV ", &info, (ftnlen)6);
- return 0;
- }
-
-/* Quick return if possible. */
-
- if (*n == 0) {
- return 0;
- }
-
- noconj = lsame_(trans, "T", (ftnlen)1, (ftnlen)1);
- nounit = lsame_(diag, "N", (ftnlen)1, (ftnlen)1);
-
-/* Set up the start point in X if the increment is not unity. This */
-/* will be ( N - 1 )*INCX too small for descending loops. */
-
- if (*incx <= 0) {
- kx = 1 - (*n - 1) * *incx;
- } else if (*incx != 1) {
- kx = 1;
- }
-
-/* Start the operations. In this version the elements of A are */
-/* accessed by sequentially with one pass through A. */
-
- if (lsame_(trans, "N", (ftnlen)1, (ftnlen)1)) {
-
-/* Form x := inv( A )*x. */
-
- if (lsame_(uplo, "U", (ftnlen)1, (ftnlen)1)) {
- kplus1 = *k + 1;
- if (*incx == 1) {
- for (j = *n; j >= 1; --j) {
- i__1 = j;
- if (x[i__1].r != 0.f || x[i__1].i != 0.f) {
- l = kplus1 - j;
- if (nounit) {
- i__1 = j;
- c_div(&q__1, &x[j], &a[kplus1 + j * a_dim1]);
- x[i__1].r = q__1.r, x[i__1].i = q__1.i;
- }
- i__1 = j;
- temp.r = x[i__1].r, temp.i = x[i__1].i;
-/* Computing MAX */
- i__2 = 1, i__3 = j - *k;
- i__1 = max(i__2,i__3);
- for (i__ = j - 1; i__ >= i__1; --i__) {
- i__2 = i__;
- i__3 = i__;
- i__4 = l + i__ + j * a_dim1;
- q__2.r = temp.r * a[i__4].r - temp.i * a[i__4].i,
- q__2.i = temp.r * a[i__4].i + temp.i * a[
- i__4].r;
- q__1.r = x[i__3].r - q__2.r, q__1.i = x[i__3].i -
- q__2.i;
- x[i__2].r = q__1.r, x[i__2].i = q__1.i;
-/* L10: */
- }
- }
-/* L20: */
- }
- } else {
- kx += (*n - 1) * *incx;
- jx = kx;
- for (j = *n; j >= 1; --j) {
- kx -= *incx;
- i__1 = jx;
- if (x[i__1].r != 0.f || x[i__1].i != 0.f) {
- ix = kx;
- l = kplus1 - j;
- if (nounit) {
- i__1 = jx;
- c_div(&q__1, &x[jx], &a[kplus1 + j * a_dim1]);
- x[i__1].r = q__1.r, x[i__1].i = q__1.i;
- }
- i__1 = jx;
- temp.r = x[i__1].r, temp.i = x[i__1].i;
-/* Computing MAX */
- i__2 = 1, i__3 = j - *k;
- i__1 = max(i__2,i__3);
- for (i__ = j - 1; i__ >= i__1; --i__) {
- i__2 = ix;
- i__3 = ix;
- i__4 = l + i__ + j * a_dim1;
- q__2.r = temp.r * a[i__4].r - temp.i * a[i__4].i,
- q__2.i = temp.r * a[i__4].i + temp.i * a[
- i__4].r;
- q__1.r = x[i__3].r - q__2.r, q__1.i = x[i__3].i -
- q__2.i;
- x[i__2].r = q__1.r, x[i__2].i = q__1.i;
- ix -= *incx;
-/* L30: */
- }
- }
- jx -= *incx;
-/* L40: */
- }
- }
- } else {
- if (*incx == 1) {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- i__2 = j;
- if (x[i__2].r != 0.f || x[i__2].i != 0.f) {
- l = 1 - j;
- if (nounit) {
- i__2 = j;
- c_div(&q__1, &x[j], &a[j * a_dim1 + 1]);
- x[i__2].r = q__1.r, x[i__2].i = q__1.i;
- }
- i__2 = j;
- temp.r = x[i__2].r, temp.i = x[i__2].i;
-/* Computing MIN */
- i__3 = *n, i__4 = j + *k;
- i__2 = min(i__3,i__4);
- for (i__ = j + 1; i__ <= i__2; ++i__) {
- i__3 = i__;
- i__4 = i__;
- i__5 = l + i__ + j * a_dim1;
- q__2.r = temp.r * a[i__5].r - temp.i * a[i__5].i,
- q__2.i = temp.r * a[i__5].i + temp.i * a[
- i__5].r;
- q__1.r = x[i__4].r - q__2.r, q__1.i = x[i__4].i -
- q__2.i;
- x[i__3].r = q__1.r, x[i__3].i = q__1.i;
-/* L50: */
- }
- }
-/* L60: */
- }
- } else {
- jx = kx;
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- kx += *incx;
- i__2 = jx;
- if (x[i__2].r != 0.f || x[i__2].i != 0.f) {
- ix = kx;
- l = 1 - j;
- if (nounit) {
- i__2 = jx;
- c_div(&q__1, &x[jx], &a[j * a_dim1 + 1]);
- x[i__2].r = q__1.r, x[i__2].i = q__1.i;
- }
- i__2 = jx;
- temp.r = x[i__2].r, temp.i = x[i__2].i;
-/* Computing MIN */
- i__3 = *n, i__4 = j + *k;
- i__2 = min(i__3,i__4);
- for (i__ = j + 1; i__ <= i__2; ++i__) {
- i__3 = ix;
- i__4 = ix;
- i__5 = l + i__ + j * a_dim1;
- q__2.r = temp.r * a[i__5].r - temp.i * a[i__5].i,
- q__2.i = temp.r * a[i__5].i + temp.i * a[
- i__5].r;
- q__1.r = x[i__4].r - q__2.r, q__1.i = x[i__4].i -
- q__2.i;
- x[i__3].r = q__1.r, x[i__3].i = q__1.i;
- ix += *incx;
-/* L70: */
- }
- }
- jx += *incx;
-/* L80: */
- }
- }
- }
- } else {
-
-/* Form x := inv( A' )*x or x := inv( conjg( A') )*x. */
-
- if (lsame_(uplo, "U", (ftnlen)1, (ftnlen)1)) {
- kplus1 = *k + 1;
- if (*incx == 1) {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- i__2 = j;
- temp.r = x[i__2].r, temp.i = x[i__2].i;
- l = kplus1 - j;
- if (noconj) {
-/* Computing MAX */
- i__2 = 1, i__3 = j - *k;
- i__4 = j - 1;
- for (i__ = max(i__2,i__3); i__ <= i__4; ++i__) {
- i__2 = l + i__ + j * a_dim1;
- i__3 = i__;
- q__2.r = a[i__2].r * x[i__3].r - a[i__2].i * x[
- i__3].i, q__2.i = a[i__2].r * x[i__3].i +
- a[i__2].i * x[i__3].r;
- q__1.r = temp.r - q__2.r, q__1.i = temp.i -
- q__2.i;
- temp.r = q__1.r, temp.i = q__1.i;
-/* L90: */
- }
- if (nounit) {
- c_div(&q__1, &temp, &a[kplus1 + j * a_dim1]);
- temp.r = q__1.r, temp.i = q__1.i;
- }
- } else {
-/* Computing MAX */
- i__4 = 1, i__2 = j - *k;
- i__3 = j - 1;
- for (i__ = max(i__4,i__2); i__ <= i__3; ++i__) {
- r_cnjg(&q__3, &a[l + i__ + j * a_dim1]);
- i__4 = i__;
- q__2.r = q__3.r * x[i__4].r - q__3.i * x[i__4].i,
- q__2.i = q__3.r * x[i__4].i + q__3.i * x[
- i__4].r;
- q__1.r = temp.r - q__2.r, q__1.i = temp.i -
- q__2.i;
- temp.r = q__1.r, temp.i = q__1.i;
-/* L100: */
- }
- if (nounit) {
- r_cnjg(&q__2, &a[kplus1 + j * a_dim1]);
- c_div(&q__1, &temp, &q__2);
- temp.r = q__1.r, temp.i = q__1.i;
- }
- }
- i__3 = j;
- x[i__3].r = temp.r, x[i__3].i = temp.i;
-/* L110: */
- }
- } else {
- jx = kx;
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- i__3 = jx;
- temp.r = x[i__3].r, temp.i = x[i__3].i;
- ix = kx;
- l = kplus1 - j;
- if (noconj) {
-/* Computing MAX */
- i__3 = 1, i__4 = j - *k;
- i__2 = j - 1;
- for (i__ = max(i__3,i__4); i__ <= i__2; ++i__) {
- i__3 = l + i__ + j * a_dim1;
- i__4 = ix;
- q__2.r = a[i__3].r * x[i__4].r - a[i__3].i * x[
- i__4].i, q__2.i = a[i__3].r * x[i__4].i +
- a[i__3].i * x[i__4].r;
- q__1.r = temp.r - q__2.r, q__1.i = temp.i -
- q__2.i;
- temp.r = q__1.r, temp.i = q__1.i;
- ix += *incx;
-/* L120: */
- }
- if (nounit) {
- c_div(&q__1, &temp, &a[kplus1 + j * a_dim1]);
- temp.r = q__1.r, temp.i = q__1.i;
- }
- } else {
-/* Computing MAX */
- i__2 = 1, i__3 = j - *k;
- i__4 = j - 1;
- for (i__ = max(i__2,i__3); i__ <= i__4; ++i__) {
- r_cnjg(&q__3, &a[l + i__ + j * a_dim1]);
- i__2 = ix;
- q__2.r = q__3.r * x[i__2].r - q__3.i * x[i__2].i,
- q__2.i = q__3.r * x[i__2].i + q__3.i * x[
- i__2].r;
- q__1.r = temp.r - q__2.r, q__1.i = temp.i -
- q__2.i;
- temp.r = q__1.r, temp.i = q__1.i;
- ix += *incx;
-/* L130: */
- }
- if (nounit) {
- r_cnjg(&q__2, &a[kplus1 + j * a_dim1]);
- c_div(&q__1, &temp, &q__2);
- temp.r = q__1.r, temp.i = q__1.i;
- }
- }
- i__4 = jx;
- x[i__4].r = temp.r, x[i__4].i = temp.i;
- jx += *incx;
- if (j > *k) {
- kx += *incx;
- }
-/* L140: */
- }
- }
- } else {
- if (*incx == 1) {
- for (j = *n; j >= 1; --j) {
- i__1 = j;
- temp.r = x[i__1].r, temp.i = x[i__1].i;
- l = 1 - j;
- if (noconj) {
-/* Computing MIN */
- i__1 = *n, i__4 = j + *k;
- i__2 = j + 1;
- for (i__ = min(i__1,i__4); i__ >= i__2; --i__) {
- i__1 = l + i__ + j * a_dim1;
- i__4 = i__;
- q__2.r = a[i__1].r * x[i__4].r - a[i__1].i * x[
- i__4].i, q__2.i = a[i__1].r * x[i__4].i +
- a[i__1].i * x[i__4].r;
- q__1.r = temp.r - q__2.r, q__1.i = temp.i -
- q__2.i;
- temp.r = q__1.r, temp.i = q__1.i;
-/* L150: */
- }
- if (nounit) {
- c_div(&q__1, &temp, &a[j * a_dim1 + 1]);
- temp.r = q__1.r, temp.i = q__1.i;
- }
- } else {
-/* Computing MIN */
- i__2 = *n, i__1 = j + *k;
- i__4 = j + 1;
- for (i__ = min(i__2,i__1); i__ >= i__4; --i__) {
- r_cnjg(&q__3, &a[l + i__ + j * a_dim1]);
- i__2 = i__;
- q__2.r = q__3.r * x[i__2].r - q__3.i * x[i__2].i,
- q__2.i = q__3.r * x[i__2].i + q__3.i * x[
- i__2].r;
- q__1.r = temp.r - q__2.r, q__1.i = temp.i -
- q__2.i;
- temp.r = q__1.r, temp.i = q__1.i;
-/* L160: */
- }
- if (nounit) {
- r_cnjg(&q__2, &a[j * a_dim1 + 1]);
- c_div(&q__1, &temp, &q__2);
- temp.r = q__1.r, temp.i = q__1.i;
- }
- }
- i__4 = j;
- x[i__4].r = temp.r, x[i__4].i = temp.i;
-/* L170: */
- }
- } else {
- kx += (*n - 1) * *incx;
- jx = kx;
- for (j = *n; j >= 1; --j) {
- i__4 = jx;
- temp.r = x[i__4].r, temp.i = x[i__4].i;
- ix = kx;
- l = 1 - j;
- if (noconj) {
-/* Computing MIN */
- i__4 = *n, i__2 = j + *k;
- i__1 = j + 1;
- for (i__ = min(i__4,i__2); i__ >= i__1; --i__) {
- i__4 = l + i__ + j * a_dim1;
- i__2 = ix;
- q__2.r = a[i__4].r * x[i__2].r - a[i__4].i * x[
- i__2].i, q__2.i = a[i__4].r * x[i__2].i +
- a[i__4].i * x[i__2].r;
- q__1.r = temp.r - q__2.r, q__1.i = temp.i -
- q__2.i;
- temp.r = q__1.r, temp.i = q__1.i;
- ix -= *incx;
-/* L180: */
- }
- if (nounit) {
- c_div(&q__1, &temp, &a[j * a_dim1 + 1]);
- temp.r = q__1.r, temp.i = q__1.i;
- }
- } else {
-/* Computing MIN */
- i__1 = *n, i__4 = j + *k;
- i__2 = j + 1;
- for (i__ = min(i__1,i__4); i__ >= i__2; --i__) {
- r_cnjg(&q__3, &a[l + i__ + j * a_dim1]);
- i__1 = ix;
- q__2.r = q__3.r * x[i__1].r - q__3.i * x[i__1].i,
- q__2.i = q__3.r * x[i__1].i + q__3.i * x[
- i__1].r;
- q__1.r = temp.r - q__2.r, q__1.i = temp.i -
- q__2.i;
- temp.r = q__1.r, temp.i = q__1.i;
- ix -= *incx;
-/* L190: */
- }
- if (nounit) {
- r_cnjg(&q__2, &a[j * a_dim1 + 1]);
- c_div(&q__1, &temp, &q__2);
- temp.r = q__1.r, temp.i = q__1.i;
- }
- }
- i__2 = jx;
- x[i__2].r = temp.r, x[i__2].i = temp.i;
- jx -= *incx;
- if (*n - j >= *k) {
- kx -= *incx;
- }
-/* L200: */
- }
- }
- }
- }
-
- return 0;
-
-/* End of CTBSV . */
-
-} /* ctbsv_ */
-
-/* Subroutine */ int ctpmv_(char *uplo, char *trans, char *diag, integer *n,
- complex *ap, complex *x, integer *incx, ftnlen uplo_len, ftnlen
- trans_len, ftnlen diag_len)
-{
- /* System generated locals */
- integer i__1, i__2, i__3, i__4, i__5;
- complex q__1, q__2, q__3;
-
- /* Builtin functions */
- void r_cnjg(complex *, complex *);
-
- /* Local variables */
- static integer i__, j, k, kk, ix, jx, kx, info;
- static complex temp;
- extern logical lsame_(char *, char *, ftnlen, ftnlen);
- extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen);
- static logical noconj, nounit;
-
-/* .. Scalar Arguments .. */
-/* .. Array Arguments .. */
-/* .. */
-
-/* Purpose */
-/* ======= */
-
-/* CTPMV performs one of the matrix-vector operations */
-
-/* x := A*x, or x := A'*x, or x := conjg( A' )*x, */
-
-/* where x is an n element vector and A is an n by n unit, or non-unit, */
-/* upper or lower triangular matrix, supplied in packed form. */
-
-/* Parameters */
-/* ========== */
-
-/* UPLO - CHARACTER*1. */
-/* On entry, UPLO specifies whether the matrix is an upper or */
-/* lower triangular matrix as follows: */
-
-/* UPLO = 'U' or 'u' A is an upper triangular matrix. */
-
-/* UPLO = 'L' or 'l' A is a lower triangular matrix. */
-
-/* Unchanged on exit. */
-
-/* TRANS - CHARACTER*1. */
-/* On entry, TRANS specifies the operation to be performed as */
-/* follows: */
-
-/* TRANS = 'N' or 'n' x := A*x. */
-
-/* TRANS = 'T' or 't' x := A'*x. */
-
-/* TRANS = 'C' or 'c' x := conjg( A' )*x. */
-
-/* Unchanged on exit. */
-
-/* DIAG - CHARACTER*1. */
-/* On entry, DIAG specifies whether or not A is unit */
-/* triangular as follows: */
-
-/* DIAG = 'U' or 'u' A is assumed to be unit triangular. */
-
-/* DIAG = 'N' or 'n' A is not assumed to be unit */
-/* triangular. */
-
-/* Unchanged on exit. */
-
-/* N - INTEGER. */
-/* On entry, N specifies the order of the matrix A. */
-/* N must be at least zero. */
-/* Unchanged on exit. */
-
-/* AP - COMPLEX array of DIMENSION at least */
-/* ( ( n*( n + 1 ) )/2 ). */
-/* Before entry with UPLO = 'U' or 'u', the array AP must */
-/* contain the upper triangular matrix packed sequentially, */
-/* column by column, so that AP( 1 ) contains a( 1, 1 ), */
-/* AP( 2 ) and AP( 3 ) contain a( 1, 2 ) and a( 2, 2 ) */
-/* respectively, and so on. */
-/* Before entry with UPLO = 'L' or 'l', the array AP must */
-/* contain the lower triangular matrix packed sequentially, */
-/* column by column, so that AP( 1 ) contains a( 1, 1 ), */
-/* AP( 2 ) and AP( 3 ) contain a( 2, 1 ) and a( 3, 1 ) */
-/* respectively, and so on. */
-/* Note that when DIAG = 'U' or 'u', the diagonal elements of */
-/* A are not referenced, but are assumed to be unity. */
-/* Unchanged on exit. */
-
-/* X - COMPLEX array of dimension at least */
-/* ( 1 + ( n - 1 )*abs( INCX ) ). */
-/* Before entry, the incremented array X must contain the n */
-/* element vector x. On exit, X is overwritten with the */
-/* tranformed vector x. */
-
-/* INCX - INTEGER. */
-/* On entry, INCX specifies the increment for the elements of */
-/* X. INCX must not be zero. */
-/* Unchanged on exit. */
-
-
-/* Level 2 Blas routine. */
-
-/* -- Written on 22-October-1986. */
-/* Jack Dongarra, Argonne National Lab. */
-/* Jeremy Du Croz, Nag Central Office. */
-/* Sven Hammarling, Nag Central Office. */
-/* Richard Hanson, Sandia National Labs. */
-
-
-/* .. Parameters .. */
-/* .. Local Scalars .. */
-/* .. External Functions .. */
-/* .. External Subroutines .. */
-/* .. Intrinsic Functions .. */
-/* .. */
-/* .. Executable Statements .. */
-
-/* Test the input parameters. */
-
- /* Parameter adjustments */
- --x;
- --ap;
-
- /* Function Body */
- info = 0;
- if (! lsame_(uplo, "U", (ftnlen)1, (ftnlen)1) && ! lsame_(uplo, "L", (
- ftnlen)1, (ftnlen)1)) {
- info = 1;
- } else if (! lsame_(trans, "N", (ftnlen)1, (ftnlen)1) && ! lsame_(trans,
- "T", (ftnlen)1, (ftnlen)1) && ! lsame_(trans, "C", (ftnlen)1, (
- ftnlen)1)) {
- info = 2;
- } else if (! lsame_(diag, "U", (ftnlen)1, (ftnlen)1) && ! lsame_(diag,
- "N", (ftnlen)1, (ftnlen)1)) {
- info = 3;
- } else if (*n < 0) {
- info = 4;
- } else if (*incx == 0) {
- info = 7;
- }
- if (info != 0) {
- xerbla_("CTPMV ", &info, (ftnlen)6);
- return 0;
- }
-
-/* Quick return if possible. */
-
- if (*n == 0) {
- return 0;
- }
-
- noconj = lsame_(trans, "T", (ftnlen)1, (ftnlen)1);
- nounit = lsame_(diag, "N", (ftnlen)1, (ftnlen)1);
-
-/* Set up the start point in X if the increment is not unity. This */
-/* will be ( N - 1 )*INCX too small for descending loops. */
-
- if (*incx <= 0) {
- kx = 1 - (*n - 1) * *incx;
- } else if (*incx != 1) {
- kx = 1;
- }
-
-/* Start the operations. In this version the elements of AP are */
-/* accessed sequentially with one pass through AP. */
-
- if (lsame_(trans, "N", (ftnlen)1, (ftnlen)1)) {
-
-/* Form x:= A*x. */
-
- if (lsame_(uplo, "U", (ftnlen)1, (ftnlen)1)) {
- kk = 1;
- if (*incx == 1) {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- i__2 = j;
- if (x[i__2].r != 0.f || x[i__2].i != 0.f) {
- i__2 = j;
- temp.r = x[i__2].r, temp.i = x[i__2].i;
- k = kk;
- i__2 = j - 1;
- for (i__ = 1; i__ <= i__2; ++i__) {
- i__3 = i__;
- i__4 = i__;
- i__5 = k;
- q__2.r = temp.r * ap[i__5].r - temp.i * ap[i__5]
- .i, q__2.i = temp.r * ap[i__5].i + temp.i
- * ap[i__5].r;
- q__1.r = x[i__4].r + q__2.r, q__1.i = x[i__4].i +
- q__2.i;
- x[i__3].r = q__1.r, x[i__3].i = q__1.i;
- ++k;
-/* L10: */
- }
- if (nounit) {
- i__2 = j;
- i__3 = j;
- i__4 = kk + j - 1;
- q__1.r = x[i__3].r * ap[i__4].r - x[i__3].i * ap[
- i__4].i, q__1.i = x[i__3].r * ap[i__4].i
- + x[i__3].i * ap[i__4].r;
- x[i__2].r = q__1.r, x[i__2].i = q__1.i;
- }
- }
- kk += j;
-/* L20: */
- }
- } else {
- jx = kx;
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- i__2 = jx;
- if (x[i__2].r != 0.f || x[i__2].i != 0.f) {
- i__2 = jx;
- temp.r = x[i__2].r, temp.i = x[i__2].i;
- ix = kx;
- i__2 = kk + j - 2;
- for (k = kk; k <= i__2; ++k) {
- i__3 = ix;
- i__4 = ix;
- i__5 = k;
- q__2.r = temp.r * ap[i__5].r - temp.i * ap[i__5]
- .i, q__2.i = temp.r * ap[i__5].i + temp.i
- * ap[i__5].r;
- q__1.r = x[i__4].r + q__2.r, q__1.i = x[i__4].i +
- q__2.i;
- x[i__3].r = q__1.r, x[i__3].i = q__1.i;
- ix += *incx;
-/* L30: */
- }
- if (nounit) {
- i__2 = jx;
- i__3 = jx;
- i__4 = kk + j - 1;
- q__1.r = x[i__3].r * ap[i__4].r - x[i__3].i * ap[
- i__4].i, q__1.i = x[i__3].r * ap[i__4].i
- + x[i__3].i * ap[i__4].r;
- x[i__2].r = q__1.r, x[i__2].i = q__1.i;
- }
- }
- jx += *incx;
- kk += j;
-/* L40: */
- }
- }
- } else {
- kk = *n * (*n + 1) / 2;
- if (*incx == 1) {
- for (j = *n; j >= 1; --j) {
- i__1 = j;
- if (x[i__1].r != 0.f || x[i__1].i != 0.f) {
- i__1 = j;
- temp.r = x[i__1].r, temp.i = x[i__1].i;
- k = kk;
- i__1 = j + 1;
- for (i__ = *n; i__ >= i__1; --i__) {
- i__2 = i__;
- i__3 = i__;
- i__4 = k;
- q__2.r = temp.r * ap[i__4].r - temp.i * ap[i__4]
- .i, q__2.i = temp.r * ap[i__4].i + temp.i
- * ap[i__4].r;
- q__1.r = x[i__3].r + q__2.r, q__1.i = x[i__3].i +
- q__2.i;
- x[i__2].r = q__1.r, x[i__2].i = q__1.i;
- --k;
-/* L50: */
- }
- if (nounit) {
- i__1 = j;
- i__2 = j;
- i__3 = kk - *n + j;
- q__1.r = x[i__2].r * ap[i__3].r - x[i__2].i * ap[
- i__3].i, q__1.i = x[i__2].r * ap[i__3].i
- + x[i__2].i * ap[i__3].r;
- x[i__1].r = q__1.r, x[i__1].i = q__1.i;
- }
- }
- kk -= *n - j + 1;
-/* L60: */
- }
- } else {
- kx += (*n - 1) * *incx;
- jx = kx;
- for (j = *n; j >= 1; --j) {
- i__1 = jx;
- if (x[i__1].r != 0.f || x[i__1].i != 0.f) {
- i__1 = jx;
- temp.r = x[i__1].r, temp.i = x[i__1].i;
- ix = kx;
- i__1 = kk - (*n - (j + 1));
- for (k = kk; k >= i__1; --k) {
- i__2 = ix;
- i__3 = ix;
- i__4 = k;
- q__2.r = temp.r * ap[i__4].r - temp.i * ap[i__4]
- .i, q__2.i = temp.r * ap[i__4].i + temp.i
- * ap[i__4].r;
- q__1.r = x[i__3].r + q__2.r, q__1.i = x[i__3].i +
- q__2.i;
- x[i__2].r = q__1.r, x[i__2].i = q__1.i;
- ix -= *incx;
-/* L70: */
- }
- if (nounit) {
- i__1 = jx;
- i__2 = jx;
- i__3 = kk - *n + j;
- q__1.r = x[i__2].r * ap[i__3].r - x[i__2].i * ap[
- i__3].i, q__1.i = x[i__2].r * ap[i__3].i
- + x[i__2].i * ap[i__3].r;
- x[i__1].r = q__1.r, x[i__1].i = q__1.i;
- }
- }
- jx -= *incx;
- kk -= *n - j + 1;
-/* L80: */
- }
- }
- }
- } else {
-
-/* Form x := A'*x or x := conjg( A' )*x. */
-
- if (lsame_(uplo, "U", (ftnlen)1, (ftnlen)1)) {
- kk = *n * (*n + 1) / 2;
- if (*incx == 1) {
- for (j = *n; j >= 1; --j) {
- i__1 = j;
- temp.r = x[i__1].r, temp.i = x[i__1].i;
- k = kk - 1;
- if (noconj) {
- if (nounit) {
- i__1 = kk;
- q__1.r = temp.r * ap[i__1].r - temp.i * ap[i__1]
- .i, q__1.i = temp.r * ap[i__1].i + temp.i
- * ap[i__1].r;
- temp.r = q__1.r, temp.i = q__1.i;
- }
- for (i__ = j - 1; i__ >= 1; --i__) {
- i__1 = k;
- i__2 = i__;
- q__2.r = ap[i__1].r * x[i__2].r - ap[i__1].i * x[
- i__2].i, q__2.i = ap[i__1].r * x[i__2].i
- + ap[i__1].i * x[i__2].r;
- q__1.r = temp.r + q__2.r, q__1.i = temp.i +
- q__2.i;
- temp.r = q__1.r, temp.i = q__1.i;
- --k;
-/* L90: */
- }
- } else {
- if (nounit) {
- r_cnjg(&q__2, &ap[kk]);
- q__1.r = temp.r * q__2.r - temp.i * q__2.i,
- q__1.i = temp.r * q__2.i + temp.i *
- q__2.r;
- temp.r = q__1.r, temp.i = q__1.i;
- }
- for (i__ = j - 1; i__ >= 1; --i__) {
- r_cnjg(&q__3, &ap[k]);
- i__1 = i__;
- q__2.r = q__3.r * x[i__1].r - q__3.i * x[i__1].i,
- q__2.i = q__3.r * x[i__1].i + q__3.i * x[
- i__1].r;
- q__1.r = temp.r + q__2.r, q__1.i = temp.i +
- q__2.i;
- temp.r = q__1.r, temp.i = q__1.i;
- --k;
-/* L100: */
- }
- }
- i__1 = j;
- x[i__1].r = temp.r, x[i__1].i = temp.i;
- kk -= j;
-/* L110: */
- }
- } else {
- jx = kx + (*n - 1) * *incx;
- for (j = *n; j >= 1; --j) {
- i__1 = jx;
- temp.r = x[i__1].r, temp.i = x[i__1].i;
- ix = jx;
- if (noconj) {
- if (nounit) {
- i__1 = kk;
- q__1.r = temp.r * ap[i__1].r - temp.i * ap[i__1]
- .i, q__1.i = temp.r * ap[i__1].i + temp.i
- * ap[i__1].r;
- temp.r = q__1.r, temp.i = q__1.i;
- }
- i__1 = kk - j + 1;
- for (k = kk - 1; k >= i__1; --k) {
- ix -= *incx;
- i__2 = k;
- i__3 = ix;
- q__2.r = ap[i__2].r * x[i__3].r - ap[i__2].i * x[
- i__3].i, q__2.i = ap[i__2].r * x[i__3].i
- + ap[i__2].i * x[i__3].r;
- q__1.r = temp.r + q__2.r, q__1.i = temp.i +
- q__2.i;
- temp.r = q__1.r, temp.i = q__1.i;
-/* L120: */
- }
- } else {
- if (nounit) {
- r_cnjg(&q__2, &ap[kk]);
- q__1.r = temp.r * q__2.r - temp.i * q__2.i,
- q__1.i = temp.r * q__2.i + temp.i *
- q__2.r;
- temp.r = q__1.r, temp.i = q__1.i;
- }
- i__1 = kk - j + 1;
- for (k = kk - 1; k >= i__1; --k) {
- ix -= *incx;
- r_cnjg(&q__3, &ap[k]);
- i__2 = ix;
- q__2.r = q__3.r * x[i__2].r - q__3.i * x[i__2].i,
- q__2.i = q__3.r * x[i__2].i + q__3.i * x[
- i__2].r;
- q__1.r = temp.r + q__2.r, q__1.i = temp.i +
- q__2.i;
- temp.r = q__1.r, temp.i = q__1.i;
-/* L130: */
- }
- }
- i__1 = jx;
- x[i__1].r = temp.r, x[i__1].i = temp.i;
- jx -= *incx;
- kk -= j;
-/* L140: */
- }
- }
- } else {
- kk = 1;
- if (*incx == 1) {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- i__2 = j;
- temp.r = x[i__2].r, temp.i = x[i__2].i;
- k = kk + 1;
- if (noconj) {
- if (nounit) {
- i__2 = kk;
- q__1.r = temp.r * ap[i__2].r - temp.i * ap[i__2]
- .i, q__1.i = temp.r * ap[i__2].i + temp.i
- * ap[i__2].r;
- temp.r = q__1.r, temp.i = q__1.i;
- }
- i__2 = *n;
- for (i__ = j + 1; i__ <= i__2; ++i__) {
- i__3 = k;
- i__4 = i__;
- q__2.r = ap[i__3].r * x[i__4].r - ap[i__3].i * x[
- i__4].i, q__2.i = ap[i__3].r * x[i__4].i
- + ap[i__3].i * x[i__4].r;
- q__1.r = temp.r + q__2.r, q__1.i = temp.i +
- q__2.i;
- temp.r = q__1.r, temp.i = q__1.i;
- ++k;
-/* L150: */
- }
- } else {
- if (nounit) {
- r_cnjg(&q__2, &ap[kk]);
- q__1.r = temp.r * q__2.r - temp.i * q__2.i,
- q__1.i = temp.r * q__2.i + temp.i *
- q__2.r;
- temp.r = q__1.r, temp.i = q__1.i;
- }
- i__2 = *n;
- for (i__ = j + 1; i__ <= i__2; ++i__) {
- r_cnjg(&q__3, &ap[k]);
- i__3 = i__;
- q__2.r = q__3.r * x[i__3].r - q__3.i * x[i__3].i,
- q__2.i = q__3.r * x[i__3].i + q__3.i * x[
- i__3].r;
- q__1.r = temp.r + q__2.r, q__1.i = temp.i +
- q__2.i;
- temp.r = q__1.r, temp.i = q__1.i;
- ++k;
-/* L160: */
- }
- }
- i__2 = j;
- x[i__2].r = temp.r, x[i__2].i = temp.i;
- kk += *n - j + 1;
-/* L170: */
- }
- } else {
- jx = kx;
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- i__2 = jx;
- temp.r = x[i__2].r, temp.i = x[i__2].i;
- ix = jx;
- if (noconj) {
- if (nounit) {
- i__2 = kk;
- q__1.r = temp.r * ap[i__2].r - temp.i * ap[i__2]
- .i, q__1.i = temp.r * ap[i__2].i + temp.i
- * ap[i__2].r;
- temp.r = q__1.r, temp.i = q__1.i;
- }
- i__2 = kk + *n - j;
- for (k = kk + 1; k <= i__2; ++k) {
- ix += *incx;
- i__3 = k;
- i__4 = ix;
- q__2.r = ap[i__3].r * x[i__4].r - ap[i__3].i * x[
- i__4].i, q__2.i = ap[i__3].r * x[i__4].i
- + ap[i__3].i * x[i__4].r;
- q__1.r = temp.r + q__2.r, q__1.i = temp.i +
- q__2.i;
- temp.r = q__1.r, temp.i = q__1.i;
-/* L180: */
- }
- } else {
- if (nounit) {
- r_cnjg(&q__2, &ap[kk]);
- q__1.r = temp.r * q__2.r - temp.i * q__2.i,
- q__1.i = temp.r * q__2.i + temp.i *
- q__2.r;
- temp.r = q__1.r, temp.i = q__1.i;
- }
- i__2 = kk + *n - j;
- for (k = kk + 1; k <= i__2; ++k) {
- ix += *incx;
- r_cnjg(&q__3, &ap[k]);
- i__3 = ix;
- q__2.r = q__3.r * x[i__3].r - q__3.i * x[i__3].i,
- q__2.i = q__3.r * x[i__3].i + q__3.i * x[
- i__3].r;
- q__1.r = temp.r + q__2.r, q__1.i = temp.i +
- q__2.i;
- temp.r = q__1.r, temp.i = q__1.i;
-/* L190: */
- }
- }
- i__2 = jx;
- x[i__2].r = temp.r, x[i__2].i = temp.i;
- jx += *incx;
- kk += *n - j + 1;
-/* L200: */
- }
- }
- }
- }
-
- return 0;
-
-/* End of CTPMV . */
-
-} /* ctpmv_ */
-
-/* Subroutine */ int ctpsv_(char *uplo, char *trans, char *diag, integer *n,
- complex *ap, complex *x, integer *incx, ftnlen uplo_len, ftnlen
- trans_len, ftnlen diag_len)
-{
- /* System generated locals */
- integer i__1, i__2, i__3, i__4, i__5;
- complex q__1, q__2, q__3;
-
- /* Builtin functions */
- void c_div(complex *, complex *, complex *), r_cnjg(complex *, complex *);
-
- /* Local variables */
- static integer i__, j, k, kk, ix, jx, kx, info;
- static complex temp;
- extern logical lsame_(char *, char *, ftnlen, ftnlen);
- extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen);
- static logical noconj, nounit;
-
-/* .. Scalar Arguments .. */
-/* .. Array Arguments .. */
-/* .. */
-
-/* Purpose */
-/* ======= */
-
-/* CTPSV solves one of the systems of equations */
-
-/* A*x = b, or A'*x = b, or conjg( A' )*x = b, */
-
-/* where b and x are n element vectors and A is an n by n unit, or */
-/* non-unit, upper or lower triangular matrix, supplied in packed form. */
-
-/* No test for singularity or near-singularity is included in this */
-/* routine. Such tests must be performed before calling this routine. */
-
-/* Parameters */
-/* ========== */
-
-/* UPLO - CHARACTER*1. */
-/* On entry, UPLO specifies whether the matrix is an upper or */
-/* lower triangular matrix as follows: */
-
-/* UPLO = 'U' or 'u' A is an upper triangular matrix. */
-
-/* UPLO = 'L' or 'l' A is a lower triangular matrix. */
-
-/* Unchanged on exit. */
-
-/* TRANS - CHARACTER*1. */
-/* On entry, TRANS specifies the equations to be solved as */
-/* follows: */
-
-/* TRANS = 'N' or 'n' A*x = b. */
-
-/* TRANS = 'T' or 't' A'*x = b. */
-
-/* TRANS = 'C' or 'c' conjg( A' )*x = b. */
-
-/* Unchanged on exit. */
-
-/* DIAG - CHARACTER*1. */
-/* On entry, DIAG specifies whether or not A is unit */
-/* triangular as follows: */
-
-/* DIAG = 'U' or 'u' A is assumed to be unit triangular. */
-
-/* DIAG = 'N' or 'n' A is not assumed to be unit */
-/* triangular. */
-
-/* Unchanged on exit. */
-
-/* N - INTEGER. */
-/* On entry, N specifies the order of the matrix A. */
-/* N must be at least zero. */
-/* Unchanged on exit. */
-
-/* AP - COMPLEX array of DIMENSION at least */
-/* ( ( n*( n + 1 ) )/2 ). */
-/* Before entry with UPLO = 'U' or 'u', the array AP must */
-/* contain the upper triangular matrix packed sequentially, */
-/* column by column, so that AP( 1 ) contains a( 1, 1 ), */
-/* AP( 2 ) and AP( 3 ) contain a( 1, 2 ) and a( 2, 2 ) */
-/* respectively, and so on. */
-/* Before entry with UPLO = 'L' or 'l', the array AP must */
-/* contain the lower triangular matrix packed sequentially, */
-/* column by column, so that AP( 1 ) contains a( 1, 1 ), */
-/* AP( 2 ) and AP( 3 ) contain a( 2, 1 ) and a( 3, 1 ) */
-/* respectively, and so on. */
-/* Note that when DIAG = 'U' or 'u', the diagonal elements of */
-/* A are not referenced, but are assumed to be unity. */
-/* Unchanged on exit. */
-
-/* X - COMPLEX array of dimension at least */
-/* ( 1 + ( n - 1 )*abs( INCX ) ). */
-/* Before entry, the incremented array X must contain the n */
-/* element right-hand side vector b. On exit, X is overwritten */
-/* with the solution vector x. */
-
-/* INCX - INTEGER. */
-/* On entry, INCX specifies the increment for the elements of */
-/* X. INCX must not be zero. */
-/* Unchanged on exit. */
-
-
-/* Level 2 Blas routine. */
-
-/* -- Written on 22-October-1986. */
-/* Jack Dongarra, Argonne National Lab. */
-/* Jeremy Du Croz, Nag Central Office. */
-/* Sven Hammarling, Nag Central Office. */
-/* Richard Hanson, Sandia National Labs. */
-
-
-/* .. Parameters .. */
-/* .. Local Scalars .. */
-/* .. External Functions .. */
-/* .. External Subroutines .. */
-/* .. Intrinsic Functions .. */
-/* .. */
-/* .. Executable Statements .. */
-
-/* Test the input parameters. */
-
- /* Parameter adjustments */
- --x;
- --ap;
-
- /* Function Body */
- info = 0;
- if (! lsame_(uplo, "U", (ftnlen)1, (ftnlen)1) && ! lsame_(uplo, "L", (
- ftnlen)1, (ftnlen)1)) {
- info = 1;
- } else if (! lsame_(trans, "N", (ftnlen)1, (ftnlen)1) && ! lsame_(trans,
- "T", (ftnlen)1, (ftnlen)1) && ! lsame_(trans, "C", (ftnlen)1, (
- ftnlen)1)) {
- info = 2;
- } else if (! lsame_(diag, "U", (ftnlen)1, (ftnlen)1) && ! lsame_(diag,
- "N", (ftnlen)1, (ftnlen)1)) {
- info = 3;
- } else if (*n < 0) {
- info = 4;
- } else if (*incx == 0) {
- info = 7;
- }
- if (info != 0) {
- xerbla_("CTPSV ", &info, (ftnlen)6);
- return 0;
- }
-
-/* Quick return if possible. */
-
- if (*n == 0) {
- return 0;
- }
-
- noconj = lsame_(trans, "T", (ftnlen)1, (ftnlen)1);
- nounit = lsame_(diag, "N", (ftnlen)1, (ftnlen)1);
-
-/* Set up the start point in X if the increment is not unity. This */
-/* will be ( N - 1 )*INCX too small for descending loops. */
-
- if (*incx <= 0) {
- kx = 1 - (*n - 1) * *incx;
- } else if (*incx != 1) {
- kx = 1;
- }
-
-/* Start the operations. In this version the elements of AP are */
-/* accessed sequentially with one pass through AP. */
-
- if (lsame_(trans, "N", (ftnlen)1, (ftnlen)1)) {
-
-/* Form x := inv( A )*x. */
-
- if (lsame_(uplo, "U", (ftnlen)1, (ftnlen)1)) {
- kk = *n * (*n + 1) / 2;
- if (*incx == 1) {
- for (j = *n; j >= 1; --j) {
- i__1 = j;
- if (x[i__1].r != 0.f || x[i__1].i != 0.f) {
- if (nounit) {
- i__1 = j;
- c_div(&q__1, &x[j], &ap[kk]);
- x[i__1].r = q__1.r, x[i__1].i = q__1.i;
- }
- i__1 = j;
- temp.r = x[i__1].r, temp.i = x[i__1].i;
- k = kk - 1;
- for (i__ = j - 1; i__ >= 1; --i__) {
- i__1 = i__;
- i__2 = i__;
- i__3 = k;
- q__2.r = temp.r * ap[i__3].r - temp.i * ap[i__3]
- .i, q__2.i = temp.r * ap[i__3].i + temp.i
- * ap[i__3].r;
- q__1.r = x[i__2].r - q__2.r, q__1.i = x[i__2].i -
- q__2.i;
- x[i__1].r = q__1.r, x[i__1].i = q__1.i;
- --k;
-/* L10: */
- }
- }
- kk -= j;
-/* L20: */
- }
- } else {
- jx = kx + (*n - 1) * *incx;
- for (j = *n; j >= 1; --j) {
- i__1 = jx;
- if (x[i__1].r != 0.f || x[i__1].i != 0.f) {
- if (nounit) {
- i__1 = jx;
- c_div(&q__1, &x[jx], &ap[kk]);
- x[i__1].r = q__1.r, x[i__1].i = q__1.i;
- }
- i__1 = jx;
- temp.r = x[i__1].r, temp.i = x[i__1].i;
- ix = jx;
- i__1 = kk - j + 1;
- for (k = kk - 1; k >= i__1; --k) {
- ix -= *incx;
- i__2 = ix;
- i__3 = ix;
- i__4 = k;
- q__2.r = temp.r * ap[i__4].r - temp.i * ap[i__4]
- .i, q__2.i = temp.r * ap[i__4].i + temp.i
- * ap[i__4].r;
- q__1.r = x[i__3].r - q__2.r, q__1.i = x[i__3].i -
- q__2.i;
- x[i__2].r = q__1.r, x[i__2].i = q__1.i;
-/* L30: */
- }
- }
- jx -= *incx;
- kk -= j;
-/* L40: */
- }
- }
- } else {
- kk = 1;
- if (*incx == 1) {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- i__2 = j;
- if (x[i__2].r != 0.f || x[i__2].i != 0.f) {
- if (nounit) {
- i__2 = j;
- c_div(&q__1, &x[j], &ap[kk]);
- x[i__2].r = q__1.r, x[i__2].i = q__1.i;
- }
- i__2 = j;
- temp.r = x[i__2].r, temp.i = x[i__2].i;
- k = kk + 1;
- i__2 = *n;
- for (i__ = j + 1; i__ <= i__2; ++i__) {
- i__3 = i__;
- i__4 = i__;
- i__5 = k;
- q__2.r = temp.r * ap[i__5].r - temp.i * ap[i__5]
- .i, q__2.i = temp.r * ap[i__5].i + temp.i
- * ap[i__5].r;
- q__1.r = x[i__4].r - q__2.r, q__1.i = x[i__4].i -
- q__2.i;
- x[i__3].r = q__1.r, x[i__3].i = q__1.i;
- ++k;
-/* L50: */
- }
- }
- kk += *n - j + 1;
-/* L60: */
- }
- } else {
- jx = kx;
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- i__2 = jx;
- if (x[i__2].r != 0.f || x[i__2].i != 0.f) {
- if (nounit) {
- i__2 = jx;
- c_div(&q__1, &x[jx], &ap[kk]);
- x[i__2].r = q__1.r, x[i__2].i = q__1.i;
- }
- i__2 = jx;
- temp.r = x[i__2].r, temp.i = x[i__2].i;
- ix = jx;
- i__2 = kk + *n - j;
- for (k = kk + 1; k <= i__2; ++k) {
- ix += *incx;
- i__3 = ix;
- i__4 = ix;
- i__5 = k;
- q__2.r = temp.r * ap[i__5].r - temp.i * ap[i__5]
- .i, q__2.i = temp.r * ap[i__5].i + temp.i
- * ap[i__5].r;
- q__1.r = x[i__4].r - q__2.r, q__1.i = x[i__4].i -
- q__2.i;
- x[i__3].r = q__1.r, x[i__3].i = q__1.i;
-/* L70: */
- }
- }
- jx += *incx;
- kk += *n - j + 1;
-/* L80: */
- }
- }
- }
- } else {
-
-/* Form x := inv( A' )*x or x := inv( conjg( A' ) )*x. */
-
- if (lsame_(uplo, "U", (ftnlen)1, (ftnlen)1)) {
- kk = 1;
- if (*incx == 1) {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- i__2 = j;
- temp.r = x[i__2].r, temp.i = x[i__2].i;
- k = kk;
- if (noconj) {
- i__2 = j - 1;
- for (i__ = 1; i__ <= i__2; ++i__) {
- i__3 = k;
- i__4 = i__;
- q__2.r = ap[i__3].r * x[i__4].r - ap[i__3].i * x[
- i__4].i, q__2.i = ap[i__3].r * x[i__4].i
- + ap[i__3].i * x[i__4].r;
- q__1.r = temp.r - q__2.r, q__1.i = temp.i -
- q__2.i;
- temp.r = q__1.r, temp.i = q__1.i;
- ++k;
-/* L90: */
- }
- if (nounit) {
- c_div(&q__1, &temp, &ap[kk + j - 1]);
- temp.r = q__1.r, temp.i = q__1.i;
- }
- } else {
- i__2 = j - 1;
- for (i__ = 1; i__ <= i__2; ++i__) {
- r_cnjg(&q__3, &ap[k]);
- i__3 = i__;
- q__2.r = q__3.r * x[i__3].r - q__3.i * x[i__3].i,
- q__2.i = q__3.r * x[i__3].i + q__3.i * x[
- i__3].r;
- q__1.r = temp.r - q__2.r, q__1.i = temp.i -
- q__2.i;
- temp.r = q__1.r, temp.i = q__1.i;
- ++k;
-/* L100: */
- }
- if (nounit) {
- r_cnjg(&q__2, &ap[kk + j - 1]);
- c_div(&q__1, &temp, &q__2);
- temp.r = q__1.r, temp.i = q__1.i;
- }
- }
- i__2 = j;
- x[i__2].r = temp.r, x[i__2].i = temp.i;
- kk += j;
-/* L110: */
- }
- } else {
- jx = kx;
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- i__2 = jx;
- temp.r = x[i__2].r, temp.i = x[i__2].i;
- ix = kx;
- if (noconj) {
- i__2 = kk + j - 2;
- for (k = kk; k <= i__2; ++k) {
- i__3 = k;
- i__4 = ix;
- q__2.r = ap[i__3].r * x[i__4].r - ap[i__3].i * x[
- i__4].i, q__2.i = ap[i__3].r * x[i__4].i
- + ap[i__3].i * x[i__4].r;
- q__1.r = temp.r - q__2.r, q__1.i = temp.i -
- q__2.i;
- temp.r = q__1.r, temp.i = q__1.i;
- ix += *incx;
-/* L120: */
- }
- if (nounit) {
- c_div(&q__1, &temp, &ap[kk + j - 1]);
- temp.r = q__1.r, temp.i = q__1.i;
- }
- } else {
- i__2 = kk + j - 2;
- for (k = kk; k <= i__2; ++k) {
- r_cnjg(&q__3, &ap[k]);
- i__3 = ix;
- q__2.r = q__3.r * x[i__3].r - q__3.i * x[i__3].i,
- q__2.i = q__3.r * x[i__3].i + q__3.i * x[
- i__3].r;
- q__1.r = temp.r - q__2.r, q__1.i = temp.i -
- q__2.i;
- temp.r = q__1.r, temp.i = q__1.i;
- ix += *incx;
-/* L130: */
- }
- if (nounit) {
- r_cnjg(&q__2, &ap[kk + j - 1]);
- c_div(&q__1, &temp, &q__2);
- temp.r = q__1.r, temp.i = q__1.i;
- }
- }
- i__2 = jx;
- x[i__2].r = temp.r, x[i__2].i = temp.i;
- jx += *incx;
- kk += j;
-/* L140: */
- }
- }
- } else {
- kk = *n * (*n + 1) / 2;
- if (*incx == 1) {
- for (j = *n; j >= 1; --j) {
- i__1 = j;
- temp.r = x[i__1].r, temp.i = x[i__1].i;
- k = kk;
- if (noconj) {
- i__1 = j + 1;
- for (i__ = *n; i__ >= i__1; --i__) {
- i__2 = k;
- i__3 = i__;
- q__2.r = ap[i__2].r * x[i__3].r - ap[i__2].i * x[
- i__3].i, q__2.i = ap[i__2].r * x[i__3].i
- + ap[i__2].i * x[i__3].r;
- q__1.r = temp.r - q__2.r, q__1.i = temp.i -
- q__2.i;
- temp.r = q__1.r, temp.i = q__1.i;
- --k;
-/* L150: */
- }
- if (nounit) {
- c_div(&q__1, &temp, &ap[kk - *n + j]);
- temp.r = q__1.r, temp.i = q__1.i;
- }
- } else {
- i__1 = j + 1;
- for (i__ = *n; i__ >= i__1; --i__) {
- r_cnjg(&q__3, &ap[k]);
- i__2 = i__;
- q__2.r = q__3.r * x[i__2].r - q__3.i * x[i__2].i,
- q__2.i = q__3.r * x[i__2].i + q__3.i * x[
- i__2].r;
- q__1.r = temp.r - q__2.r, q__1.i = temp.i -
- q__2.i;
- temp.r = q__1.r, temp.i = q__1.i;
- --k;
-/* L160: */
- }
- if (nounit) {
- r_cnjg(&q__2, &ap[kk - *n + j]);
- c_div(&q__1, &temp, &q__2);
- temp.r = q__1.r, temp.i = q__1.i;
- }
- }
- i__1 = j;
- x[i__1].r = temp.r, x[i__1].i = temp.i;
- kk -= *n - j + 1;
-/* L170: */
- }
- } else {
- kx += (*n - 1) * *incx;
- jx = kx;
- for (j = *n; j >= 1; --j) {
- i__1 = jx;
- temp.r = x[i__1].r, temp.i = x[i__1].i;
- ix = kx;
- if (noconj) {
- i__1 = kk - (*n - (j + 1));
- for (k = kk; k >= i__1; --k) {
- i__2 = k;
- i__3 = ix;
- q__2.r = ap[i__2].r * x[i__3].r - ap[i__2].i * x[
- i__3].i, q__2.i = ap[i__2].r * x[i__3].i
- + ap[i__2].i * x[i__3].r;
- q__1.r = temp.r - q__2.r, q__1.i = temp.i -
- q__2.i;
- temp.r = q__1.r, temp.i = q__1.i;
- ix -= *incx;
-/* L180: */
- }
- if (nounit) {
- c_div(&q__1, &temp, &ap[kk - *n + j]);
- temp.r = q__1.r, temp.i = q__1.i;
- }
- } else {
- i__1 = kk - (*n - (j + 1));
- for (k = kk; k >= i__1; --k) {
- r_cnjg(&q__3, &ap[k]);
- i__2 = ix;
- q__2.r = q__3.r * x[i__2].r - q__3.i * x[i__2].i,
- q__2.i = q__3.r * x[i__2].i + q__3.i * x[
- i__2].r;
- q__1.r = temp.r - q__2.r, q__1.i = temp.i -
- q__2.i;
- temp.r = q__1.r, temp.i = q__1.i;
- ix -= *incx;
-/* L190: */
- }
- if (nounit) {
- r_cnjg(&q__2, &ap[kk - *n + j]);
- c_div(&q__1, &temp, &q__2);
- temp.r = q__1.r, temp.i = q__1.i;
- }
- }
- i__1 = jx;
- x[i__1].r = temp.r, x[i__1].i = temp.i;
- jx -= *incx;
- kk -= *n - j + 1;
-/* L200: */
- }
- }
- }
- }
-
- return 0;
-
-/* End of CTPSV . */
-
-} /* ctpsv_ */
-
-/* Subroutine */ int ctrmm_(char *side, char *uplo, char *transa, char *diag,
- integer *m, integer *n, complex *alpha, complex *a, integer *lda,
- complex *b, integer *ldb, ftnlen side_len, ftnlen uplo_len, ftnlen
- transa_len, ftnlen diag_len)
-{
- /* System generated locals */
- integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2, i__3, i__4, i__5,
- i__6;
- complex q__1, q__2, q__3;
-
- /* Builtin functions */
- void r_cnjg(complex *, complex *);
-
- /* Local variables */
- static integer i__, j, k, info;
- static complex temp;
- extern logical lsame_(char *, char *, ftnlen, ftnlen);
- static logical lside;
- static integer nrowa;
- static logical upper;
- extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen);
- static logical noconj, nounit;
-
-/* .. Scalar Arguments .. */
-/* .. Array Arguments .. */
-/* .. */
-
-/* Purpose */
-/* ======= */
-
-/* CTRMM performs one of the matrix-matrix operations */
-
-/* B := alpha*op( A )*B, or B := alpha*B*op( A ) */
-
-/* where alpha is a scalar, B is an m by n matrix, A is a unit, or */
-/* non-unit, upper or lower triangular matrix and op( A ) is one of */
-
-/* op( A ) = A or op( A ) = A' or op( A ) = conjg( A' ). */
-
-/* Parameters */
-/* ========== */
-
-/* SIDE - CHARACTER*1. */
-/* On entry, SIDE specifies whether op( A ) multiplies B from */
-/* the left or right as follows: */
-
-/* SIDE = 'L' or 'l' B := alpha*op( A )*B. */
-
-/* SIDE = 'R' or 'r' B := alpha*B*op( A ). */
-
-/* Unchanged on exit. */
-
-/* UPLO - CHARACTER*1. */
-/* On entry, UPLO specifies whether the matrix A is an upper or */
-/* lower triangular matrix as follows: */
-
-/* UPLO = 'U' or 'u' A is an upper triangular matrix. */
-
-/* UPLO = 'L' or 'l' A is a lower triangular matrix. */
-
-/* Unchanged on exit. */
-
-/* TRANSA - CHARACTER*1. */
-/* On entry, TRANSA specifies the form of op( A ) to be used in */
-/* the matrix multiplication as follows: */
-
-/* TRANSA = 'N' or 'n' op( A ) = A. */
-
-/* TRANSA = 'T' or 't' op( A ) = A'. */
-
-/* TRANSA = 'C' or 'c' op( A ) = conjg( A' ). */
-
-/* Unchanged on exit. */
-
-/* DIAG - CHARACTER*1. */
-/* On entry, DIAG specifies whether or not A is unit triangular */
-/* as follows: */
-
-/* DIAG = 'U' or 'u' A is assumed to be unit triangular. */
-
-/* DIAG = 'N' or 'n' A is not assumed to be unit */
-/* triangular. */
-
-/* Unchanged on exit. */
-
-/* M - INTEGER. */
-/* On entry, M specifies the number of rows of B. M must be at */
-/* least zero. */
-/* Unchanged on exit. */
-
-/* N - INTEGER. */
-/* On entry, N specifies the number of columns of B. N must be */
-/* at least zero. */
-/* Unchanged on exit. */
-
-/* ALPHA - COMPLEX . */
-/* On entry, ALPHA specifies the scalar alpha. When alpha is */
-/* zero then A is not referenced and B need not be set before */
-/* entry. */
-/* Unchanged on exit. */
-
-/* A - COMPLEX array of DIMENSION ( LDA, k ), where k is m */
-/* when SIDE = 'L' or 'l' and is n when SIDE = 'R' or 'r'. */
-/* Before entry with UPLO = 'U' or 'u', the leading k by k */
-/* upper triangular part of the array A must contain the upper */
-/* triangular matrix and the strictly lower triangular part of */
-/* A is not referenced. */
-/* Before entry with UPLO = 'L' or 'l', the leading k by k */
-/* lower triangular part of the array A must contain the lower */
-/* triangular matrix and the strictly upper triangular part of */
-/* A is not referenced. */
-/* Note that when DIAG = 'U' or 'u', the diagonal elements of */
-/* A are not referenced either, but are assumed to be unity. */
-/* Unchanged on exit. */
-
-/* LDA - INTEGER. */
-/* On entry, LDA specifies the first dimension of A as declared */
-/* in the calling (sub) program. When SIDE = 'L' or 'l' then */
-/* LDA must be at least max( 1, m ), when SIDE = 'R' or 'r' */
-/* then LDA must be at least max( 1, n ). */
-/* Unchanged on exit. */
-
-/* B - COMPLEX array of DIMENSION ( LDB, n ). */
-/* Before entry, the leading m by n part of the array B must */
-/* contain the matrix B, and on exit is overwritten by the */
-/* transformed matrix. */
-
-/* LDB - INTEGER. */
-/* On entry, LDB specifies the first dimension of B as declared */
-/* in the calling (sub) program. LDB must be at least */
-/* max( 1, m ). */
-/* Unchanged on exit. */
-
-
-/* Level 3 Blas routine. */
-
-/* -- Written on 8-February-1989. */
-/* Jack Dongarra, Argonne National Laboratory. */
-/* Iain Duff, AERE Harwell. */
-/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */
-/* Sven Hammarling, Numerical Algorithms Group Ltd. */
-
-
-/* .. External Functions .. */
-/* .. External Subroutines .. */
-/* .. Intrinsic Functions .. */
-/* .. Local Scalars .. */
-/* .. Parameters .. */
-/* .. */
-/* .. Executable Statements .. */
-
-/* Test the input parameters. */
-
- /* Parameter adjustments */
- a_dim1 = *lda;
- a_offset = 1 + a_dim1 * 1;
- a -= a_offset;
- b_dim1 = *ldb;
- b_offset = 1 + b_dim1 * 1;
- b -= b_offset;
-
- /* Function Body */
- lside = lsame_(side, "L", (ftnlen)1, (ftnlen)1);
- if (lside) {
- nrowa = *m;
- } else {
- nrowa = *n;
- }
- noconj = lsame_(transa, "T", (ftnlen)1, (ftnlen)1);
- nounit = lsame_(diag, "N", (ftnlen)1, (ftnlen)1);
- upper = lsame_(uplo, "U", (ftnlen)1, (ftnlen)1);
-
- info = 0;
- if (! lside && ! lsame_(side, "R", (ftnlen)1, (ftnlen)1)) {
- info = 1;
- } else if (! upper && ! lsame_(uplo, "L", (ftnlen)1, (ftnlen)1)) {
- info = 2;
- } else if (! lsame_(transa, "N", (ftnlen)1, (ftnlen)1) && ! lsame_(transa,
- "T", (ftnlen)1, (ftnlen)1) && ! lsame_(transa, "C", (ftnlen)1, (
- ftnlen)1)) {
- info = 3;
- } else if (! lsame_(diag, "U", (ftnlen)1, (ftnlen)1) && ! lsame_(diag,
- "N", (ftnlen)1, (ftnlen)1)) {
- info = 4;
- } else if (*m < 0) {
- info = 5;
- } else if (*n < 0) {
- info = 6;
- } else if (*lda < max(1,nrowa)) {
- info = 9;
- } else if (*ldb < max(1,*m)) {
- info = 11;
- }
- if (info != 0) {
- xerbla_("CTRMM ", &info, (ftnlen)6);
- return 0;
- }
-
-/* Quick return if possible. */
-
- if (*n == 0) {
- return 0;
- }
-
-/* And when alpha.eq.zero. */
-
- if (alpha->r == 0.f && alpha->i == 0.f) {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- i__2 = *m;
- for (i__ = 1; i__ <= i__2; ++i__) {
- i__3 = i__ + j * b_dim1;
- b[i__3].r = 0.f, b[i__3].i = 0.f;
-/* L10: */
- }
-/* L20: */
- }
- return 0;
- }
-
-/* Start the operations. */
-
- if (lside) {
- if (lsame_(transa, "N", (ftnlen)1, (ftnlen)1)) {
-
-/* Form B := alpha*A*B. */
-
- if (upper) {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- i__2 = *m;
- for (k = 1; k <= i__2; ++k) {
- i__3 = k + j * b_dim1;
- if (b[i__3].r != 0.f || b[i__3].i != 0.f) {
- i__3 = k + j * b_dim1;
- q__1.r = alpha->r * b[i__3].r - alpha->i * b[i__3]
- .i, q__1.i = alpha->r * b[i__3].i +
- alpha->i * b[i__3].r;
- temp.r = q__1.r, temp.i = q__1.i;
- i__3 = k - 1;
- for (i__ = 1; i__ <= i__3; ++i__) {
- i__4 = i__ + j * b_dim1;
- i__5 = i__ + j * b_dim1;
- i__6 = i__ + k * a_dim1;
- q__2.r = temp.r * a[i__6].r - temp.i * a[i__6]
- .i, q__2.i = temp.r * a[i__6].i +
- temp.i * a[i__6].r;
- q__1.r = b[i__5].r + q__2.r, q__1.i = b[i__5]
- .i + q__2.i;
- b[i__4].r = q__1.r, b[i__4].i = q__1.i;
-/* L30: */
- }
- if (nounit) {
- i__3 = k + k * a_dim1;
- q__1.r = temp.r * a[i__3].r - temp.i * a[i__3]
- .i, q__1.i = temp.r * a[i__3].i +
- temp.i * a[i__3].r;
- temp.r = q__1.r, temp.i = q__1.i;
- }
- i__3 = k + j * b_dim1;
- b[i__3].r = temp.r, b[i__3].i = temp.i;
- }
-/* L40: */
- }
-/* L50: */
- }
- } else {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- for (k = *m; k >= 1; --k) {
- i__2 = k + j * b_dim1;
- if (b[i__2].r != 0.f || b[i__2].i != 0.f) {
- i__2 = k + j * b_dim1;
- q__1.r = alpha->r * b[i__2].r - alpha->i * b[i__2]
- .i, q__1.i = alpha->r * b[i__2].i +
- alpha->i * b[i__2].r;
- temp.r = q__1.r, temp.i = q__1.i;
- i__2 = k + j * b_dim1;
- b[i__2].r = temp.r, b[i__2].i = temp.i;
- if (nounit) {
- i__2 = k + j * b_dim1;
- i__3 = k + j * b_dim1;
- i__4 = k + k * a_dim1;
- q__1.r = b[i__3].r * a[i__4].r - b[i__3].i *
- a[i__4].i, q__1.i = b[i__3].r * a[
- i__4].i + b[i__3].i * a[i__4].r;
- b[i__2].r = q__1.r, b[i__2].i = q__1.i;
- }
- i__2 = *m;
- for (i__ = k + 1; i__ <= i__2; ++i__) {
- i__3 = i__ + j * b_dim1;
- i__4 = i__ + j * b_dim1;
- i__5 = i__ + k * a_dim1;
- q__2.r = temp.r * a[i__5].r - temp.i * a[i__5]
- .i, q__2.i = temp.r * a[i__5].i +
- temp.i * a[i__5].r;
- q__1.r = b[i__4].r + q__2.r, q__1.i = b[i__4]
- .i + q__2.i;
- b[i__3].r = q__1.r, b[i__3].i = q__1.i;
-/* L60: */
- }
- }
-/* L70: */
- }
-/* L80: */
- }
- }
- } else {
-
-/* Form B := alpha*A'*B or B := alpha*conjg( A' )*B. */
-
- if (upper) {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- for (i__ = *m; i__ >= 1; --i__) {
- i__2 = i__ + j * b_dim1;
- temp.r = b[i__2].r, temp.i = b[i__2].i;
- if (noconj) {
- if (nounit) {
- i__2 = i__ + i__ * a_dim1;
- q__1.r = temp.r * a[i__2].r - temp.i * a[i__2]
- .i, q__1.i = temp.r * a[i__2].i +
- temp.i * a[i__2].r;
- temp.r = q__1.r, temp.i = q__1.i;
- }
- i__2 = i__ - 1;
- for (k = 1; k <= i__2; ++k) {
- i__3 = k + i__ * a_dim1;
- i__4 = k + j * b_dim1;
- q__2.r = a[i__3].r * b[i__4].r - a[i__3].i *
- b[i__4].i, q__2.i = a[i__3].r * b[
- i__4].i + a[i__3].i * b[i__4].r;
- q__1.r = temp.r + q__2.r, q__1.i = temp.i +
- q__2.i;
- temp.r = q__1.r, temp.i = q__1.i;
-/* L90: */
- }
- } else {
- if (nounit) {
- r_cnjg(&q__2, &a[i__ + i__ * a_dim1]);
- q__1.r = temp.r * q__2.r - temp.i * q__2.i,
- q__1.i = temp.r * q__2.i + temp.i *
- q__2.r;
- temp.r = q__1.r, temp.i = q__1.i;
- }
- i__2 = i__ - 1;
- for (k = 1; k <= i__2; ++k) {
- r_cnjg(&q__3, &a[k + i__ * a_dim1]);
- i__3 = k + j * b_dim1;
- q__2.r = q__3.r * b[i__3].r - q__3.i * b[i__3]
- .i, q__2.i = q__3.r * b[i__3].i +
- q__3.i * b[i__3].r;
- q__1.r = temp.r + q__2.r, q__1.i = temp.i +
- q__2.i;
- temp.r = q__1.r, temp.i = q__1.i;
-/* L100: */
- }
- }
- i__2 = i__ + j * b_dim1;
- q__1.r = alpha->r * temp.r - alpha->i * temp.i,
- q__1.i = alpha->r * temp.i + alpha->i *
- temp.r;
- b[i__2].r = q__1.r, b[i__2].i = q__1.i;
-/* L110: */
- }
-/* L120: */
- }
- } else {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- i__2 = *m;
- for (i__ = 1; i__ <= i__2; ++i__) {
- i__3 = i__ + j * b_dim1;
- temp.r = b[i__3].r, temp.i = b[i__3].i;
- if (noconj) {
- if (nounit) {
- i__3 = i__ + i__ * a_dim1;
- q__1.r = temp.r * a[i__3].r - temp.i * a[i__3]
- .i, q__1.i = temp.r * a[i__3].i +
- temp.i * a[i__3].r;
- temp.r = q__1.r, temp.i = q__1.i;
- }
- i__3 = *m;
- for (k = i__ + 1; k <= i__3; ++k) {
- i__4 = k + i__ * a_dim1;
- i__5 = k + j * b_dim1;
- q__2.r = a[i__4].r * b[i__5].r - a[i__4].i *
- b[i__5].i, q__2.i = a[i__4].r * b[
- i__5].i + a[i__4].i * b[i__5].r;
- q__1.r = temp.r + q__2.r, q__1.i = temp.i +
- q__2.i;
- temp.r = q__1.r, temp.i = q__1.i;
-/* L130: */
- }
- } else {
- if (nounit) {
- r_cnjg(&q__2, &a[i__ + i__ * a_dim1]);
- q__1.r = temp.r * q__2.r - temp.i * q__2.i,
- q__1.i = temp.r * q__2.i + temp.i *
- q__2.r;
- temp.r = q__1.r, temp.i = q__1.i;
- }
- i__3 = *m;
- for (k = i__ + 1; k <= i__3; ++k) {
- r_cnjg(&q__3, &a[k + i__ * a_dim1]);
- i__4 = k + j * b_dim1;
- q__2.r = q__3.r * b[i__4].r - q__3.i * b[i__4]
- .i, q__2.i = q__3.r * b[i__4].i +
- q__3.i * b[i__4].r;
- q__1.r = temp.r + q__2.r, q__1.i = temp.i +
- q__2.i;
- temp.r = q__1.r, temp.i = q__1.i;
-/* L140: */
- }
- }
- i__3 = i__ + j * b_dim1;
- q__1.r = alpha->r * temp.r - alpha->i * temp.i,
- q__1.i = alpha->r * temp.i + alpha->i *
- temp.r;
- b[i__3].r = q__1.r, b[i__3].i = q__1.i;
-/* L150: */
- }
-/* L160: */
- }
- }
- }
- } else {
- if (lsame_(transa, "N", (ftnlen)1, (ftnlen)1)) {
-
-/* Form B := alpha*B*A. */
-
- if (upper) {
- for (j = *n; j >= 1; --j) {
- temp.r = alpha->r, temp.i = alpha->i;
- if (nounit) {
- i__1 = j + j * a_dim1;
- q__1.r = temp.r * a[i__1].r - temp.i * a[i__1].i,
- q__1.i = temp.r * a[i__1].i + temp.i * a[i__1]
- .r;
- temp.r = q__1.r, temp.i = q__1.i;
- }
- i__1 = *m;
- for (i__ = 1; i__ <= i__1; ++i__) {
- i__2 = i__ + j * b_dim1;
- i__3 = i__ + j * b_dim1;
- q__1.r = temp.r * b[i__3].r - temp.i * b[i__3].i,
- q__1.i = temp.r * b[i__3].i + temp.i * b[i__3]
- .r;
- b[i__2].r = q__1.r, b[i__2].i = q__1.i;
-/* L170: */
- }
- i__1 = j - 1;
- for (k = 1; k <= i__1; ++k) {
- i__2 = k + j * a_dim1;
- if (a[i__2].r != 0.f || a[i__2].i != 0.f) {
- i__2 = k + j * a_dim1;
- q__1.r = alpha->r * a[i__2].r - alpha->i * a[i__2]
- .i, q__1.i = alpha->r * a[i__2].i +
- alpha->i * a[i__2].r;
- temp.r = q__1.r, temp.i = q__1.i;
- i__2 = *m;
- for (i__ = 1; i__ <= i__2; ++i__) {
- i__3 = i__ + j * b_dim1;
- i__4 = i__ + j * b_dim1;
- i__5 = i__ + k * b_dim1;
- q__2.r = temp.r * b[i__5].r - temp.i * b[i__5]
- .i, q__2.i = temp.r * b[i__5].i +
- temp.i * b[i__5].r;
- q__1.r = b[i__4].r + q__2.r, q__1.i = b[i__4]
- .i + q__2.i;
- b[i__3].r = q__1.r, b[i__3].i = q__1.i;
-/* L180: */
- }
- }
-/* L190: */
- }
-/* L200: */
- }
- } else {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- temp.r = alpha->r, temp.i = alpha->i;
- if (nounit) {
- i__2 = j + j * a_dim1;
- q__1.r = temp.r * a[i__2].r - temp.i * a[i__2].i,
- q__1.i = temp.r * a[i__2].i + temp.i * a[i__2]
- .r;
- temp.r = q__1.r, temp.i = q__1.i;
- }
- i__2 = *m;
- for (i__ = 1; i__ <= i__2; ++i__) {
- i__3 = i__ + j * b_dim1;
- i__4 = i__ + j * b_dim1;
- q__1.r = temp.r * b[i__4].r - temp.i * b[i__4].i,
- q__1.i = temp.r * b[i__4].i + temp.i * b[i__4]
- .r;
- b[i__3].r = q__1.r, b[i__3].i = q__1.i;
-/* L210: */
- }
- i__2 = *n;
- for (k = j + 1; k <= i__2; ++k) {
- i__3 = k + j * a_dim1;
- if (a[i__3].r != 0.f || a[i__3].i != 0.f) {
- i__3 = k + j * a_dim1;
- q__1.r = alpha->r * a[i__3].r - alpha->i * a[i__3]
- .i, q__1.i = alpha->r * a[i__3].i +
- alpha->i * a[i__3].r;
- temp.r = q__1.r, temp.i = q__1.i;
- i__3 = *m;
- for (i__ = 1; i__ <= i__3; ++i__) {
- i__4 = i__ + j * b_dim1;
- i__5 = i__ + j * b_dim1;
- i__6 = i__ + k * b_dim1;
- q__2.r = temp.r * b[i__6].r - temp.i * b[i__6]
- .i, q__2.i = temp.r * b[i__6].i +
- temp.i * b[i__6].r;
- q__1.r = b[i__5].r + q__2.r, q__1.i = b[i__5]
- .i + q__2.i;
- b[i__4].r = q__1.r, b[i__4].i = q__1.i;
-/* L220: */
- }
- }
-/* L230: */
- }
-/* L240: */
- }
- }
- } else {
-
-/* Form B := alpha*B*A' or B := alpha*B*conjg( A' ). */
-
- if (upper) {
- i__1 = *n;
- for (k = 1; k <= i__1; ++k) {
- i__2 = k - 1;
- for (j = 1; j <= i__2; ++j) {
- i__3 = j + k * a_dim1;
- if (a[i__3].r != 0.f || a[i__3].i != 0.f) {
- if (noconj) {
- i__3 = j + k * a_dim1;
- q__1.r = alpha->r * a[i__3].r - alpha->i * a[
- i__3].i, q__1.i = alpha->r * a[i__3]
- .i + alpha->i * a[i__3].r;
- temp.r = q__1.r, temp.i = q__1.i;
- } else {
- r_cnjg(&q__2, &a[j + k * a_dim1]);
- q__1.r = alpha->r * q__2.r - alpha->i *
- q__2.i, q__1.i = alpha->r * q__2.i +
- alpha->i * q__2.r;
- temp.r = q__1.r, temp.i = q__1.i;
- }
- i__3 = *m;
- for (i__ = 1; i__ <= i__3; ++i__) {
- i__4 = i__ + j * b_dim1;
- i__5 = i__ + j * b_dim1;
- i__6 = i__ + k * b_dim1;
- q__2.r = temp.r * b[i__6].r - temp.i * b[i__6]
- .i, q__2.i = temp.r * b[i__6].i +
- temp.i * b[i__6].r;
- q__1.r = b[i__5].r + q__2.r, q__1.i = b[i__5]
- .i + q__2.i;
- b[i__4].r = q__1.r, b[i__4].i = q__1.i;
-/* L250: */
- }
- }
-/* L260: */
- }
- temp.r = alpha->r, temp.i = alpha->i;
- if (nounit) {
- if (noconj) {
- i__2 = k + k * a_dim1;
- q__1.r = temp.r * a[i__2].r - temp.i * a[i__2].i,
- q__1.i = temp.r * a[i__2].i + temp.i * a[
- i__2].r;
- temp.r = q__1.r, temp.i = q__1.i;
- } else {
- r_cnjg(&q__2, &a[k + k * a_dim1]);
- q__1.r = temp.r * q__2.r - temp.i * q__2.i,
- q__1.i = temp.r * q__2.i + temp.i *
- q__2.r;
- temp.r = q__1.r, temp.i = q__1.i;
- }
- }
- if (temp.r != 1.f || temp.i != 0.f) {
- i__2 = *m;
- for (i__ = 1; i__ <= i__2; ++i__) {
- i__3 = i__ + k * b_dim1;
- i__4 = i__ + k * b_dim1;
- q__1.r = temp.r * b[i__4].r - temp.i * b[i__4].i,
- q__1.i = temp.r * b[i__4].i + temp.i * b[
- i__4].r;
- b[i__3].r = q__1.r, b[i__3].i = q__1.i;
-/* L270: */
- }
- }
-/* L280: */
- }
- } else {
- for (k = *n; k >= 1; --k) {
- i__1 = *n;
- for (j = k + 1; j <= i__1; ++j) {
- i__2 = j + k * a_dim1;
- if (a[i__2].r != 0.f || a[i__2].i != 0.f) {
- if (noconj) {
- i__2 = j + k * a_dim1;
- q__1.r = alpha->r * a[i__2].r - alpha->i * a[
- i__2].i, q__1.i = alpha->r * a[i__2]
- .i + alpha->i * a[i__2].r;
- temp.r = q__1.r, temp.i = q__1.i;
- } else {
- r_cnjg(&q__2, &a[j + k * a_dim1]);
- q__1.r = alpha->r * q__2.r - alpha->i *
- q__2.i, q__1.i = alpha->r * q__2.i +
- alpha->i * q__2.r;
- temp.r = q__1.r, temp.i = q__1.i;
- }
- i__2 = *m;
- for (i__ = 1; i__ <= i__2; ++i__) {
- i__3 = i__ + j * b_dim1;
- i__4 = i__ + j * b_dim1;
- i__5 = i__ + k * b_dim1;
- q__2.r = temp.r * b[i__5].r - temp.i * b[i__5]
- .i, q__2.i = temp.r * b[i__5].i +
- temp.i * b[i__5].r;
- q__1.r = b[i__4].r + q__2.r, q__1.i = b[i__4]
- .i + q__2.i;
- b[i__3].r = q__1.r, b[i__3].i = q__1.i;
-/* L290: */
- }
- }
-/* L300: */
- }
- temp.r = alpha->r, temp.i = alpha->i;
- if (nounit) {
- if (noconj) {
- i__1 = k + k * a_dim1;
- q__1.r = temp.r * a[i__1].r - temp.i * a[i__1].i,
- q__1.i = temp.r * a[i__1].i + temp.i * a[
- i__1].r;
- temp.r = q__1.r, temp.i = q__1.i;
- } else {
- r_cnjg(&q__2, &a[k + k * a_dim1]);
- q__1.r = temp.r * q__2.r - temp.i * q__2.i,
- q__1.i = temp.r * q__2.i + temp.i *
- q__2.r;
- temp.r = q__1.r, temp.i = q__1.i;
- }
- }
- if (temp.r != 1.f || temp.i != 0.f) {
- i__1 = *m;
- for (i__ = 1; i__ <= i__1; ++i__) {
- i__2 = i__ + k * b_dim1;
- i__3 = i__ + k * b_dim1;
- q__1.r = temp.r * b[i__3].r - temp.i * b[i__3].i,
- q__1.i = temp.r * b[i__3].i + temp.i * b[
- i__3].r;
- b[i__2].r = q__1.r, b[i__2].i = q__1.i;
-/* L310: */
- }
- }
-/* L320: */
- }
- }
- }
- }
-
- return 0;
-
-/* End of CTRMM . */
-
-} /* ctrmm_ */
-
-/* Subroutine */ int ctrmv_(char *uplo, char *trans, char *diag, integer *n,
- complex *a, integer *lda, complex *x, integer *incx, ftnlen uplo_len,
- ftnlen trans_len, ftnlen diag_len)
-{
- /* System generated locals */
- integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5;
- complex q__1, q__2, q__3;
-
- /* Builtin functions */
- void r_cnjg(complex *, complex *);
-
- /* Local variables */
- static integer i__, j, ix, jx, kx, info;
- static complex temp;
- extern logical lsame_(char *, char *, ftnlen, ftnlen);
- extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen);
- static logical noconj, nounit;
-
-/* .. Scalar Arguments .. */
-/* .. Array Arguments .. */
-/* .. */
-
-/* Purpose */
-/* ======= */
-
-/* CTRMV performs one of the matrix-vector operations */
-
-/* x := A*x, or x := A'*x, or x := conjg( A' )*x, */
-
-/* where x is an n element vector and A is an n by n unit, or non-unit, */
-/* upper or lower triangular matrix. */
-
-/* Parameters */
-/* ========== */
-
-/* UPLO - CHARACTER*1. */
-/* On entry, UPLO specifies whether the matrix is an upper or */
-/* lower triangular matrix as follows: */
-
-/* UPLO = 'U' or 'u' A is an upper triangular matrix. */
-
-/* UPLO = 'L' or 'l' A is a lower triangular matrix. */
-
-/* Unchanged on exit. */
-
-/* TRANS - CHARACTER*1. */
-/* On entry, TRANS specifies the operation to be performed as */
-/* follows: */
-
-/* TRANS = 'N' or 'n' x := A*x. */
-
-/* TRANS = 'T' or 't' x := A'*x. */
-
-/* TRANS = 'C' or 'c' x := conjg( A' )*x. */
-
-/* Unchanged on exit. */
-
-/* DIAG - CHARACTER*1. */
-/* On entry, DIAG specifies whether or not A is unit */
-/* triangular as follows: */
-
-/* DIAG = 'U' or 'u' A is assumed to be unit triangular. */
-
-/* DIAG = 'N' or 'n' A is not assumed to be unit */
-/* triangular. */
-
-/* Unchanged on exit. */
-
-/* N - INTEGER. */
-/* On entry, N specifies the order of the matrix A. */
-/* N must be at least zero. */
-/* Unchanged on exit. */
-
-/* A - COMPLEX array of DIMENSION ( LDA, n ). */
-/* Before entry with UPLO = 'U' or 'u', the leading n by n */
-/* upper triangular part of the array A must contain the upper */
-/* triangular matrix and the strictly lower triangular part of */
-/* A is not referenced. */
-/* Before entry with UPLO = 'L' or 'l', the leading n by n */
-/* lower triangular part of the array A must contain the lower */
-/* triangular matrix and the strictly upper triangular part of */
-/* A is not referenced. */
-/* Note that when DIAG = 'U' or 'u', the diagonal elements of */
-/* A are not referenced either, but are assumed to be unity. */
-/* Unchanged on exit. */
-
-/* LDA - INTEGER. */
-/* On entry, LDA specifies the first dimension of A as declared */
-/* in the calling (sub) program. LDA must be at least */
-/* max( 1, n ). */
-/* Unchanged on exit. */
-
-/* X - COMPLEX array of dimension at least */
-/* ( 1 + ( n - 1 )*abs( INCX ) ). */
-/* Before entry, the incremented array X must contain the n */
-/* element vector x. On exit, X is overwritten with the */
-/* tranformed vector x. */
-
-/* INCX - INTEGER. */
-/* On entry, INCX specifies the increment for the elements of */
-/* X. INCX must not be zero. */
-/* Unchanged on exit. */
-
-
-/* Level 2 Blas routine. */
-
-/* -- Written on 22-October-1986. */
-/* Jack Dongarra, Argonne National Lab. */
-/* Jeremy Du Croz, Nag Central Office. */
-/* Sven Hammarling, Nag Central Office. */
-/* Richard Hanson, Sandia National Labs. */
-
-
-/* .. Parameters .. */
-/* .. Local Scalars .. */
-/* .. External Functions .. */
-/* .. External Subroutines .. */
-/* .. Intrinsic Functions .. */
-/* .. */
-/* .. Executable Statements .. */
-
-/* Test the input parameters. */
-
- /* Parameter adjustments */
- a_dim1 = *lda;
- a_offset = 1 + a_dim1 * 1;
- a -= a_offset;
- --x;
-
- /* Function Body */
- info = 0;
- if (! lsame_(uplo, "U", (ftnlen)1, (ftnlen)1) && ! lsame_(uplo, "L", (
- ftnlen)1, (ftnlen)1)) {
- info = 1;
- } else if (! lsame_(trans, "N", (ftnlen)1, (ftnlen)1) && ! lsame_(trans,
- "T", (ftnlen)1, (ftnlen)1) && ! lsame_(trans, "C", (ftnlen)1, (
- ftnlen)1)) {
- info = 2;
- } else if (! lsame_(diag, "U", (ftnlen)1, (ftnlen)1) && ! lsame_(diag,
- "N", (ftnlen)1, (ftnlen)1)) {
- info = 3;
- } else if (*n < 0) {
- info = 4;
- } else if (*lda < max(1,*n)) {
- info = 6;
- } else if (*incx == 0) {
- info = 8;
- }
- if (info != 0) {
- xerbla_("CTRMV ", &info, (ftnlen)6);
- return 0;
- }
-
-/* Quick return if possible. */
-
- if (*n == 0) {
- return 0;
- }
-
- noconj = lsame_(trans, "T", (ftnlen)1, (ftnlen)1);
- nounit = lsame_(diag, "N", (ftnlen)1, (ftnlen)1);
-
-/* Set up the start point in X if the increment is not unity. This */
-/* will be ( N - 1 )*INCX too small for descending loops. */
-
- if (*incx <= 0) {
- kx = 1 - (*n - 1) * *incx;
- } else if (*incx != 1) {
- kx = 1;
- }
-
-/* Start the operations. In this version the elements of A are */
-/* accessed sequentially with one pass through A. */
-
- if (lsame_(trans, "N", (ftnlen)1, (ftnlen)1)) {
-
-/* Form x := A*x. */
-
- if (lsame_(uplo, "U", (ftnlen)1, (ftnlen)1)) {
- if (*incx == 1) {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- i__2 = j;
- if (x[i__2].r != 0.f || x[i__2].i != 0.f) {
- i__2 = j;
- temp.r = x[i__2].r, temp.i = x[i__2].i;
- i__2 = j - 1;
- for (i__ = 1; i__ <= i__2; ++i__) {
- i__3 = i__;
- i__4 = i__;
- i__5 = i__ + j * a_dim1;
- q__2.r = temp.r * a[i__5].r - temp.i * a[i__5].i,
- q__2.i = temp.r * a[i__5].i + temp.i * a[
- i__5].r;
- q__1.r = x[i__4].r + q__2.r, q__1.i = x[i__4].i +
- q__2.i;
- x[i__3].r = q__1.r, x[i__3].i = q__1.i;
-/* L10: */
- }
- if (nounit) {
- i__2 = j;
- i__3 = j;
- i__4 = j + j * a_dim1;
- q__1.r = x[i__3].r * a[i__4].r - x[i__3].i * a[
- i__4].i, q__1.i = x[i__3].r * a[i__4].i +
- x[i__3].i * a[i__4].r;
- x[i__2].r = q__1.r, x[i__2].i = q__1.i;
- }
- }
-/* L20: */
- }
- } else {
- jx = kx;
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- i__2 = jx;
- if (x[i__2].r != 0.f || x[i__2].i != 0.f) {
- i__2 = jx;
- temp.r = x[i__2].r, temp.i = x[i__2].i;
- ix = kx;
- i__2 = j - 1;
- for (i__ = 1; i__ <= i__2; ++i__) {
- i__3 = ix;
- i__4 = ix;
- i__5 = i__ + j * a_dim1;
- q__2.r = temp.r * a[i__5].r - temp.i * a[i__5].i,
- q__2.i = temp.r * a[i__5].i + temp.i * a[
- i__5].r;
- q__1.r = x[i__4].r + q__2.r, q__1.i = x[i__4].i +
- q__2.i;
- x[i__3].r = q__1.r, x[i__3].i = q__1.i;
- ix += *incx;
-/* L30: */
- }
- if (nounit) {
- i__2 = jx;
- i__3 = jx;
- i__4 = j + j * a_dim1;
- q__1.r = x[i__3].r * a[i__4].r - x[i__3].i * a[
- i__4].i, q__1.i = x[i__3].r * a[i__4].i +
- x[i__3].i * a[i__4].r;
- x[i__2].r = q__1.r, x[i__2].i = q__1.i;
- }
- }
- jx += *incx;
-/* L40: */
- }
- }
- } else {
- if (*incx == 1) {
- for (j = *n; j >= 1; --j) {
- i__1 = j;
- if (x[i__1].r != 0.f || x[i__1].i != 0.f) {
- i__1 = j;
- temp.r = x[i__1].r, temp.i = x[i__1].i;
- i__1 = j + 1;
- for (i__ = *n; i__ >= i__1; --i__) {
- i__2 = i__;
- i__3 = i__;
- i__4 = i__ + j * a_dim1;
- q__2.r = temp.r * a[i__4].r - temp.i * a[i__4].i,
- q__2.i = temp.r * a[i__4].i + temp.i * a[
- i__4].r;
- q__1.r = x[i__3].r + q__2.r, q__1.i = x[i__3].i +
- q__2.i;
- x[i__2].r = q__1.r, x[i__2].i = q__1.i;
-/* L50: */
- }
- if (nounit) {
- i__1 = j;
- i__2 = j;
- i__3 = j + j * a_dim1;
- q__1.r = x[i__2].r * a[i__3].r - x[i__2].i * a[
- i__3].i, q__1.i = x[i__2].r * a[i__3].i +
- x[i__2].i * a[i__3].r;
- x[i__1].r = q__1.r, x[i__1].i = q__1.i;
- }
- }
-/* L60: */
- }
- } else {
- kx += (*n - 1) * *incx;
- jx = kx;
- for (j = *n; j >= 1; --j) {
- i__1 = jx;
- if (x[i__1].r != 0.f || x[i__1].i != 0.f) {
- i__1 = jx;
- temp.r = x[i__1].r, temp.i = x[i__1].i;
- ix = kx;
- i__1 = j + 1;
- for (i__ = *n; i__ >= i__1; --i__) {
- i__2 = ix;
- i__3 = ix;
- i__4 = i__ + j * a_dim1;
- q__2.r = temp.r * a[i__4].r - temp.i * a[i__4].i,
- q__2.i = temp.r * a[i__4].i + temp.i * a[
- i__4].r;
- q__1.r = x[i__3].r + q__2.r, q__1.i = x[i__3].i +
- q__2.i;
- x[i__2].r = q__1.r, x[i__2].i = q__1.i;
- ix -= *incx;
-/* L70: */
- }
- if (nounit) {
- i__1 = jx;
- i__2 = jx;
- i__3 = j + j * a_dim1;
- q__1.r = x[i__2].r * a[i__3].r - x[i__2].i * a[
- i__3].i, q__1.i = x[i__2].r * a[i__3].i +
- x[i__2].i * a[i__3].r;
- x[i__1].r = q__1.r, x[i__1].i = q__1.i;
- }
- }
- jx -= *incx;
-/* L80: */
- }
- }
- }
- } else {
-
-/* Form x := A'*x or x := conjg( A' )*x. */
-
- if (lsame_(uplo, "U", (ftnlen)1, (ftnlen)1)) {
- if (*incx == 1) {
- for (j = *n; j >= 1; --j) {
- i__1 = j;
- temp.r = x[i__1].r, temp.i = x[i__1].i;
- if (noconj) {
- if (nounit) {
- i__1 = j + j * a_dim1;
- q__1.r = temp.r * a[i__1].r - temp.i * a[i__1].i,
- q__1.i = temp.r * a[i__1].i + temp.i * a[
- i__1].r;
- temp.r = q__1.r, temp.i = q__1.i;
- }
- for (i__ = j - 1; i__ >= 1; --i__) {
- i__1 = i__ + j * a_dim1;
- i__2 = i__;
- q__2.r = a[i__1].r * x[i__2].r - a[i__1].i * x[
- i__2].i, q__2.i = a[i__1].r * x[i__2].i +
- a[i__1].i * x[i__2].r;
- q__1.r = temp.r + q__2.r, q__1.i = temp.i +
- q__2.i;
- temp.r = q__1.r, temp.i = q__1.i;
-/* L90: */
- }
- } else {
- if (nounit) {
- r_cnjg(&q__2, &a[j + j * a_dim1]);
- q__1.r = temp.r * q__2.r - temp.i * q__2.i,
- q__1.i = temp.r * q__2.i + temp.i *
- q__2.r;
- temp.r = q__1.r, temp.i = q__1.i;
- }
- for (i__ = j - 1; i__ >= 1; --i__) {
- r_cnjg(&q__3, &a[i__ + j * a_dim1]);
- i__1 = i__;
- q__2.r = q__3.r * x[i__1].r - q__3.i * x[i__1].i,
- q__2.i = q__3.r * x[i__1].i + q__3.i * x[
- i__1].r;
- q__1.r = temp.r + q__2.r, q__1.i = temp.i +
- q__2.i;
- temp.r = q__1.r, temp.i = q__1.i;
-/* L100: */
- }
- }
- i__1 = j;
- x[i__1].r = temp.r, x[i__1].i = temp.i;
-/* L110: */
- }
- } else {
- jx = kx + (*n - 1) * *incx;
- for (j = *n; j >= 1; --j) {
- i__1 = jx;
- temp.r = x[i__1].r, temp.i = x[i__1].i;
- ix = jx;
- if (noconj) {
- if (nounit) {
- i__1 = j + j * a_dim1;
- q__1.r = temp.r * a[i__1].r - temp.i * a[i__1].i,
- q__1.i = temp.r * a[i__1].i + temp.i * a[
- i__1].r;
- temp.r = q__1.r, temp.i = q__1.i;
- }
- for (i__ = j - 1; i__ >= 1; --i__) {
- ix -= *incx;
- i__1 = i__ + j * a_dim1;
- i__2 = ix;
- q__2.r = a[i__1].r * x[i__2].r - a[i__1].i * x[
- i__2].i, q__2.i = a[i__1].r * x[i__2].i +
- a[i__1].i * x[i__2].r;
- q__1.r = temp.r + q__2.r, q__1.i = temp.i +
- q__2.i;
- temp.r = q__1.r, temp.i = q__1.i;
-/* L120: */
- }
- } else {
- if (nounit) {
- r_cnjg(&q__2, &a[j + j * a_dim1]);
- q__1.r = temp.r * q__2.r - temp.i * q__2.i,
- q__1.i = temp.r * q__2.i + temp.i *
- q__2.r;
- temp.r = q__1.r, temp.i = q__1.i;
- }
- for (i__ = j - 1; i__ >= 1; --i__) {
- ix -= *incx;
- r_cnjg(&q__3, &a[i__ + j * a_dim1]);
- i__1 = ix;
- q__2.r = q__3.r * x[i__1].r - q__3.i * x[i__1].i,
- q__2.i = q__3.r * x[i__1].i + q__3.i * x[
- i__1].r;
- q__1.r = temp.r + q__2.r, q__1.i = temp.i +
- q__2.i;
- temp.r = q__1.r, temp.i = q__1.i;
-/* L130: */
- }
- }
- i__1 = jx;
- x[i__1].r = temp.r, x[i__1].i = temp.i;
- jx -= *incx;
-/* L140: */
- }
- }
- } else {
- if (*incx == 1) {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- i__2 = j;
- temp.r = x[i__2].r, temp.i = x[i__2].i;
- if (noconj) {
- if (nounit) {
- i__2 = j + j * a_dim1;
- q__1.r = temp.r * a[i__2].r - temp.i * a[i__2].i,
- q__1.i = temp.r * a[i__2].i + temp.i * a[
- i__2].r;
- temp.r = q__1.r, temp.i = q__1.i;
- }
- i__2 = *n;
- for (i__ = j + 1; i__ <= i__2; ++i__) {
- i__3 = i__ + j * a_dim1;
- i__4 = i__;
- q__2.r = a[i__3].r * x[i__4].r - a[i__3].i * x[
- i__4].i, q__2.i = a[i__3].r * x[i__4].i +
- a[i__3].i * x[i__4].r;
- q__1.r = temp.r + q__2.r, q__1.i = temp.i +
- q__2.i;
- temp.r = q__1.r, temp.i = q__1.i;
-/* L150: */
- }
- } else {
- if (nounit) {
- r_cnjg(&q__2, &a[j + j * a_dim1]);
- q__1.r = temp.r * q__2.r - temp.i * q__2.i,
- q__1.i = temp.r * q__2.i + temp.i *
- q__2.r;
- temp.r = q__1.r, temp.i = q__1.i;
- }
- i__2 = *n;
- for (i__ = j + 1; i__ <= i__2; ++i__) {
- r_cnjg(&q__3, &a[i__ + j * a_dim1]);
- i__3 = i__;
- q__2.r = q__3.r * x[i__3].r - q__3.i * x[i__3].i,
- q__2.i = q__3.r * x[i__3].i + q__3.i * x[
- i__3].r;
- q__1.r = temp.r + q__2.r, q__1.i = temp.i +
- q__2.i;
- temp.r = q__1.r, temp.i = q__1.i;
-/* L160: */
- }
- }
- i__2 = j;
- x[i__2].r = temp.r, x[i__2].i = temp.i;
-/* L170: */
- }
- } else {
- jx = kx;
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- i__2 = jx;
- temp.r = x[i__2].r, temp.i = x[i__2].i;
- ix = jx;
- if (noconj) {
- if (nounit) {
- i__2 = j + j * a_dim1;
- q__1.r = temp.r * a[i__2].r - temp.i * a[i__2].i,
- q__1.i = temp.r * a[i__2].i + temp.i * a[
- i__2].r;
- temp.r = q__1.r, temp.i = q__1.i;
- }
- i__2 = *n;
- for (i__ = j + 1; i__ <= i__2; ++i__) {
- ix += *incx;
- i__3 = i__ + j * a_dim1;
- i__4 = ix;
- q__2.r = a[i__3].r * x[i__4].r - a[i__3].i * x[
- i__4].i, q__2.i = a[i__3].r * x[i__4].i +
- a[i__3].i * x[i__4].r;
- q__1.r = temp.r + q__2.r, q__1.i = temp.i +
- q__2.i;
- temp.r = q__1.r, temp.i = q__1.i;
-/* L180: */
- }
- } else {
- if (nounit) {
- r_cnjg(&q__2, &a[j + j * a_dim1]);
- q__1.r = temp.r * q__2.r - temp.i * q__2.i,
- q__1.i = temp.r * q__2.i + temp.i *
- q__2.r;
- temp.r = q__1.r, temp.i = q__1.i;
- }
- i__2 = *n;
- for (i__ = j + 1; i__ <= i__2; ++i__) {
- ix += *incx;
- r_cnjg(&q__3, &a[i__ + j * a_dim1]);
- i__3 = ix;
- q__2.r = q__3.r * x[i__3].r - q__3.i * x[i__3].i,
- q__2.i = q__3.r * x[i__3].i + q__3.i * x[
- i__3].r;
- q__1.r = temp.r + q__2.r, q__1.i = temp.i +
- q__2.i;
- temp.r = q__1.r, temp.i = q__1.i;
-/* L190: */
- }
- }
- i__2 = jx;
- x[i__2].r = temp.r, x[i__2].i = temp.i;
- jx += *incx;
-/* L200: */
- }
- }
- }
- }
-
- return 0;
-
-/* End of CTRMV . */
-
-} /* ctrmv_ */
-
-/* Subroutine */ int ctrsm_(char *side, char *uplo, char *transa, char *diag,
- integer *m, integer *n, complex *alpha, complex *a, integer *lda,
- complex *b, integer *ldb, ftnlen side_len, ftnlen uplo_len, ftnlen
- transa_len, ftnlen diag_len)
-{
- /* System generated locals */
- integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2, i__3, i__4, i__5,
- i__6, i__7;
- complex q__1, q__2, q__3;
-
- /* Builtin functions */
- void c_div(complex *, complex *, complex *), r_cnjg(complex *, complex *);
-
- /* Local variables */
- static integer i__, j, k, info;
- static complex temp;
- extern logical lsame_(char *, char *, ftnlen, ftnlen);
- static logical lside;
- static integer nrowa;
- static logical upper;
- extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen);
- static logical noconj, nounit;
-
-/* .. Scalar Arguments .. */
-/* .. Array Arguments .. */
-/* .. */
-
-/* Purpose */
-/* ======= */
-
-/* CTRSM solves one of the matrix equations */
-
-/* op( A )*X = alpha*B, or X*op( A ) = alpha*B, */
-
-/* where alpha is a scalar, X and B are m by n matrices, A is a unit, or */
-/* non-unit, upper or lower triangular matrix and op( A ) is one of */
-
-/* op( A ) = A or op( A ) = A' or op( A ) = conjg( A' ). */
-
-/* The matrix X is overwritten on B. */
-
-/* Parameters */
-/* ========== */
-
-/* SIDE - CHARACTER*1. */
-/* On entry, SIDE specifies whether op( A ) appears on the left */
-/* or right of X as follows: */
-
-/* SIDE = 'L' or 'l' op( A )*X = alpha*B. */
-
-/* SIDE = 'R' or 'r' X*op( A ) = alpha*B. */
-
-/* Unchanged on exit. */
-
-/* UPLO - CHARACTER*1. */
-/* On entry, UPLO specifies whether the matrix A is an upper or */
-/* lower triangular matrix as follows: */
-
-/* UPLO = 'U' or 'u' A is an upper triangular matrix. */
-
-/* UPLO = 'L' or 'l' A is a lower triangular matrix. */
-
-/* Unchanged on exit. */
-
-/* TRANSA - CHARACTER*1. */
-/* On entry, TRANSA specifies the form of op( A ) to be used in */
-/* the matrix multiplication as follows: */
-
-/* TRANSA = 'N' or 'n' op( A ) = A. */
-
-/* TRANSA = 'T' or 't' op( A ) = A'. */
-
-/* TRANSA = 'C' or 'c' op( A ) = conjg( A' ). */
-
-/* Unchanged on exit. */
-
-/* DIAG - CHARACTER*1. */
-/* On entry, DIAG specifies whether or not A is unit triangular */
-/* as follows: */
-
-/* DIAG = 'U' or 'u' A is assumed to be unit triangular. */
-
-/* DIAG = 'N' or 'n' A is not assumed to be unit */
-/* triangular. */
-
-/* Unchanged on exit. */
-
-/* M - INTEGER. */
-/* On entry, M specifies the number of rows of B. M must be at */
-/* least zero. */
-/* Unchanged on exit. */
-
-/* N - INTEGER. */
-/* On entry, N specifies the number of columns of B. N must be */
-/* at least zero. */
-/* Unchanged on exit. */
-
-/* ALPHA - COMPLEX . */
-/* On entry, ALPHA specifies the scalar alpha. When alpha is */
-/* zero then A is not referenced and B need not be set before */
-/* entry. */
-/* Unchanged on exit. */
-
-/* A - COMPLEX array of DIMENSION ( LDA, k ), where k is m */
-/* when SIDE = 'L' or 'l' and is n when SIDE = 'R' or 'r'. */
-/* Before entry with UPLO = 'U' or 'u', the leading k by k */
-/* upper triangular part of the array A must contain the upper */
-/* triangular matrix and the strictly lower triangular part of */
-/* A is not referenced. */
-/* Before entry with UPLO = 'L' or 'l', the leading k by k */
-/* lower triangular part of the array A must contain the lower */
-/* triangular matrix and the strictly upper triangular part of */
-/* A is not referenced. */
-/* Note that when DIAG = 'U' or 'u', the diagonal elements of */
-/* A are not referenced either, but are assumed to be unity. */
-/* Unchanged on exit. */
-
-/* LDA - INTEGER. */
-/* On entry, LDA specifies the first dimension of A as declared */
-/* in the calling (sub) program. When SIDE = 'L' or 'l' then */
-/* LDA must be at least max( 1, m ), when SIDE = 'R' or 'r' */
-/* then LDA must be at least max( 1, n ). */
-/* Unchanged on exit. */
-
-/* B - COMPLEX array of DIMENSION ( LDB, n ). */
-/* Before entry, the leading m by n part of the array B must */
-/* contain the right-hand side matrix B, and on exit is */
-/* overwritten by the solution matrix X. */
-
-/* LDB - INTEGER. */
-/* On entry, LDB specifies the first dimension of B as declared */
-/* in the calling (sub) program. LDB must be at least */
-/* max( 1, m ). */
-/* Unchanged on exit. */
-
-
-/* Level 3 Blas routine. */
-
-/* -- Written on 8-February-1989. */
-/* Jack Dongarra, Argonne National Laboratory. */
-/* Iain Duff, AERE Harwell. */
-/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */
-/* Sven Hammarling, Numerical Algorithms Group Ltd. */
-
-
-/* .. External Functions .. */
-/* .. External Subroutines .. */
-/* .. Intrinsic Functions .. */
-/* .. Local Scalars .. */
-/* .. Parameters .. */
-/* .. */
-/* .. Executable Statements .. */
-
-/* Test the input parameters. */
-
- /* Parameter adjustments */
- a_dim1 = *lda;
- a_offset = 1 + a_dim1 * 1;
- a -= a_offset;
- b_dim1 = *ldb;
- b_offset = 1 + b_dim1 * 1;
- b -= b_offset;
-
- /* Function Body */
- lside = lsame_(side, "L", (ftnlen)1, (ftnlen)1);
- if (lside) {
- nrowa = *m;
- } else {
- nrowa = *n;
- }
- noconj = lsame_(transa, "T", (ftnlen)1, (ftnlen)1);
- nounit = lsame_(diag, "N", (ftnlen)1, (ftnlen)1);
- upper = lsame_(uplo, "U", (ftnlen)1, (ftnlen)1);
-
- info = 0;
- if (! lside && ! lsame_(side, "R", (ftnlen)1, (ftnlen)1)) {
- info = 1;
- } else if (! upper && ! lsame_(uplo, "L", (ftnlen)1, (ftnlen)1)) {
- info = 2;
- } else if (! lsame_(transa, "N", (ftnlen)1, (ftnlen)1) && ! lsame_(transa,
- "T", (ftnlen)1, (ftnlen)1) && ! lsame_(transa, "C", (ftnlen)1, (
- ftnlen)1)) {
- info = 3;
- } else if (! lsame_(diag, "U", (ftnlen)1, (ftnlen)1) && ! lsame_(diag,
- "N", (ftnlen)1, (ftnlen)1)) {
- info = 4;
- } else if (*m < 0) {
- info = 5;
- } else if (*n < 0) {
- info = 6;
- } else if (*lda < max(1,nrowa)) {
- info = 9;
- } else if (*ldb < max(1,*m)) {
- info = 11;
- }
- if (info != 0) {
- xerbla_("CTRSM ", &info, (ftnlen)6);
- return 0;
- }
-
-/* Quick return if possible. */
-
- if (*n == 0) {
- return 0;
- }
-
-/* And when alpha.eq.zero. */
-
- if (alpha->r == 0.f && alpha->i == 0.f) {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- i__2 = *m;
- for (i__ = 1; i__ <= i__2; ++i__) {
- i__3 = i__ + j * b_dim1;
- b[i__3].r = 0.f, b[i__3].i = 0.f;
-/* L10: */
- }
-/* L20: */
- }
- return 0;
- }
-
-/* Start the operations. */
-
- if (lside) {
- if (lsame_(transa, "N", (ftnlen)1, (ftnlen)1)) {
-
-/* Form B := alpha*inv( A )*B. */
-
- if (upper) {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- if (alpha->r != 1.f || alpha->i != 0.f) {
- i__2 = *m;
- for (i__ = 1; i__ <= i__2; ++i__) {
- i__3 = i__ + j * b_dim1;
- i__4 = i__ + j * b_dim1;
- q__1.r = alpha->r * b[i__4].r - alpha->i * b[i__4]
- .i, q__1.i = alpha->r * b[i__4].i +
- alpha->i * b[i__4].r;
- b[i__3].r = q__1.r, b[i__3].i = q__1.i;
-/* L30: */
- }
- }
- for (k = *m; k >= 1; --k) {
- i__2 = k + j * b_dim1;
- if (b[i__2].r != 0.f || b[i__2].i != 0.f) {
- if (nounit) {
- i__2 = k + j * b_dim1;
- c_div(&q__1, &b[k + j * b_dim1], &a[k + k *
- a_dim1]);
- b[i__2].r = q__1.r, b[i__2].i = q__1.i;
- }
- i__2 = k - 1;
- for (i__ = 1; i__ <= i__2; ++i__) {
- i__3 = i__ + j * b_dim1;
- i__4 = i__ + j * b_dim1;
- i__5 = k + j * b_dim1;
- i__6 = i__ + k * a_dim1;
- q__2.r = b[i__5].r * a[i__6].r - b[i__5].i *
- a[i__6].i, q__2.i = b[i__5].r * a[
- i__6].i + b[i__5].i * a[i__6].r;
- q__1.r = b[i__4].r - q__2.r, q__1.i = b[i__4]
- .i - q__2.i;
- b[i__3].r = q__1.r, b[i__3].i = q__1.i;
-/* L40: */
- }
- }
-/* L50: */
- }
-/* L60: */
- }
- } else {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- if (alpha->r != 1.f || alpha->i != 0.f) {
- i__2 = *m;
- for (i__ = 1; i__ <= i__2; ++i__) {
- i__3 = i__ + j * b_dim1;
- i__4 = i__ + j * b_dim1;
- q__1.r = alpha->r * b[i__4].r - alpha->i * b[i__4]
- .i, q__1.i = alpha->r * b[i__4].i +
- alpha->i * b[i__4].r;
- b[i__3].r = q__1.r, b[i__3].i = q__1.i;
-/* L70: */
- }
- }
- i__2 = *m;
- for (k = 1; k <= i__2; ++k) {
- i__3 = k + j * b_dim1;
- if (b[i__3].r != 0.f || b[i__3].i != 0.f) {
- if (nounit) {
- i__3 = k + j * b_dim1;
- c_div(&q__1, &b[k + j * b_dim1], &a[k + k *
- a_dim1]);
- b[i__3].r = q__1.r, b[i__3].i = q__1.i;
- }
- i__3 = *m;
- for (i__ = k + 1; i__ <= i__3; ++i__) {
- i__4 = i__ + j * b_dim1;
- i__5 = i__ + j * b_dim1;
- i__6 = k + j * b_dim1;
- i__7 = i__ + k * a_dim1;
- q__2.r = b[i__6].r * a[i__7].r - b[i__6].i *
- a[i__7].i, q__2.i = b[i__6].r * a[
- i__7].i + b[i__6].i * a[i__7].r;
- q__1.r = b[i__5].r - q__2.r, q__1.i = b[i__5]
- .i - q__2.i;
- b[i__4].r = q__1.r, b[i__4].i = q__1.i;
-/* L80: */
- }
- }
-/* L90: */
- }
-/* L100: */
- }
- }
- } else {
-
-/* Form B := alpha*inv( A' )*B */
-/* or B := alpha*inv( conjg( A' ) )*B. */
-
- if (upper) {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- i__2 = *m;
- for (i__ = 1; i__ <= i__2; ++i__) {
- i__3 = i__ + j * b_dim1;
- q__1.r = alpha->r * b[i__3].r - alpha->i * b[i__3].i,
- q__1.i = alpha->r * b[i__3].i + alpha->i * b[
- i__3].r;
- temp.r = q__1.r, temp.i = q__1.i;
- if (noconj) {
- i__3 = i__ - 1;
- for (k = 1; k <= i__3; ++k) {
- i__4 = k + i__ * a_dim1;
- i__5 = k + j * b_dim1;
- q__2.r = a[i__4].r * b[i__5].r - a[i__4].i *
- b[i__5].i, q__2.i = a[i__4].r * b[
- i__5].i + a[i__4].i * b[i__5].r;
- q__1.r = temp.r - q__2.r, q__1.i = temp.i -
- q__2.i;
- temp.r = q__1.r, temp.i = q__1.i;
-/* L110: */
- }
- if (nounit) {
- c_div(&q__1, &temp, &a[i__ + i__ * a_dim1]);
- temp.r = q__1.r, temp.i = q__1.i;
- }
- } else {
- i__3 = i__ - 1;
- for (k = 1; k <= i__3; ++k) {
- r_cnjg(&q__3, &a[k + i__ * a_dim1]);
- i__4 = k + j * b_dim1;
- q__2.r = q__3.r * b[i__4].r - q__3.i * b[i__4]
- .i, q__2.i = q__3.r * b[i__4].i +
- q__3.i * b[i__4].r;
- q__1.r = temp.r - q__2.r, q__1.i = temp.i -
- q__2.i;
- temp.r = q__1.r, temp.i = q__1.i;
-/* L120: */
- }
- if (nounit) {
- r_cnjg(&q__2, &a[i__ + i__ * a_dim1]);
- c_div(&q__1, &temp, &q__2);
- temp.r = q__1.r, temp.i = q__1.i;
- }
- }
- i__3 = i__ + j * b_dim1;
- b[i__3].r = temp.r, b[i__3].i = temp.i;
-/* L130: */
- }
-/* L140: */
- }
- } else {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- for (i__ = *m; i__ >= 1; --i__) {
- i__2 = i__ + j * b_dim1;
- q__1.r = alpha->r * b[i__2].r - alpha->i * b[i__2].i,
- q__1.i = alpha->r * b[i__2].i + alpha->i * b[
- i__2].r;
- temp.r = q__1.r, temp.i = q__1.i;
- if (noconj) {
- i__2 = *m;
- for (k = i__ + 1; k <= i__2; ++k) {
- i__3 = k + i__ * a_dim1;
- i__4 = k + j * b_dim1;
- q__2.r = a[i__3].r * b[i__4].r - a[i__3].i *
- b[i__4].i, q__2.i = a[i__3].r * b[
- i__4].i + a[i__3].i * b[i__4].r;
- q__1.r = temp.r - q__2.r, q__1.i = temp.i -
- q__2.i;
- temp.r = q__1.r, temp.i = q__1.i;
-/* L150: */
- }
- if (nounit) {
- c_div(&q__1, &temp, &a[i__ + i__ * a_dim1]);
- temp.r = q__1.r, temp.i = q__1.i;
- }
- } else {
- i__2 = *m;
- for (k = i__ + 1; k <= i__2; ++k) {
- r_cnjg(&q__3, &a[k + i__ * a_dim1]);
- i__3 = k + j * b_dim1;
- q__2.r = q__3.r * b[i__3].r - q__3.i * b[i__3]
- .i, q__2.i = q__3.r * b[i__3].i +
- q__3.i * b[i__3].r;
- q__1.r = temp.r - q__2.r, q__1.i = temp.i -
- q__2.i;
- temp.r = q__1.r, temp.i = q__1.i;
-/* L160: */
- }
- if (nounit) {
- r_cnjg(&q__2, &a[i__ + i__ * a_dim1]);
- c_div(&q__1, &temp, &q__2);
- temp.r = q__1.r, temp.i = q__1.i;
- }
- }
- i__2 = i__ + j * b_dim1;
- b[i__2].r = temp.r, b[i__2].i = temp.i;
-/* L170: */
- }
-/* L180: */
- }
- }
- }
- } else {
- if (lsame_(transa, "N", (ftnlen)1, (ftnlen)1)) {
-
-/* Form B := alpha*B*inv( A ). */
-
- if (upper) {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- if (alpha->r != 1.f || alpha->i != 0.f) {
- i__2 = *m;
- for (i__ = 1; i__ <= i__2; ++i__) {
- i__3 = i__ + j * b_dim1;
- i__4 = i__ + j * b_dim1;
- q__1.r = alpha->r * b[i__4].r - alpha->i * b[i__4]
- .i, q__1.i = alpha->r * b[i__4].i +
- alpha->i * b[i__4].r;
- b[i__3].r = q__1.r, b[i__3].i = q__1.i;
-/* L190: */
- }
- }
- i__2 = j - 1;
- for (k = 1; k <= i__2; ++k) {
- i__3 = k + j * a_dim1;
- if (a[i__3].r != 0.f || a[i__3].i != 0.f) {
- i__3 = *m;
- for (i__ = 1; i__ <= i__3; ++i__) {
- i__4 = i__ + j * b_dim1;
- i__5 = i__ + j * b_dim1;
- i__6 = k + j * a_dim1;
- i__7 = i__ + k * b_dim1;
- q__2.r = a[i__6].r * b[i__7].r - a[i__6].i *
- b[i__7].i, q__2.i = a[i__6].r * b[
- i__7].i + a[i__6].i * b[i__7].r;
- q__1.r = b[i__5].r - q__2.r, q__1.i = b[i__5]
- .i - q__2.i;
- b[i__4].r = q__1.r, b[i__4].i = q__1.i;
-/* L200: */
- }
- }
-/* L210: */
- }
- if (nounit) {
- c_div(&q__1, &c_b21, &a[j + j * a_dim1]);
- temp.r = q__1.r, temp.i = q__1.i;
- i__2 = *m;
- for (i__ = 1; i__ <= i__2; ++i__) {
- i__3 = i__ + j * b_dim1;
- i__4 = i__ + j * b_dim1;
- q__1.r = temp.r * b[i__4].r - temp.i * b[i__4].i,
- q__1.i = temp.r * b[i__4].i + temp.i * b[
- i__4].r;
- b[i__3].r = q__1.r, b[i__3].i = q__1.i;
-/* L220: */
- }
- }
-/* L230: */
- }
- } else {
- for (j = *n; j >= 1; --j) {
- if (alpha->r != 1.f || alpha->i != 0.f) {
- i__1 = *m;
- for (i__ = 1; i__ <= i__1; ++i__) {
- i__2 = i__ + j * b_dim1;
- i__3 = i__ + j * b_dim1;
- q__1.r = alpha->r * b[i__3].r - alpha->i * b[i__3]
- .i, q__1.i = alpha->r * b[i__3].i +
- alpha->i * b[i__3].r;
- b[i__2].r = q__1.r, b[i__2].i = q__1.i;
-/* L240: */
- }
- }
- i__1 = *n;
- for (k = j + 1; k <= i__1; ++k) {
- i__2 = k + j * a_dim1;
- if (a[i__2].r != 0.f || a[i__2].i != 0.f) {
- i__2 = *m;
- for (i__ = 1; i__ <= i__2; ++i__) {
- i__3 = i__ + j * b_dim1;
- i__4 = i__ + j * b_dim1;
- i__5 = k + j * a_dim1;
- i__6 = i__ + k * b_dim1;
- q__2.r = a[i__5].r * b[i__6].r - a[i__5].i *
- b[i__6].i, q__2.i = a[i__5].r * b[
- i__6].i + a[i__5].i * b[i__6].r;
- q__1.r = b[i__4].r - q__2.r, q__1.i = b[i__4]
- .i - q__2.i;
- b[i__3].r = q__1.r, b[i__3].i = q__1.i;
-/* L250: */
- }
- }
-/* L260: */
- }
- if (nounit) {
- c_div(&q__1, &c_b21, &a[j + j * a_dim1]);
- temp.r = q__1.r, temp.i = q__1.i;
- i__1 = *m;
- for (i__ = 1; i__ <= i__1; ++i__) {
- i__2 = i__ + j * b_dim1;
- i__3 = i__ + j * b_dim1;
- q__1.r = temp.r * b[i__3].r - temp.i * b[i__3].i,
- q__1.i = temp.r * b[i__3].i + temp.i * b[
- i__3].r;
- b[i__2].r = q__1.r, b[i__2].i = q__1.i;
-/* L270: */
- }
- }
-/* L280: */
- }
- }
- } else {
-
-/* Form B := alpha*B*inv( A' ) */
-/* or B := alpha*B*inv( conjg( A' ) ). */
-
- if (upper) {
- for (k = *n; k >= 1; --k) {
- if (nounit) {
- if (noconj) {
- c_div(&q__1, &c_b21, &a[k + k * a_dim1]);
- temp.r = q__1.r, temp.i = q__1.i;
- } else {
- r_cnjg(&q__2, &a[k + k * a_dim1]);
- c_div(&q__1, &c_b21, &q__2);
- temp.r = q__1.r, temp.i = q__1.i;
- }
- i__1 = *m;
- for (i__ = 1; i__ <= i__1; ++i__) {
- i__2 = i__ + k * b_dim1;
- i__3 = i__ + k * b_dim1;
- q__1.r = temp.r * b[i__3].r - temp.i * b[i__3].i,
- q__1.i = temp.r * b[i__3].i + temp.i * b[
- i__3].r;
- b[i__2].r = q__1.r, b[i__2].i = q__1.i;
-/* L290: */
- }
- }
- i__1 = k - 1;
- for (j = 1; j <= i__1; ++j) {
- i__2 = j + k * a_dim1;
- if (a[i__2].r != 0.f || a[i__2].i != 0.f) {
- if (noconj) {
- i__2 = j + k * a_dim1;
- temp.r = a[i__2].r, temp.i = a[i__2].i;
- } else {
- r_cnjg(&q__1, &a[j + k * a_dim1]);
- temp.r = q__1.r, temp.i = q__1.i;
- }
- i__2 = *m;
- for (i__ = 1; i__ <= i__2; ++i__) {
- i__3 = i__ + j * b_dim1;
- i__4 = i__ + j * b_dim1;
- i__5 = i__ + k * b_dim1;
- q__2.r = temp.r * b[i__5].r - temp.i * b[i__5]
- .i, q__2.i = temp.r * b[i__5].i +
- temp.i * b[i__5].r;
- q__1.r = b[i__4].r - q__2.r, q__1.i = b[i__4]
- .i - q__2.i;
- b[i__3].r = q__1.r, b[i__3].i = q__1.i;
-/* L300: */
- }
- }
-/* L310: */
- }
- if (alpha->r != 1.f || alpha->i != 0.f) {
- i__1 = *m;
- for (i__ = 1; i__ <= i__1; ++i__) {
- i__2 = i__ + k * b_dim1;
- i__3 = i__ + k * b_dim1;
- q__1.r = alpha->r * b[i__3].r - alpha->i * b[i__3]
- .i, q__1.i = alpha->r * b[i__3].i +
- alpha->i * b[i__3].r;
- b[i__2].r = q__1.r, b[i__2].i = q__1.i;
-/* L320: */
- }
- }
-/* L330: */
- }
- } else {
- i__1 = *n;
- for (k = 1; k <= i__1; ++k) {
- if (nounit) {
- if (noconj) {
- c_div(&q__1, &c_b21, &a[k + k * a_dim1]);
- temp.r = q__1.r, temp.i = q__1.i;
- } else {
- r_cnjg(&q__2, &a[k + k * a_dim1]);
- c_div(&q__1, &c_b21, &q__2);
- temp.r = q__1.r, temp.i = q__1.i;
- }
- i__2 = *m;
- for (i__ = 1; i__ <= i__2; ++i__) {
- i__3 = i__ + k * b_dim1;
- i__4 = i__ + k * b_dim1;
- q__1.r = temp.r * b[i__4].r - temp.i * b[i__4].i,
- q__1.i = temp.r * b[i__4].i + temp.i * b[
- i__4].r;
- b[i__3].r = q__1.r, b[i__3].i = q__1.i;
-/* L340: */
- }
- }
- i__2 = *n;
- for (j = k + 1; j <= i__2; ++j) {
- i__3 = j + k * a_dim1;
- if (a[i__3].r != 0.f || a[i__3].i != 0.f) {
- if (noconj) {
- i__3 = j + k * a_dim1;
- temp.r = a[i__3].r, temp.i = a[i__3].i;
- } else {
- r_cnjg(&q__1, &a[j + k * a_dim1]);
- temp.r = q__1.r, temp.i = q__1.i;
- }
- i__3 = *m;
- for (i__ = 1; i__ <= i__3; ++i__) {
- i__4 = i__ + j * b_dim1;
- i__5 = i__ + j * b_dim1;
- i__6 = i__ + k * b_dim1;
- q__2.r = temp.r * b[i__6].r - temp.i * b[i__6]
- .i, q__2.i = temp.r * b[i__6].i +
- temp.i * b[i__6].r;
- q__1.r = b[i__5].r - q__2.r, q__1.i = b[i__5]
- .i - q__2.i;
- b[i__4].r = q__1.r, b[i__4].i = q__1.i;
-/* L350: */
- }
- }
-/* L360: */
- }
- if (alpha->r != 1.f || alpha->i != 0.f) {
- i__2 = *m;
- for (i__ = 1; i__ <= i__2; ++i__) {
- i__3 = i__ + k * b_dim1;
- i__4 = i__ + k * b_dim1;
- q__1.r = alpha->r * b[i__4].r - alpha->i * b[i__4]
- .i, q__1.i = alpha->r * b[i__4].i +
- alpha->i * b[i__4].r;
- b[i__3].r = q__1.r, b[i__3].i = q__1.i;
-/* L370: */
- }
- }
-/* L380: */
- }
- }
- }
- }
-
- return 0;
-
-/* End of CTRSM . */
-
-} /* ctrsm_ */
-
-/* Subroutine */ int ctrsv_(char *uplo, char *trans, char *diag, integer *n,
- complex *a, integer *lda, complex *x, integer *incx, ftnlen uplo_len,
- ftnlen trans_len, ftnlen diag_len)
-{
- /* System generated locals */
- integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5;
- complex q__1, q__2, q__3;
-
- /* Builtin functions */
- void c_div(complex *, complex *, complex *), r_cnjg(complex *, complex *);
-
- /* Local variables */
- static integer i__, j, ix, jx, kx, info;
- static complex temp;
- extern logical lsame_(char *, char *, ftnlen, ftnlen);
- extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen);
- static logical noconj, nounit;
-
-/* .. Scalar Arguments .. */
-/* .. Array Arguments .. */
-/* .. */
-
-/* Purpose */
-/* ======= */
-
-/* CTRSV solves one of the systems of equations */
-
-/* A*x = b, or A'*x = b, or conjg( A' )*x = b, */
-
-/* where b and x are n element vectors and A is an n by n unit, or */
-/* non-unit, upper or lower triangular matrix. */
-
-/* No test for singularity or near-singularity is included in this */
-/* routine. Such tests must be performed before calling this routine. */
-
-/* Parameters */
-/* ========== */
-
-/* UPLO - CHARACTER*1. */
-/* On entry, UPLO specifies whether the matrix is an upper or */
-/* lower triangular matrix as follows: */
-
-/* UPLO = 'U' or 'u' A is an upper triangular matrix. */
-
-/* UPLO = 'L' or 'l' A is a lower triangular matrix. */
-
-/* Unchanged on exit. */
-
-/* TRANS - CHARACTER*1. */
-/* On entry, TRANS specifies the equations to be solved as */
-/* follows: */
-
-/* TRANS = 'N' or 'n' A*x = b. */
-
-/* TRANS = 'T' or 't' A'*x = b. */
-
-/* TRANS = 'C' or 'c' conjg( A' )*x = b. */
-
-/* Unchanged on exit. */
-
-/* DIAG - CHARACTER*1. */
-/* On entry, DIAG specifies whether or not A is unit */
-/* triangular as follows: */
-
-/* DIAG = 'U' or 'u' A is assumed to be unit triangular. */
-
-/* DIAG = 'N' or 'n' A is not assumed to be unit */
-/* triangular. */
-
-/* Unchanged on exit. */
-
-/* N - INTEGER. */
-/* On entry, N specifies the order of the matrix A. */
-/* N must be at least zero. */
-/* Unchanged on exit. */
-
-/* A - COMPLEX array of DIMENSION ( LDA, n ). */
-/* Before entry with UPLO = 'U' or 'u', the leading n by n */
-/* upper triangular part of the array A must contain the upper */
-/* triangular matrix and the strictly lower triangular part of */
-/* A is not referenced. */
-/* Before entry with UPLO = 'L' or 'l', the leading n by n */
-/* lower triangular part of the array A must contain the lower */
-/* triangular matrix and the strictly upper triangular part of */
-/* A is not referenced. */
-/* Note that when DIAG = 'U' or 'u', the diagonal elements of */
-/* A are not referenced either, but are assumed to be unity. */
-/* Unchanged on exit. */
-
-/* LDA - INTEGER. */
-/* On entry, LDA specifies the first dimension of A as declared */
-/* in the calling (sub) program. LDA must be at least */
-/* max( 1, n ). */
-/* Unchanged on exit. */
-
-/* X - COMPLEX array of dimension at least */
-/* ( 1 + ( n - 1 )*abs( INCX ) ). */
-/* Before entry, the incremented array X must contain the n */
-/* element right-hand side vector b. On exit, X is overwritten */
-/* with the solution vector x. */
-
-/* INCX - INTEGER. */
-/* On entry, INCX specifies the increment for the elements of */
-/* X. INCX must not be zero. */
-/* Unchanged on exit. */
-
-
-/* Level 2 Blas routine. */
-
-/* -- Written on 22-October-1986. */
-/* Jack Dongarra, Argonne National Lab. */
-/* Jeremy Du Croz, Nag Central Office. */
-/* Sven Hammarling, Nag Central Office. */
-/* Richard Hanson, Sandia National Labs. */
-
-
-/* .. Parameters .. */
-/* .. Local Scalars .. */
-/* .. External Functions .. */
-/* .. External Subroutines .. */
-/* .. Intrinsic Functions .. */
-/* .. */
-/* .. Executable Statements .. */
-
-/* Test the input parameters. */
-
- /* Parameter adjustments */
- a_dim1 = *lda;
- a_offset = 1 + a_dim1 * 1;
- a -= a_offset;
- --x;
-
- /* Function Body */
- info = 0;
- if (! lsame_(uplo, "U", (ftnlen)1, (ftnlen)1) && ! lsame_(uplo, "L", (
- ftnlen)1, (ftnlen)1)) {
- info = 1;
- } else if (! lsame_(trans, "N", (ftnlen)1, (ftnlen)1) && ! lsame_(trans,
- "T", (ftnlen)1, (ftnlen)1) && ! lsame_(trans, "C", (ftnlen)1, (
- ftnlen)1)) {
- info = 2;
- } else if (! lsame_(diag, "U", (ftnlen)1, (ftnlen)1) && ! lsame_(diag,
- "N", (ftnlen)1, (ftnlen)1)) {
- info = 3;
- } else if (*n < 0) {
- info = 4;
- } else if (*lda < max(1,*n)) {
- info = 6;
- } else if (*incx == 0) {
- info = 8;
- }
- if (info != 0) {
- xerbla_("CTRSV ", &info, (ftnlen)6);
- return 0;
- }
-
-/* Quick return if possible. */
-
- if (*n == 0) {
- return 0;
- }
-
- noconj = lsame_(trans, "T", (ftnlen)1, (ftnlen)1);
- nounit = lsame_(diag, "N", (ftnlen)1, (ftnlen)1);
-
-/* Set up the start point in X if the increment is not unity. This */
-/* will be ( N - 1 )*INCX too small for descending loops. */
-
- if (*incx <= 0) {
- kx = 1 - (*n - 1) * *incx;
- } else if (*incx != 1) {
- kx = 1;
- }
-
-/* Start the operations. In this version the elements of A are */
-/* accessed sequentially with one pass through A. */
-
- if (lsame_(trans, "N", (ftnlen)1, (ftnlen)1)) {
-
-/* Form x := inv( A )*x. */
-
- if (lsame_(uplo, "U", (ftnlen)1, (ftnlen)1)) {
- if (*incx == 1) {
- for (j = *n; j >= 1; --j) {
- i__1 = j;
- if (x[i__1].r != 0.f || x[i__1].i != 0.f) {
- if (nounit) {
- i__1 = j;
- c_div(&q__1, &x[j], &a[j + j * a_dim1]);
- x[i__1].r = q__1.r, x[i__1].i = q__1.i;
- }
- i__1 = j;
- temp.r = x[i__1].r, temp.i = x[i__1].i;
- for (i__ = j - 1; i__ >= 1; --i__) {
- i__1 = i__;
- i__2 = i__;
- i__3 = i__ + j * a_dim1;
- q__2.r = temp.r * a[i__3].r - temp.i * a[i__3].i,
- q__2.i = temp.r * a[i__3].i + temp.i * a[
- i__3].r;
- q__1.r = x[i__2].r - q__2.r, q__1.i = x[i__2].i -
- q__2.i;
- x[i__1].r = q__1.r, x[i__1].i = q__1.i;
-/* L10: */
- }
- }
-/* L20: */
- }
- } else {
- jx = kx + (*n - 1) * *incx;
- for (j = *n; j >= 1; --j) {
- i__1 = jx;
- if (x[i__1].r != 0.f || x[i__1].i != 0.f) {
- if (nounit) {
- i__1 = jx;
- c_div(&q__1, &x[jx], &a[j + j * a_dim1]);
- x[i__1].r = q__1.r, x[i__1].i = q__1.i;
- }
- i__1 = jx;
- temp.r = x[i__1].r, temp.i = x[i__1].i;
- ix = jx;
- for (i__ = j - 1; i__ >= 1; --i__) {
- ix -= *incx;
- i__1 = ix;
- i__2 = ix;
- i__3 = i__ + j * a_dim1;
- q__2.r = temp.r * a[i__3].r - temp.i * a[i__3].i,
- q__2.i = temp.r * a[i__3].i + temp.i * a[
- i__3].r;
- q__1.r = x[i__2].r - q__2.r, q__1.i = x[i__2].i -
- q__2.i;
- x[i__1].r = q__1.r, x[i__1].i = q__1.i;
-/* L30: */
- }
- }
- jx -= *incx;
-/* L40: */
- }
- }
- } else {
- if (*incx == 1) {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- i__2 = j;
- if (x[i__2].r != 0.f || x[i__2].i != 0.f) {
- if (nounit) {
- i__2 = j;
- c_div(&q__1, &x[j], &a[j + j * a_dim1]);
- x[i__2].r = q__1.r, x[i__2].i = q__1.i;
- }
- i__2 = j;
- temp.r = x[i__2].r, temp.i = x[i__2].i;
- i__2 = *n;
- for (i__ = j + 1; i__ <= i__2; ++i__) {
- i__3 = i__;
- i__4 = i__;
- i__5 = i__ + j * a_dim1;
- q__2.r = temp.r * a[i__5].r - temp.i * a[i__5].i,
- q__2.i = temp.r * a[i__5].i + temp.i * a[
- i__5].r;
- q__1.r = x[i__4].r - q__2.r, q__1.i = x[i__4].i -
- q__2.i;
- x[i__3].r = q__1.r, x[i__3].i = q__1.i;
-/* L50: */
- }
- }
-/* L60: */
- }
- } else {
- jx = kx;
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- i__2 = jx;
- if (x[i__2].r != 0.f || x[i__2].i != 0.f) {
- if (nounit) {
- i__2 = jx;
- c_div(&q__1, &x[jx], &a[j + j * a_dim1]);
- x[i__2].r = q__1.r, x[i__2].i = q__1.i;
- }
- i__2 = jx;
- temp.r = x[i__2].r, temp.i = x[i__2].i;
- ix = jx;
- i__2 = *n;
- for (i__ = j + 1; i__ <= i__2; ++i__) {
- ix += *incx;
- i__3 = ix;
- i__4 = ix;
- i__5 = i__ + j * a_dim1;
- q__2.r = temp.r * a[i__5].r - temp.i * a[i__5].i,
- q__2.i = temp.r * a[i__5].i + temp.i * a[
- i__5].r;
- q__1.r = x[i__4].r - q__2.r, q__1.i = x[i__4].i -
- q__2.i;
- x[i__3].r = q__1.r, x[i__3].i = q__1.i;
-/* L70: */
- }
- }
- jx += *incx;
-/* L80: */
- }
- }
- }
- } else {
-
-/* Form x := inv( A' )*x or x := inv( conjg( A' ) )*x. */
-
- if (lsame_(uplo, "U", (ftnlen)1, (ftnlen)1)) {
- if (*incx == 1) {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- i__2 = j;
- temp.r = x[i__2].r, temp.i = x[i__2].i;
- if (noconj) {
- i__2 = j - 1;
- for (i__ = 1; i__ <= i__2; ++i__) {
- i__3 = i__ + j * a_dim1;
- i__4 = i__;
- q__2.r = a[i__3].r * x[i__4].r - a[i__3].i * x[
- i__4].i, q__2.i = a[i__3].r * x[i__4].i +
- a[i__3].i * x[i__4].r;
- q__1.r = temp.r - q__2.r, q__1.i = temp.i -
- q__2.i;
- temp.r = q__1.r, temp.i = q__1.i;
-/* L90: */
- }
- if (nounit) {
- c_div(&q__1, &temp, &a[j + j * a_dim1]);
- temp.r = q__1.r, temp.i = q__1.i;
- }
- } else {
- i__2 = j - 1;
- for (i__ = 1; i__ <= i__2; ++i__) {
- r_cnjg(&q__3, &a[i__ + j * a_dim1]);
- i__3 = i__;
- q__2.r = q__3.r * x[i__3].r - q__3.i * x[i__3].i,
- q__2.i = q__3.r * x[i__3].i + q__3.i * x[
- i__3].r;
- q__1.r = temp.r - q__2.r, q__1.i = temp.i -
- q__2.i;
- temp.r = q__1.r, temp.i = q__1.i;
-/* L100: */
- }
- if (nounit) {
- r_cnjg(&q__2, &a[j + j * a_dim1]);
- c_div(&q__1, &temp, &q__2);
- temp.r = q__1.r, temp.i = q__1.i;
- }
- }
- i__2 = j;
- x[i__2].r = temp.r, x[i__2].i = temp.i;
-/* L110: */
- }
- } else {
- jx = kx;
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- ix = kx;
- i__2 = jx;
- temp.r = x[i__2].r, temp.i = x[i__2].i;
- if (noconj) {
- i__2 = j - 1;
- for (i__ = 1; i__ <= i__2; ++i__) {
- i__3 = i__ + j * a_dim1;
- i__4 = ix;
- q__2.r = a[i__3].r * x[i__4].r - a[i__3].i * x[
- i__4].i, q__2.i = a[i__3].r * x[i__4].i +
- a[i__3].i * x[i__4].r;
- q__1.r = temp.r - q__2.r, q__1.i = temp.i -
- q__2.i;
- temp.r = q__1.r, temp.i = q__1.i;
- ix += *incx;
-/* L120: */
- }
- if (nounit) {
- c_div(&q__1, &temp, &a[j + j * a_dim1]);
- temp.r = q__1.r, temp.i = q__1.i;
- }
- } else {
- i__2 = j - 1;
- for (i__ = 1; i__ <= i__2; ++i__) {
- r_cnjg(&q__3, &a[i__ + j * a_dim1]);
- i__3 = ix;
- q__2.r = q__3.r * x[i__3].r - q__3.i * x[i__3].i,
- q__2.i = q__3.r * x[i__3].i + q__3.i * x[
- i__3].r;
- q__1.r = temp.r - q__2.r, q__1.i = temp.i -
- q__2.i;
- temp.r = q__1.r, temp.i = q__1.i;
- ix += *incx;
-/* L130: */
- }
- if (nounit) {
- r_cnjg(&q__2, &a[j + j * a_dim1]);
- c_div(&q__1, &temp, &q__2);
- temp.r = q__1.r, temp.i = q__1.i;
- }
- }
- i__2 = jx;
- x[i__2].r = temp.r, x[i__2].i = temp.i;
- jx += *incx;
-/* L140: */
- }
- }
- } else {
- if (*incx == 1) {
- for (j = *n; j >= 1; --j) {
- i__1 = j;
- temp.r = x[i__1].r, temp.i = x[i__1].i;
- if (noconj) {
- i__1 = j + 1;
- for (i__ = *n; i__ >= i__1; --i__) {
- i__2 = i__ + j * a_dim1;
- i__3 = i__;
- q__2.r = a[i__2].r * x[i__3].r - a[i__2].i * x[
- i__3].i, q__2.i = a[i__2].r * x[i__3].i +
- a[i__2].i * x[i__3].r;
- q__1.r = temp.r - q__2.r, q__1.i = temp.i -
- q__2.i;
- temp.r = q__1.r, temp.i = q__1.i;
-/* L150: */
- }
- if (nounit) {
- c_div(&q__1, &temp, &a[j + j * a_dim1]);
- temp.r = q__1.r, temp.i = q__1.i;
- }
- } else {
- i__1 = j + 1;
- for (i__ = *n; i__ >= i__1; --i__) {
- r_cnjg(&q__3, &a[i__ + j * a_dim1]);
- i__2 = i__;
- q__2.r = q__3.r * x[i__2].r - q__3.i * x[i__2].i,
- q__2.i = q__3.r * x[i__2].i + q__3.i * x[
- i__2].r;
- q__1.r = temp.r - q__2.r, q__1.i = temp.i -
- q__2.i;
- temp.r = q__1.r, temp.i = q__1.i;
-/* L160: */
- }
- if (nounit) {
- r_cnjg(&q__2, &a[j + j * a_dim1]);
- c_div(&q__1, &temp, &q__2);
- temp.r = q__1.r, temp.i = q__1.i;
- }
- }
- i__1 = j;
- x[i__1].r = temp.r, x[i__1].i = temp.i;
-/* L170: */
- }
- } else {
- kx += (*n - 1) * *incx;
- jx = kx;
- for (j = *n; j >= 1; --j) {
- ix = kx;
- i__1 = jx;
- temp.r = x[i__1].r, temp.i = x[i__1].i;
- if (noconj) {
- i__1 = j + 1;
- for (i__ = *n; i__ >= i__1; --i__) {
- i__2 = i__ + j * a_dim1;
- i__3 = ix;
- q__2.r = a[i__2].r * x[i__3].r - a[i__2].i * x[
- i__3].i, q__2.i = a[i__2].r * x[i__3].i +
- a[i__2].i * x[i__3].r;
- q__1.r = temp.r - q__2.r, q__1.i = temp.i -
- q__2.i;
- temp.r = q__1.r, temp.i = q__1.i;
- ix -= *incx;
-/* L180: */
- }
- if (nounit) {
- c_div(&q__1, &temp, &a[j + j * a_dim1]);
- temp.r = q__1.r, temp.i = q__1.i;
- }
- } else {
- i__1 = j + 1;
- for (i__ = *n; i__ >= i__1; --i__) {
- r_cnjg(&q__3, &a[i__ + j * a_dim1]);
- i__2 = ix;
- q__2.r = q__3.r * x[i__2].r - q__3.i * x[i__2].i,
- q__2.i = q__3.r * x[i__2].i + q__3.i * x[
- i__2].r;
- q__1.r = temp.r - q__2.r, q__1.i = temp.i -
- q__2.i;
- temp.r = q__1.r, temp.i = q__1.i;
- ix -= *incx;
-/* L190: */
- }
- if (nounit) {
- r_cnjg(&q__2, &a[j + j * a_dim1]);
- c_div(&q__1, &temp, &q__2);
- temp.r = q__1.r, temp.i = q__1.i;
- }
- }
- i__1 = jx;
- x[i__1].r = temp.r, x[i__1].i = temp.i;
- jx -= *incx;
-/* L200: */
- }
- }
- }
- }
-
- return 0;
-
-/* End of CTRSV . */
-
-} /* ctrsv_ */
-
-doublereal dasum_(integer *n, doublereal *dx, integer *incx)
-{
- /* System generated locals */
- integer i__1, i__2;
- doublereal ret_val, d__1, d__2, d__3, d__4, d__5, d__6;
-
- /* Local variables */
- static integer i__, m, mp1;
- static doublereal dtemp;
- static integer nincx;
-
-
-/* takes the sum of the absolute values. */
-/* jack dongarra, linpack, 3/11/78. */
-/* modified 3/93 to return if incx .le. 0. */
-/* modified 12/3/93, array(1) declarations changed to array(*) */
-
-
- /* Parameter adjustments */
- --dx;
-
- /* Function Body */
- ret_val = 0.;
- dtemp = 0.;
- if (*n <= 0 || *incx <= 0) {
- return ret_val;
- }
- if (*incx == 1) {
- goto L20;
- }
-
-/* code for increment not equal to 1 */
-
- nincx = *n * *incx;
- i__1 = nincx;
- i__2 = *incx;
- for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
- dtemp += (d__1 = dx[i__], abs(d__1));
-/* L10: */
- }
- ret_val = dtemp;
- return ret_val;
-
-/* code for increment equal to 1 */
-
-
-/* clean-up loop */
-
-L20:
- m = *n % 6;
- if (m == 0) {
- goto L40;
- }
- i__2 = m;
- for (i__ = 1; i__ <= i__2; ++i__) {
- dtemp += (d__1 = dx[i__], abs(d__1));
-/* L30: */
- }
- if (*n < 6) {
- goto L60;
- }
-L40:
- mp1 = m + 1;
- i__2 = *n;
- for (i__ = mp1; i__ <= i__2; i__ += 6) {
- dtemp = dtemp + (d__1 = dx[i__], abs(d__1)) + (d__2 = dx[i__ + 1],
- abs(d__2)) + (d__3 = dx[i__ + 2], abs(d__3)) + (d__4 = dx[i__
- + 3], abs(d__4)) + (d__5 = dx[i__ + 4], abs(d__5)) + (d__6 =
- dx[i__ + 5], abs(d__6));
-/* L50: */
- }
-L60:
- ret_val = dtemp;
- return ret_val;
-} /* dasum_ */
-
-/* Subroutine */ int daxpy_(integer *n, doublereal *da, doublereal *dx,
- integer *incx, doublereal *dy, integer *incy)
-{
- /* System generated locals */
- integer i__1;
-
- /* Local variables */
- static integer i__, m, ix, iy, mp1;
-
-
-/* constant times a vector plus a vector. */
-/* uses unrolled loops for increments equal to one. */
-/* jack dongarra, linpack, 3/11/78. */
-/* modified 12/3/93, array(1) declarations changed to array(*) */
-
-
- /* Parameter adjustments */
- --dy;
- --dx;
-
- /* Function Body */
- if (*n <= 0) {
- return 0;
- }
- if (*da == 0.) {
- return 0;
- }
- if (*incx == 1 && *incy == 1) {
- goto L20;
- }
-
-/* code for unequal increments or equal increments */
-/* not equal to 1 */
-
- ix = 1;
- iy = 1;
- if (*incx < 0) {
- ix = (-(*n) + 1) * *incx + 1;
- }
- if (*incy < 0) {
- iy = (-(*n) + 1) * *incy + 1;
- }
- i__1 = *n;
- for (i__ = 1; i__ <= i__1; ++i__) {
- dy[iy] += *da * dx[ix];
- ix += *incx;
- iy += *incy;
-/* L10: */
- }
- return 0;
-
-/* code for both increments equal to 1 */
-
-
-/* clean-up loop */
-
-L20:
- m = *n % 4;
- if (m == 0) {
- goto L40;
- }
- i__1 = m;
- for (i__ = 1; i__ <= i__1; ++i__) {
- dy[i__] += *da * dx[i__];
-/* L30: */
- }
- if (*n < 4) {
- return 0;
- }
-L40:
- mp1 = m + 1;
- i__1 = *n;
- for (i__ = mp1; i__ <= i__1; i__ += 4) {
- dy[i__] += *da * dx[i__];
- dy[i__ + 1] += *da * dx[i__ + 1];
- dy[i__ + 2] += *da * dx[i__ + 2];
- dy[i__ + 3] += *da * dx[i__ + 3];
-/* L50: */
- }
- return 0;
-} /* daxpy_ */
-
-doublereal dcabs1_(doublecomplex *z__)
-{
- /* System generated locals */
- doublereal ret_val;
- static doublecomplex equiv_0[1];
-
- /* Local variables */
-#define t ((doublereal *)equiv_0)
-#define zz (equiv_0)
-
- zz->r = z__->r, zz->i = z__->i;
- ret_val = abs(t[0]) + abs(t[1]);
- return ret_val;
-} /* dcabs1_ */
-
-#undef zz
-#undef t
-
-
-/* Subroutine */ int dcopy_(integer *n, doublereal *dx, integer *incx,
- doublereal *dy, integer *incy)
-{
- /* System generated locals */
- integer i__1;
-
- /* Local variables */
- static integer i__, m, ix, iy, mp1;
-
-
-/* copies a vector, x, to a vector, y. */
-/* uses unrolled loops for increments equal to one. */
-/* jack dongarra, linpack, 3/11/78. */
-/* modified 12/3/93, array(1) declarations changed to array(*) */
-
-
- /* Parameter adjustments */
- --dy;
- --dx;
-
- /* Function Body */
- if (*n <= 0) {
- return 0;
- }
- if (*incx == 1 && *incy == 1) {
- goto L20;
- }
-
-/* code for unequal increments or equal increments */
-/* not equal to 1 */
-
- ix = 1;
- iy = 1;
- if (*incx < 0) {
- ix = (-(*n) + 1) * *incx + 1;
- }
- if (*incy < 0) {
- iy = (-(*n) + 1) * *incy + 1;
- }
- i__1 = *n;
- for (i__ = 1; i__ <= i__1; ++i__) {
- dy[iy] = dx[ix];
- ix += *incx;
- iy += *incy;
-/* L10: */
- }
- return 0;
-
-/* code for both increments equal to 1 */
-
-
-/* clean-up loop */
-
-L20:
- m = *n % 7;
- if (m == 0) {
- goto L40;
- }
- i__1 = m;
- for (i__ = 1; i__ <= i__1; ++i__) {
- dy[i__] = dx[i__];
-/* L30: */
- }
- if (*n < 7) {
- return 0;
- }
-L40:
- mp1 = m + 1;
- i__1 = *n;
- for (i__ = mp1; i__ <= i__1; i__ += 7) {
- dy[i__] = dx[i__];
- dy[i__ + 1] = dx[i__ + 1];
- dy[i__ + 2] = dx[i__ + 2];
- dy[i__ + 3] = dx[i__ + 3];
- dy[i__ + 4] = dx[i__ + 4];
- dy[i__ + 5] = dx[i__ + 5];
- dy[i__ + 6] = dx[i__ + 6];
-/* L50: */
- }
- return 0;
-} /* dcopy_ */
-
-doublereal ddot_(integer *n, doublereal *dx, integer *incx, doublereal *dy,
- integer *incy)
-{
- /* System generated locals */
- integer i__1;
- doublereal ret_val;
-
- /* Local variables */
- static integer i__, m, ix, iy, mp1;
- static doublereal dtemp;
-
-
-/* forms the dot product of two vectors. */
-/* uses unrolled loops for increments equal to one. */
-/* jack dongarra, linpack, 3/11/78. */
-/* modified 12/3/93, array(1) declarations changed to array(*) */
-
-
- /* Parameter adjustments */
- --dy;
- --dx;
-
- /* Function Body */
- ret_val = 0.;
- dtemp = 0.;
- if (*n <= 0) {
- return ret_val;
- }
- if (*incx == 1 && *incy == 1) {
- goto L20;
- }
-
-/* code for unequal increments or equal increments */
-/* not equal to 1 */
-
- ix = 1;
- iy = 1;
- if (*incx < 0) {
- ix = (-(*n) + 1) * *incx + 1;
- }
- if (*incy < 0) {
- iy = (-(*n) + 1) * *incy + 1;
- }
- i__1 = *n;
- for (i__ = 1; i__ <= i__1; ++i__) {
- dtemp += dx[ix] * dy[iy];
- ix += *incx;
- iy += *incy;
-/* L10: */
- }
- ret_val = dtemp;
- return ret_val;
-
-/* code for both increments equal to 1 */
-
-
-/* clean-up loop */
-
-L20:
- m = *n % 5;
- if (m == 0) {
- goto L40;
- }
- i__1 = m;
- for (i__ = 1; i__ <= i__1; ++i__) {
- dtemp += dx[i__] * dy[i__];
-/* L30: */
- }
- if (*n < 5) {
- goto L60;
- }
-L40:
- mp1 = m + 1;
- i__1 = *n;
- for (i__ = mp1; i__ <= i__1; i__ += 5) {
- dtemp = dtemp + dx[i__] * dy[i__] + dx[i__ + 1] * dy[i__ + 1] + dx[
- i__ + 2] * dy[i__ + 2] + dx[i__ + 3] * dy[i__ + 3] + dx[i__ +
- 4] * dy[i__ + 4];
-/* L50: */
- }
-L60:
- ret_val = dtemp;
- return ret_val;
-} /* ddot_ */
-
-/* Subroutine */ int dgbmv_(char *trans, integer *m, integer *n, integer *kl,
- integer *ku, doublereal *alpha, doublereal *a, integer *lda,
- doublereal *x, integer *incx, doublereal *beta, doublereal *y,
- integer *incy, ftnlen trans_len)
-{
- /* System generated locals */
- integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5, i__6;
-
- /* Local variables */
- static integer i__, j, k, ix, iy, jx, jy, kx, ky, kup1, info;
- static doublereal temp;
- static integer lenx, leny;
- extern logical lsame_(char *, char *, ftnlen, ftnlen);
- extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen);
-
-/* .. Scalar Arguments .. */
-/* .. Array Arguments .. */
-/* .. */
-
-/* Purpose */
-/* ======= */
-
-/* DGBMV performs one of the matrix-vector operations */
-
-/* y := alpha*A*x + beta*y, or y := alpha*A'*x + beta*y, */
-
-/* where alpha and beta are scalars, x and y are vectors and A is an */
-/* m by n band matrix, with kl sub-diagonals and ku super-diagonals. */
-
-/* Parameters */
-/* ========== */
-
-/* TRANS - CHARACTER*1. */
-/* On entry, TRANS specifies the operation to be performed as */
-/* follows: */
-
-/* TRANS = 'N' or 'n' y := alpha*A*x + beta*y. */
-
-/* TRANS = 'T' or 't' y := alpha*A'*x + beta*y. */
-
-/* TRANS = 'C' or 'c' y := alpha*A'*x + beta*y. */
-
-/* Unchanged on exit. */
-
-/* M - INTEGER. */
-/* On entry, M specifies the number of rows of the matrix A. */
-/* M must be at least zero. */
-/* Unchanged on exit. */
-
-/* N - INTEGER. */
-/* On entry, N specifies the number of columns of the matrix A. */
-/* N must be at least zero. */
-/* Unchanged on exit. */
-
-/* KL - INTEGER. */
-/* On entry, KL specifies the number of sub-diagonals of the */
-/* matrix A. KL must satisfy 0 .le. KL. */
-/* Unchanged on exit. */
-
-/* KU - INTEGER. */
-/* On entry, KU specifies the number of super-diagonals of the */
-/* matrix A. KU must satisfy 0 .le. KU. */
-/* Unchanged on exit. */
-
-/* ALPHA - DOUBLE PRECISION. */
-/* On entry, ALPHA specifies the scalar alpha. */
-/* Unchanged on exit. */
-
-/* A - DOUBLE PRECISION array of DIMENSION ( LDA, n ). */
-/* Before entry, the leading ( kl + ku + 1 ) by n part of the */
-/* array A must contain the matrix of coefficients, supplied */
-/* column by column, with the leading diagonal of the matrix in */
-/* row ( ku + 1 ) of the array, the first super-diagonal */
-/* starting at position 2 in row ku, the first sub-diagonal */
-/* starting at position 1 in row ( ku + 2 ), and so on. */
-/* Elements in the array A that do not correspond to elements */
-/* in the band matrix (such as the top left ku by ku triangle) */
-/* are not referenced. */
-/* The following program segment will transfer a band matrix */
-/* from conventional full matrix storage to band storage: */
-
-/* DO 20, J = 1, N */
-/* K = KU + 1 - J */
-/* DO 10, I = MAX( 1, J - KU ), MIN( M, J + KL ) */
-/* A( K + I, J ) = matrix( I, J ) */
-/* 10 CONTINUE */
-/* 20 CONTINUE */
-
-/* Unchanged on exit. */
-
-/* LDA - INTEGER. */
-/* On entry, LDA specifies the first dimension of A as declared */
-/* in the calling (sub) program. LDA must be at least */
-/* ( kl + ku + 1 ). */
-/* Unchanged on exit. */
-
-/* X - DOUBLE PRECISION array of DIMENSION at least */
-/* ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n' */
-/* and at least */
-/* ( 1 + ( m - 1 )*abs( INCX ) ) otherwise. */
-/* Before entry, the incremented array X must contain the */
-/* vector x. */
-/* Unchanged on exit. */
-
-/* INCX - INTEGER. */
-/* On entry, INCX specifies the increment for the elements of */
-/* X. INCX must not be zero. */
-/* Unchanged on exit. */
-
-/* BETA - DOUBLE PRECISION. */
-/* On entry, BETA specifies the scalar beta. When BETA is */
-/* supplied as zero then Y need not be set on input. */
-/* Unchanged on exit. */
-
-/* Y - DOUBLE PRECISION array of DIMENSION at least */
-/* ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n' */
-/* and at least */
-/* ( 1 + ( n - 1 )*abs( INCY ) ) otherwise. */
-/* Before entry, the incremented array Y must contain the */
-/* vector y. On exit, Y is overwritten by the updated vector y. */
-
-/* INCY - INTEGER. */
-/* On entry, INCY specifies the increment for the elements of */
-/* Y. INCY must not be zero. */
-/* Unchanged on exit. */
-
-
-/* Level 2 Blas routine. */
-
-/* -- Written on 22-October-1986. */
-/* Jack Dongarra, Argonne National Lab. */
-/* Jeremy Du Croz, Nag Central Office. */
-/* Sven Hammarling, Nag Central Office. */
-/* Richard Hanson, Sandia National Labs. */
-
-/* .. Parameters .. */
-/* .. Local Scalars .. */
-/* .. External Functions .. */
-/* .. External Subroutines .. */
-/* .. Intrinsic Functions .. */
-/* .. */
-/* .. Executable Statements .. */
-
-/* Test the input parameters. */
-
- /* Parameter adjustments */
- a_dim1 = *lda;
- a_offset = 1 + a_dim1 * 1;
- a -= a_offset;
- --x;
- --y;
-
- /* Function Body */
- info = 0;
- if (! lsame_(trans, "N", (ftnlen)1, (ftnlen)1) && ! lsame_(trans, "T", (
- ftnlen)1, (ftnlen)1) && ! lsame_(trans, "C", (ftnlen)1, (ftnlen)1)
- ) {
- info = 1;
- } else if (*m < 0) {
- info = 2;
- } else if (*n < 0) {
- info = 3;
- } else if (*kl < 0) {
- info = 4;
- } else if (*ku < 0) {
- info = 5;
- } else if (*lda < *kl + *ku + 1) {
- info = 8;
- } else if (*incx == 0) {
- info = 10;
- } else if (*incy == 0) {
- info = 13;
- }
- if (info != 0) {
- xerbla_("DGBMV ", &info, (ftnlen)6);
- return 0;
- }
-
-/* Quick return if possible. */
-
- if (*m == 0 || *n == 0 || *alpha == 0. && *beta == 1.) {
- return 0;
- }
-
-/* Set LENX and LENY, the lengths of the vectors x and y, and set */
-/* up the start points in X and Y. */
-
- if (lsame_(trans, "N", (ftnlen)1, (ftnlen)1)) {
- lenx = *n;
- leny = *m;
- } else {
- lenx = *m;
- leny = *n;
- }
- if (*incx > 0) {
- kx = 1;
- } else {
- kx = 1 - (lenx - 1) * *incx;
- }
- if (*incy > 0) {
- ky = 1;
- } else {
- ky = 1 - (leny - 1) * *incy;
- }
-
-/* Start the operations. In this version the elements of A are */
-/* accessed sequentially with one pass through the band part of A. */
-
-/* First form y := beta*y. */
-
- if (*beta != 1.) {
- if (*incy == 1) {
- if (*beta == 0.) {
- i__1 = leny;
- for (i__ = 1; i__ <= i__1; ++i__) {
- y[i__] = 0.;
-/* L10: */
- }
- } else {
- i__1 = leny;
- for (i__ = 1; i__ <= i__1; ++i__) {
- y[i__] = *beta * y[i__];
-/* L20: */
- }
- }
- } else {
- iy = ky;
- if (*beta == 0.) {
- i__1 = leny;
- for (i__ = 1; i__ <= i__1; ++i__) {
- y[iy] = 0.;
- iy += *incy;
-/* L30: */
- }
- } else {
- i__1 = leny;
- for (i__ = 1; i__ <= i__1; ++i__) {
- y[iy] = *beta * y[iy];
- iy += *incy;
-/* L40: */
- }
- }
- }
- }
- if (*alpha == 0.) {
- return 0;
- }
- kup1 = *ku + 1;
- if (lsame_(trans, "N", (ftnlen)1, (ftnlen)1)) {
-
-/* Form y := alpha*A*x + y. */
-
- jx = kx;
- if (*incy == 1) {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- if (x[jx] != 0.) {
- temp = *alpha * x[jx];
- k = kup1 - j;
-/* Computing MAX */
- i__2 = 1, i__3 = j - *ku;
-/* Computing MIN */
- i__5 = *m, i__6 = j + *kl;
- i__4 = min(i__5,i__6);
- for (i__ = max(i__2,i__3); i__ <= i__4; ++i__) {
- y[i__] += temp * a[k + i__ + j * a_dim1];
-/* L50: */
- }
- }
- jx += *incx;
-/* L60: */
- }
- } else {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- if (x[jx] != 0.) {
- temp = *alpha * x[jx];
- iy = ky;
- k = kup1 - j;
-/* Computing MAX */
- i__4 = 1, i__2 = j - *ku;
-/* Computing MIN */
- i__5 = *m, i__6 = j + *kl;
- i__3 = min(i__5,i__6);
- for (i__ = max(i__4,i__2); i__ <= i__3; ++i__) {
- y[iy] += temp * a[k + i__ + j * a_dim1];
- iy += *incy;
-/* L70: */
- }
- }
- jx += *incx;
- if (j > *ku) {
- ky += *incy;
- }
-/* L80: */
- }
- }
- } else {
-
-/* Form y := alpha*A'*x + y. */
-
- jy = ky;
- if (*incx == 1) {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- temp = 0.;
- k = kup1 - j;
-/* Computing MAX */
- i__3 = 1, i__4 = j - *ku;
-/* Computing MIN */
- i__5 = *m, i__6 = j + *kl;
- i__2 = min(i__5,i__6);
- for (i__ = max(i__3,i__4); i__ <= i__2; ++i__) {
- temp += a[k + i__ + j * a_dim1] * x[i__];
-/* L90: */
- }
- y[jy] += *alpha * temp;
- jy += *incy;
-/* L100: */
- }
- } else {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- temp = 0.;
- ix = kx;
- k = kup1 - j;
-/* Computing MAX */
- i__2 = 1, i__3 = j - *ku;
-/* Computing MIN */
- i__5 = *m, i__6 = j + *kl;
- i__4 = min(i__5,i__6);
- for (i__ = max(i__2,i__3); i__ <= i__4; ++i__) {
- temp += a[k + i__ + j * a_dim1] * x[ix];
- ix += *incx;
-/* L110: */
- }
- y[jy] += *alpha * temp;
- jy += *incy;
- if (j > *ku) {
- kx += *incx;
- }
-/* L120: */
- }
- }
- }
-
- return 0;
-
-/* End of DGBMV . */
-
-} /* dgbmv_ */
-
-/* Subroutine */ int dgemm_(char *transa, char *transb, integer *m, integer *
- n, integer *k, doublereal *alpha, doublereal *a, integer *lda,
- doublereal *b, integer *ldb, doublereal *beta, doublereal *c__,
- integer *ldc, ftnlen transa_len, ftnlen transb_len)
-{
- /* System generated locals */
- integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2,
- i__3;
-
- /* Local variables */
- static integer i__, j, l, info;
- static logical nota, notb;
- static doublereal temp;
- static integer ncola;
- extern logical lsame_(char *, char *, ftnlen, ftnlen);
- static integer nrowa, nrowb;
- extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen);
-
-/* .. Scalar Arguments .. */
-/* .. Array Arguments .. */
-/* .. */
-
-/* Purpose */
-/* ======= */
-
-/* DGEMM performs one of the matrix-matrix operations */
-
-/* C := alpha*op( A )*op( B ) + beta*C, */
-
-/* where op( X ) is one of */
-
-/* op( X ) = X or op( X ) = X', */
-
-/* alpha and beta are scalars, and A, B and C are matrices, with op( A ) */
-/* an m by k matrix, op( B ) a k by n matrix and C an m by n matrix. */
-
-/* Parameters */
-/* ========== */
-
-/* TRANSA - CHARACTER*1. */
-/* On entry, TRANSA specifies the form of op( A ) to be used in */
-/* the matrix multiplication as follows: */
-
-/* TRANSA = 'N' or 'n', op( A ) = A. */
-
-/* TRANSA = 'T' or 't', op( A ) = A'. */
-
-/* TRANSA = 'C' or 'c', op( A ) = A'. */
-
-/* Unchanged on exit. */
-
-/* TRANSB - CHARACTER*1. */
-/* On entry, TRANSB specifies the form of op( B ) to be used in */
-/* the matrix multiplication as follows: */
-
-/* TRANSB = 'N' or 'n', op( B ) = B. */
-
-/* TRANSB = 'T' or 't', op( B ) = B'. */
-
-/* TRANSB = 'C' or 'c', op( B ) = B'. */
-
-/* Unchanged on exit. */
-
-/* M - INTEGER. */
-/* On entry, M specifies the number of rows of the matrix */
-/* op( A ) and of the matrix C. M must be at least zero. */
-/* Unchanged on exit. */
-
-/* N - INTEGER. */
-/* On entry, N specifies the number of columns of the matrix */
-/* op( B ) and the number of columns of the matrix C. N must be */
-/* at least zero. */
-/* Unchanged on exit. */
-
-/* K - INTEGER. */
-/* On entry, K specifies the number of columns of the matrix */
-/* op( A ) and the number of rows of the matrix op( B ). K must */
-/* be at least zero. */
-/* Unchanged on exit. */
-
-/* ALPHA - DOUBLE PRECISION. */
-/* On entry, ALPHA specifies the scalar alpha. */
-/* Unchanged on exit. */
-
-/* A - DOUBLE PRECISION array of DIMENSION ( LDA, ka ), where ka is */
-/* k when TRANSA = 'N' or 'n', and is m otherwise. */
-/* Before entry with TRANSA = 'N' or 'n', the leading m by k */
-/* part of the array A must contain the matrix A, otherwise */
-/* the leading k by m part of the array A must contain the */
-/* matrix A. */
-/* Unchanged on exit. */
-
-/* LDA - INTEGER. */
-/* On entry, LDA specifies the first dimension of A as declared */
-/* in the calling (sub) program. When TRANSA = 'N' or 'n' then */
-/* LDA must be at least max( 1, m ), otherwise LDA must be at */
-/* least max( 1, k ). */
-/* Unchanged on exit. */
-
-/* B - DOUBLE PRECISION array of DIMENSION ( LDB, kb ), where kb is */
-/* n when TRANSB = 'N' or 'n', and is k otherwise. */
-/* Before entry with TRANSB = 'N' or 'n', the leading k by n */
-/* part of the array B must contain the matrix B, otherwise */
-/* the leading n by k part of the array B must contain the */
-/* matrix B. */
-/* Unchanged on exit. */
-
-/* LDB - INTEGER. */
-/* On entry, LDB specifies the first dimension of B as declared */
-/* in the calling (sub) program. When TRANSB = 'N' or 'n' then */
-/* LDB must be at least max( 1, k ), otherwise LDB must be at */
-/* least max( 1, n ). */
-/* Unchanged on exit. */
-
-/* BETA - DOUBLE PRECISION. */
-/* On entry, BETA specifies the scalar beta. When BETA is */
-/* supplied as zero then C need not be set on input. */
-/* Unchanged on exit. */
-
-/* C - DOUBLE PRECISION array of DIMENSION ( LDC, n ). */
-/* Before entry, the leading m by n part of the array C must */
-/* contain the matrix C, except when beta is zero, in which */
-/* case C need not be set on entry. */
-/* On exit, the array C is overwritten by the m by n matrix */
-/* ( alpha*op( A )*op( B ) + beta*C ). */
-
-/* LDC - INTEGER. */
-/* On entry, LDC specifies the first dimension of C as declared */
-/* in the calling (sub) program. LDC must be at least */
-/* max( 1, m ). */
-/* Unchanged on exit. */
-
-
-/* Level 3 Blas routine. */
-
-/* -- Written on 8-February-1989. */
-/* Jack Dongarra, Argonne National Laboratory. */
-/* Iain Duff, AERE Harwell. */
-/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */
-/* Sven Hammarling, Numerical Algorithms Group Ltd. */
-
-
-/* .. External Functions .. */
-/* .. External Subroutines .. */
-/* .. Intrinsic Functions .. */
-/* .. Local Scalars .. */
-/* .. Parameters .. */
-/* .. */
-/* .. Executable Statements .. */
-
-/* Set NOTA and NOTB as true if A and B respectively are not */
-/* transposed and set NROWA, NCOLA and NROWB as the number of rows */
-/* and columns of A and the number of rows of B respectively. */
-
- /* Parameter adjustments */
- a_dim1 = *lda;
- a_offset = 1 + a_dim1 * 1;
- a -= a_offset;
- b_dim1 = *ldb;
- b_offset = 1 + b_dim1 * 1;
- b -= b_offset;
- c_dim1 = *ldc;
- c_offset = 1 + c_dim1 * 1;
- c__ -= c_offset;
-
- /* Function Body */
- nota = lsame_(transa, "N", (ftnlen)1, (ftnlen)1);
- notb = lsame_(transb, "N", (ftnlen)1, (ftnlen)1);
- if (nota) {
- nrowa = *m;
- ncola = *k;
- } else {
- nrowa = *k;
- ncola = *m;
- }
- if (notb) {
- nrowb = *k;
- } else {
- nrowb = *n;
- }
-
-/* Test the input parameters. */
-
- info = 0;
- if (! nota && ! lsame_(transa, "C", (ftnlen)1, (ftnlen)1) && ! lsame_(
- transa, "T", (ftnlen)1, (ftnlen)1)) {
- info = 1;
- } else if (! notb && ! lsame_(transb, "C", (ftnlen)1, (ftnlen)1) && !
- lsame_(transb, "T", (ftnlen)1, (ftnlen)1)) {
- info = 2;
- } else if (*m < 0) {
- info = 3;
- } else if (*n < 0) {
- info = 4;
- } else if (*k < 0) {
- info = 5;
- } else if (*lda < max(1,nrowa)) {
- info = 8;
- } else if (*ldb < max(1,nrowb)) {
- info = 10;
- } else if (*ldc < max(1,*m)) {
- info = 13;
- }
- if (info != 0) {
- xerbla_("DGEMM ", &info, (ftnlen)6);
- return 0;
- }
-
-/* Quick return if possible. */
-
- if (*m == 0 || *n == 0 || (*alpha == 0. || *k == 0) && *beta == 1.) {
- return 0;
- }
-
-/* And if alpha.eq.zero. */
-
- if (*alpha == 0.) {
- if (*beta == 0.) {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- i__2 = *m;
- for (i__ = 1; i__ <= i__2; ++i__) {
- c__[i__ + j * c_dim1] = 0.;
-/* L10: */
- }
-/* L20: */
- }
- } else {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- i__2 = *m;
- for (i__ = 1; i__ <= i__2; ++i__) {
- c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1];
-/* L30: */
- }
-/* L40: */
- }
- }
- return 0;
- }
-
-/* Start the operations. */
-
- if (notb) {
- if (nota) {
-
-/* Form C := alpha*A*B + beta*C. */
-
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- if (*beta == 0.) {
- i__2 = *m;
- for (i__ = 1; i__ <= i__2; ++i__) {
- c__[i__ + j * c_dim1] = 0.;
-/* L50: */
- }
- } else if (*beta != 1.) {
- i__2 = *m;
- for (i__ = 1; i__ <= i__2; ++i__) {
- c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1];
-/* L60: */
- }
- }
- i__2 = *k;
- for (l = 1; l <= i__2; ++l) {
- if (b[l + j * b_dim1] != 0.) {
- temp = *alpha * b[l + j * b_dim1];
- i__3 = *m;
- for (i__ = 1; i__ <= i__3; ++i__) {
- c__[i__ + j * c_dim1] += temp * a[i__ + l *
- a_dim1];
-/* L70: */
- }
- }
-/* L80: */
- }
-/* L90: */
- }
- } else {
-
-/* Form C := alpha*A'*B + beta*C */
-
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- i__2 = *m;
- for (i__ = 1; i__ <= i__2; ++i__) {
- temp = 0.;
- i__3 = *k;
- for (l = 1; l <= i__3; ++l) {
- temp += a[l + i__ * a_dim1] * b[l + j * b_dim1];
-/* L100: */
- }
- if (*beta == 0.) {
- c__[i__ + j * c_dim1] = *alpha * temp;
- } else {
- c__[i__ + j * c_dim1] = *alpha * temp + *beta * c__[
- i__ + j * c_dim1];
- }
-/* L110: */
- }
-/* L120: */
- }
- }
- } else {
- if (nota) {
-
-/* Form C := alpha*A*B' + beta*C */
-
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- if (*beta == 0.) {
- i__2 = *m;
- for (i__ = 1; i__ <= i__2; ++i__) {
- c__[i__ + j * c_dim1] = 0.;
-/* L130: */
- }
- } else if (*beta != 1.) {
- i__2 = *m;
- for (i__ = 1; i__ <= i__2; ++i__) {
- c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1];
-/* L140: */
- }
- }
- i__2 = *k;
- for (l = 1; l <= i__2; ++l) {
- if (b[j + l * b_dim1] != 0.) {
- temp = *alpha * b[j + l * b_dim1];
- i__3 = *m;
- for (i__ = 1; i__ <= i__3; ++i__) {
- c__[i__ + j * c_dim1] += temp * a[i__ + l *
- a_dim1];
-/* L150: */
- }
- }
-/* L160: */
- }
-/* L170: */
- }
- } else {
-
-/* Form C := alpha*A'*B' + beta*C */
-
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- i__2 = *m;
- for (i__ = 1; i__ <= i__2; ++i__) {
- temp = 0.;
- i__3 = *k;
- for (l = 1; l <= i__3; ++l) {
- temp += a[l + i__ * a_dim1] * b[j + l * b_dim1];
-/* L180: */
- }
- if (*beta == 0.) {
- c__[i__ + j * c_dim1] = *alpha * temp;
- } else {
- c__[i__ + j * c_dim1] = *alpha * temp + *beta * c__[
- i__ + j * c_dim1];
- }
-/* L190: */
- }
-/* L200: */
- }
- }
- }
-
- return 0;
-
-/* End of DGEMM . */
-
-} /* dgemm_ */
-
-/* Subroutine */ int dgemv_(char *trans, integer *m, integer *n, doublereal *
- alpha, doublereal *a, integer *lda, doublereal *x, integer *incx,
- doublereal *beta, doublereal *y, integer *incy, ftnlen trans_len)
-{
- /* System generated locals */
- integer a_dim1, a_offset, i__1, i__2;
-
- /* Local variables */
- static integer i__, j, ix, iy, jx, jy, kx, ky, info;
- static doublereal temp;
- static integer lenx, leny;
- extern logical lsame_(char *, char *, ftnlen, ftnlen);
- extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen);
-
-/* .. Scalar Arguments .. */
-/* .. Array Arguments .. */
-/* .. */
-
-/* Purpose */
-/* ======= */
-
-/* DGEMV performs one of the matrix-vector operations */
-
-/* y := alpha*A*x + beta*y, or y := alpha*A'*x + beta*y, */
-
-/* where alpha and beta are scalars, x and y are vectors and A is an */
-/* m by n matrix. */
-
-/* Parameters */
-/* ========== */
-
-/* TRANS - CHARACTER*1. */
-/* On entry, TRANS specifies the operation to be performed as */
-/* follows: */
-
-/* TRANS = 'N' or 'n' y := alpha*A*x + beta*y. */
-
-/* TRANS = 'T' or 't' y := alpha*A'*x + beta*y. */
-
-/* TRANS = 'C' or 'c' y := alpha*A'*x + beta*y. */
-
-/* Unchanged on exit. */
-
-/* M - INTEGER. */
-/* On entry, M specifies the number of rows of the matrix A. */
-/* M must be at least zero. */
-/* Unchanged on exit. */
-
-/* N - INTEGER. */
-/* On entry, N specifies the number of columns of the matrix A. */
-/* N must be at least zero. */
-/* Unchanged on exit. */
-
-/* ALPHA - DOUBLE PRECISION. */
-/* On entry, ALPHA specifies the scalar alpha. */
-/* Unchanged on exit. */
-
-/* A - DOUBLE PRECISION array of DIMENSION ( LDA, n ). */
-/* Before entry, the leading m by n part of the array A must */
-/* contain the matrix of coefficients. */
-/* Unchanged on exit. */
-
-/* LDA - INTEGER. */
-/* On entry, LDA specifies the first dimension of A as declared */
-/* in the calling (sub) program. LDA must be at least */
-/* max( 1, m ). */
-/* Unchanged on exit. */
-
-/* X - DOUBLE PRECISION array of DIMENSION at least */
-/* ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n' */
-/* and at least */
-/* ( 1 + ( m - 1 )*abs( INCX ) ) otherwise. */
-/* Before entry, the incremented array X must contain the */
-/* vector x. */
-/* Unchanged on exit. */
-
-/* INCX - INTEGER. */
-/* On entry, INCX specifies the increment for the elements of */
-/* X. INCX must not be zero. */
-/* Unchanged on exit. */
-
-/* BETA - DOUBLE PRECISION. */
-/* On entry, BETA specifies the scalar beta. When BETA is */
-/* supplied as zero then Y need not be set on input. */
-/* Unchanged on exit. */
-
-/* Y - DOUBLE PRECISION array of DIMENSION at least */
-/* ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n' */
-/* and at least */
-/* ( 1 + ( n - 1 )*abs( INCY ) ) otherwise. */
-/* Before entry with BETA non-zero, the incremented array Y */
-/* must contain the vector y. On exit, Y is overwritten by the */
-/* updated vector y. */
-
-/* INCY - INTEGER. */
-/* On entry, INCY specifies the increment for the elements of */
-/* Y. INCY must not be zero. */
-/* Unchanged on exit. */
-
-
-/* Level 2 Blas routine. */
-
-/* -- Written on 22-October-1986. */
-/* Jack Dongarra, Argonne National Lab. */
-/* Jeremy Du Croz, Nag Central Office. */
-/* Sven Hammarling, Nag Central Office. */
-/* Richard Hanson, Sandia National Labs. */
-
-
-/* .. Parameters .. */
-/* .. Local Scalars .. */
-/* .. External Functions .. */
-/* .. External Subroutines .. */
-/* .. Intrinsic Functions .. */
-/* .. */
-/* .. Executable Statements .. */
-
-/* Test the input parameters. */
-
- /* Parameter adjustments */
- a_dim1 = *lda;
- a_offset = 1 + a_dim1 * 1;
- a -= a_offset;
- --x;
- --y;
-
- /* Function Body */
- info = 0;
- if (! lsame_(trans, "N", (ftnlen)1, (ftnlen)1) && ! lsame_(trans, "T", (
- ftnlen)1, (ftnlen)1) && ! lsame_(trans, "C", (ftnlen)1, (ftnlen)1)
- ) {
- info = 1;
- } else if (*m < 0) {
- info = 2;
- } else if (*n < 0) {
- info = 3;
- } else if (*lda < max(1,*m)) {
- info = 6;
- } else if (*incx == 0) {
- info = 8;
- } else if (*incy == 0) {
- info = 11;
- }
- if (info != 0) {
- xerbla_("DGEMV ", &info, (ftnlen)6);
- return 0;
- }
-
-/* Quick return if possible. */
-
- if (*m == 0 || *n == 0 || *alpha == 0. && *beta == 1.) {
- return 0;
- }
-
-/* Set LENX and LENY, the lengths of the vectors x and y, and set */
-/* up the start points in X and Y. */
-
- if (lsame_(trans, "N", (ftnlen)1, (ftnlen)1)) {
- lenx = *n;
- leny = *m;
- } else {
- lenx = *m;
- leny = *n;
- }
- if (*incx > 0) {
- kx = 1;
- } else {
- kx = 1 - (lenx - 1) * *incx;
- }
- if (*incy > 0) {
- ky = 1;
- } else {
- ky = 1 - (leny - 1) * *incy;
- }
-
-/* Start the operations. In this version the elements of A are */
-/* accessed sequentially with one pass through A. */
-
-/* First form y := beta*y. */
-
- if (*beta != 1.) {
- if (*incy == 1) {
- if (*beta == 0.) {
- i__1 = leny;
- for (i__ = 1; i__ <= i__1; ++i__) {
- y[i__] = 0.;
-/* L10: */
- }
- } else {
- i__1 = leny;
- for (i__ = 1; i__ <= i__1; ++i__) {
- y[i__] = *beta * y[i__];
-/* L20: */
- }
- }
- } else {
- iy = ky;
- if (*beta == 0.) {
- i__1 = leny;
- for (i__ = 1; i__ <= i__1; ++i__) {
- y[iy] = 0.;
- iy += *incy;
-/* L30: */
- }
- } else {
- i__1 = leny;
- for (i__ = 1; i__ <= i__1; ++i__) {
- y[iy] = *beta * y[iy];
- iy += *incy;
-/* L40: */
- }
- }
- }
- }
- if (*alpha == 0.) {
- return 0;
- }
- if (lsame_(trans, "N", (ftnlen)1, (ftnlen)1)) {
-
-/* Form y := alpha*A*x + y. */
-
- jx = kx;
- if (*incy == 1) {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- if (x[jx] != 0.) {
- temp = *alpha * x[jx];
- i__2 = *m;
- for (i__ = 1; i__ <= i__2; ++i__) {
- y[i__] += temp * a[i__ + j * a_dim1];
-/* L50: */
- }
- }
- jx += *incx;
-/* L60: */
- }
- } else {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- if (x[jx] != 0.) {
- temp = *alpha * x[jx];
- iy = ky;
- i__2 = *m;
- for (i__ = 1; i__ <= i__2; ++i__) {
- y[iy] += temp * a[i__ + j * a_dim1];
- iy += *incy;
-/* L70: */
- }
- }
- jx += *incx;
-/* L80: */
- }
- }
- } else {
-
-/* Form y := alpha*A'*x + y. */
-
- jy = ky;
- if (*incx == 1) {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- temp = 0.;
- i__2 = *m;
- for (i__ = 1; i__ <= i__2; ++i__) {
- temp += a[i__ + j * a_dim1] * x[i__];
-/* L90: */
- }
- y[jy] += *alpha * temp;
- jy += *incy;
-/* L100: */
- }
- } else {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- temp = 0.;
- ix = kx;
- i__2 = *m;
- for (i__ = 1; i__ <= i__2; ++i__) {
- temp += a[i__ + j * a_dim1] * x[ix];
- ix += *incx;
-/* L110: */
- }
- y[jy] += *alpha * temp;
- jy += *incy;
-/* L120: */
- }
- }
- }
-
- return 0;
-
-/* End of DGEMV . */
-
-} /* dgemv_ */
-
-/* Subroutine */ int dger_(integer *m, integer *n, doublereal *alpha,
- doublereal *x, integer *incx, doublereal *y, integer *incy,
- doublereal *a, integer *lda)
-{
- /* System generated locals */
- integer a_dim1, a_offset, i__1, i__2;
-
- /* Local variables */
- static integer i__, j, ix, jy, kx, info;
- static doublereal temp;
- extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen);
-
-/* .. Scalar Arguments .. */
-/* .. Array Arguments .. */
-/* .. */
-
-/* Purpose */
-/* ======= */
-
-/* DGER performs the rank 1 operation */
-
-/* A := alpha*x*y' + A, */
-
-/* where alpha is a scalar, x is an m element vector, y is an n element */
-/* vector and A is an m by n matrix. */
-
-/* Parameters */
-/* ========== */
-
-/* M - INTEGER. */
-/* On entry, M specifies the number of rows of the matrix A. */
-/* M must be at least zero. */
-/* Unchanged on exit. */
-
-/* N - INTEGER. */
-/* On entry, N specifies the number of columns of the matrix A. */
-/* N must be at least zero. */
-/* Unchanged on exit. */
-
-/* ALPHA - DOUBLE PRECISION. */
-/* On entry, ALPHA specifies the scalar alpha. */
-/* Unchanged on exit. */
-
-/* X - DOUBLE PRECISION array of dimension at least */
-/* ( 1 + ( m - 1 )*abs( INCX ) ). */
-/* Before entry, the incremented array X must contain the m */
-/* element vector x. */
-/* Unchanged on exit. */
-
-/* INCX - INTEGER. */
-/* On entry, INCX specifies the increment for the elements of */
-/* X. INCX must not be zero. */
-/* Unchanged on exit. */
-
-/* Y - DOUBLE PRECISION array of dimension at least */
-/* ( 1 + ( n - 1 )*abs( INCY ) ). */
-/* Before entry, the incremented array Y must contain the n */
-/* element vector y. */
-/* Unchanged on exit. */
-
-/* INCY - INTEGER. */
-/* On entry, INCY specifies the increment for the elements of */
-/* Y. INCY must not be zero. */
-/* Unchanged on exit. */
-
-/* A - DOUBLE PRECISION array of DIMENSION ( LDA, n ). */
-/* Before entry, the leading m by n part of the array A must */
-/* contain the matrix of coefficients. On exit, A is */
-/* overwritten by the updated matrix. */
-
-/* LDA - INTEGER. */
-/* On entry, LDA specifies the first dimension of A as declared */
-/* in the calling (sub) program. LDA must be at least */
-/* max( 1, m ). */
-/* Unchanged on exit. */
-
-
-/* Level 2 Blas routine. */
-
-/* -- Written on 22-October-1986. */
-/* Jack Dongarra, Argonne National Lab. */
-/* Jeremy Du Croz, Nag Central Office. */
-/* Sven Hammarling, Nag Central Office. */
-/* Richard Hanson, Sandia National Labs. */
-
-
-/* .. Parameters .. */
-/* .. Local Scalars .. */
-/* .. External Subroutines .. */
-/* .. Intrinsic Functions .. */
-/* .. */
-/* .. Executable Statements .. */
-
-/* Test the input parameters. */
-
- /* Parameter adjustments */
- --x;
- --y;
- a_dim1 = *lda;
- a_offset = 1 + a_dim1 * 1;
- a -= a_offset;
-
- /* Function Body */
- info = 0;
- if (*m < 0) {
- info = 1;
- } else if (*n < 0) {
- info = 2;
- } else if (*incx == 0) {
- info = 5;
- } else if (*incy == 0) {
- info = 7;
- } else if (*lda < max(1,*m)) {
- info = 9;
- }
- if (info != 0) {
- xerbla_("DGER ", &info, (ftnlen)6);
- return 0;
- }
-
-/* Quick return if possible. */
-
- if (*m == 0 || *n == 0 || *alpha == 0.) {
- return 0;
- }
-
-/* Start the operations. In this version the elements of A are */
-/* accessed sequentially with one pass through A. */
-
- if (*incy > 0) {
- jy = 1;
- } else {
- jy = 1 - (*n - 1) * *incy;
- }
- if (*incx == 1) {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- if (y[jy] != 0.) {
- temp = *alpha * y[jy];
- i__2 = *m;
- for (i__ = 1; i__ <= i__2; ++i__) {
- a[i__ + j * a_dim1] += x[i__] * temp;
-/* L10: */
- }
- }
- jy += *incy;
-/* L20: */
- }
- } else {
- if (*incx > 0) {
- kx = 1;
- } else {
- kx = 1 - (*m - 1) * *incx;
- }
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- if (y[jy] != 0.) {
- temp = *alpha * y[jy];
- ix = kx;
- i__2 = *m;
- for (i__ = 1; i__ <= i__2; ++i__) {
- a[i__ + j * a_dim1] += x[ix] * temp;
- ix += *incx;
-/* L30: */
- }
- }
- jy += *incy;
-/* L40: */
- }
- }
-
- return 0;
-
-/* End of DGER . */
-
-} /* dger_ */
-
-doublereal dnrm2_(integer *n, doublereal *x, integer *incx)
-{
- /* System generated locals */
- integer i__1, i__2;
- doublereal ret_val, d__1;
-
- /* Builtin functions */
- double sqrt(doublereal);
-
- /* Local variables */
- static integer ix;
- static doublereal ssq, norm, scale, absxi;
-
-/* .. Scalar Arguments .. */
-/* .. Array Arguments .. */
-/* .. */
-
-/* DNRM2 returns the euclidean norm of a vector via the function */
-/* name, so that */
-
-/* DNRM2 := sqrt( x'*x ) */
-
-
-
-/* -- This version written on 25-October-1982. */
-/* Modified on 14-October-1993 to inline the call to DLASSQ. */
-/* Sven Hammarling, Nag Ltd. */
-
-
-/* .. Parameters .. */
-/* .. Local Scalars .. */
-/* .. Intrinsic Functions .. */
-/* .. */
-/* .. Executable Statements .. */
- /* Parameter adjustments */
- --x;
-
- /* Function Body */
- if (*n < 1 || *incx < 1) {
- norm = 0.;
- } else if (*n == 1) {
- norm = abs(x[1]);
- } else {
- scale = 0.;
- ssq = 1.;
-/* The following loop is equivalent to this call to the LAPACK */
-/* auxiliary routine: */
-/* CALL DLASSQ( N, X, INCX, SCALE, SSQ ) */
-
- i__1 = (*n - 1) * *incx + 1;
- i__2 = *incx;
- for (ix = 1; i__2 < 0 ? ix >= i__1 : ix <= i__1; ix += i__2) {
- if (x[ix] != 0.) {
- absxi = (d__1 = x[ix], abs(d__1));
- if (scale < absxi) {
-/* Computing 2nd power */
- d__1 = scale / absxi;
- ssq = ssq * (d__1 * d__1) + 1.;
- scale = absxi;
- } else {
-/* Computing 2nd power */
- d__1 = absxi / scale;
- ssq += d__1 * d__1;
- }
- }
-/* L10: */
- }
- norm = scale * sqrt(ssq);
- }
-
- ret_val = norm;
- return ret_val;
-
-/* End of DNRM2. */
-
-} /* dnrm2_ */
-
-/* Subroutine */ int drot_(integer *n, doublereal *dx, integer *incx,
- doublereal *dy, integer *incy, doublereal *c__, doublereal *s)
-{
- /* System generated locals */
- integer i__1;
-
- /* Local variables */
- static integer i__, ix, iy;
- static doublereal dtemp;
-
-
-/* applies a plane rotation. */
-/* jack dongarra, linpack, 3/11/78. */
-/* modified 12/3/93, array(1) declarations changed to array(*) */
-
-
- /* Parameter adjustments */
- --dy;
- --dx;
-
- /* Function Body */
- if (*n <= 0) {
- return 0;
- }
- if (*incx == 1 && *incy == 1) {
- goto L20;
- }
-
-/* code for unequal increments or equal increments not equal */
-/* to 1 */
-
- ix = 1;
- iy = 1;
- if (*incx < 0) {
- ix = (-(*n) + 1) * *incx + 1;
- }
- if (*incy < 0) {
- iy = (-(*n) + 1) * *incy + 1;
- }
- i__1 = *n;
- for (i__ = 1; i__ <= i__1; ++i__) {
- dtemp = *c__ * dx[ix] + *s * dy[iy];
- dy[iy] = *c__ * dy[iy] - *s * dx[ix];
- dx[ix] = dtemp;
- ix += *incx;
- iy += *incy;
-/* L10: */
- }
- return 0;
-
-/* code for both increments equal to 1 */
-
-L20:
- i__1 = *n;
- for (i__ = 1; i__ <= i__1; ++i__) {
- dtemp = *c__ * dx[i__] + *s * dy[i__];
- dy[i__] = *c__ * dy[i__] - *s * dx[i__];
- dx[i__] = dtemp;
-/* L30: */
- }
- return 0;
-} /* drot_ */
-
-/* Subroutine */ int drotg_(doublereal *da, doublereal *db, doublereal *c__,
- doublereal *s)
-{
- /* System generated locals */
- doublereal d__1, d__2;
-
- /* Builtin functions */
- double sqrt(doublereal), d_sign(doublereal *, doublereal *);
-
- /* Local variables */
- static doublereal r__, z__, roe, scale;
-
-
-/* construct givens plane rotation. */
-/* jack dongarra, linpack, 3/11/78. */
-
-
- roe = *db;
- if (abs(*da) > abs(*db)) {
- roe = *da;
- }
- scale = abs(*da) + abs(*db);
- if (scale != 0.) {
- goto L10;
- }
- *c__ = 1.;
- *s = 0.;
- r__ = 0.;
- z__ = 0.;
- goto L20;
-L10:
-/* Computing 2nd power */
- d__1 = *da / scale;
-/* Computing 2nd power */
- d__2 = *db / scale;
- r__ = scale * sqrt(d__1 * d__1 + d__2 * d__2);
- r__ = d_sign(&c_b876, &roe) * r__;
- *c__ = *da / r__;
- *s = *db / r__;
- z__ = 1.;
- if (abs(*da) > abs(*db)) {
- z__ = *s;
- }
- if (abs(*db) >= abs(*da) && *c__ != 0.) {
- z__ = 1. / *c__;
- }
-L20:
- *da = r__;
- *db = z__;
- return 0;
-} /* drotg_ */
-
-/* Subroutine */ int drotm_(integer *n, doublereal *dx, integer *incx,
- doublereal *dy, integer *incy, doublereal *dparam)
-{
- /* Initialized data */
-
- static doublereal zero = 0.;
- static doublereal two = 2.;
-
- /* System generated locals */
- integer i__1, i__2;
-
- /* Local variables */
- static integer i__;
- static doublereal w, z__;
- static integer kx, ky;
- static doublereal dh11, dh12, dh22, dh21, dflag;
- static integer nsteps;
-
-
-/* APPLY THE MODIFIED GIVENS TRANSFORMATION, H, TO THE 2 BY N MATRIX */
-
-/* (DX**T) , WHERE **T INDICATES TRANSPOSE. THE ELEMENTS OF DX ARE IN */
-/* (DY**T) */
-
-/* DX(LX+I*INCX), I = 0 TO N-1, WHERE LX = 1 IF INCX .GE. 0, ELSE */
-/* LX = (-INCX)*N, AND SIMILARLY FOR SY USING LY AND INCY. */
-/* WITH DPARAM(1)=DFLAG, H HAS ONE OF THE FOLLOWING FORMS.. */
-
-/* DFLAG=-1.D0 DFLAG=0.D0 DFLAG=1.D0 DFLAG=-2.D0 */
-
-/* (DH11 DH12) (1.D0 DH12) (DH11 1.D0) (1.D0 0.D0) */
-/* H=( ) ( ) ( ) ( ) */
-/* (DH21 DH22), (DH21 1.D0), (-1.D0 DH22), (0.D0 1.D0). */
-/* SEE DROTMG FOR A DESCRIPTION OF DATA STORAGE IN DPARAM. */
-
- /* Parameter adjustments */
- --dparam;
- --dy;
- --dx;
-
- /* Function Body */
-
- dflag = dparam[1];
- if (*n <= 0 || dflag + two == zero) {
- goto L140;
- }
- if (! (*incx == *incy && *incx > 0)) {
- goto L70;
- }
-
- nsteps = *n * *incx;
- if (dflag < 0.) {
- goto L50;
- } else if (dflag == 0) {
- goto L10;
- } else {
- goto L30;
- }
-L10:
- dh12 = dparam[4];
- dh21 = dparam[3];
- i__1 = nsteps;
- i__2 = *incx;
- for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
- w = dx[i__];
- z__ = dy[i__];
- dx[i__] = w + z__ * dh12;
- dy[i__] = w * dh21 + z__;
-/* L20: */
- }
- goto L140;
-L30:
- dh11 = dparam[2];
- dh22 = dparam[5];
- i__2 = nsteps;
- i__1 = *incx;
- for (i__ = 1; i__1 < 0 ? i__ >= i__2 : i__ <= i__2; i__ += i__1) {
- w = dx[i__];
- z__ = dy[i__];
- dx[i__] = w * dh11 + z__;
- dy[i__] = -w + dh22 * z__;
-/* L40: */
- }
- goto L140;
-L50:
- dh11 = dparam[2];
- dh12 = dparam[4];
- dh21 = dparam[3];
- dh22 = dparam[5];
- i__1 = nsteps;
- i__2 = *incx;
- for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
- w = dx[i__];
- z__ = dy[i__];
- dx[i__] = w * dh11 + z__ * dh12;
- dy[i__] = w * dh21 + z__ * dh22;
-/* L60: */
- }
- goto L140;
-L70:
- kx = 1;
- ky = 1;
- if (*incx < 0) {
- kx = (1 - *n) * *incx + 1;
- }
- if (*incy < 0) {
- ky = (1 - *n) * *incy + 1;
- }
-
- if (dflag < 0.) {
- goto L120;
- } else if (dflag == 0) {
- goto L80;
- } else {
- goto L100;
- }
-L80:
- dh12 = dparam[4];
- dh21 = dparam[3];
- i__2 = *n;
- for (i__ = 1; i__ <= i__2; ++i__) {
- w = dx[kx];
- z__ = dy[ky];
- dx[kx] = w + z__ * dh12;
- dy[ky] = w * dh21 + z__;
- kx += *incx;
- ky += *incy;
-/* L90: */
- }
- goto L140;
-L100:
- dh11 = dparam[2];
- dh22 = dparam[5];
- i__2 = *n;
- for (i__ = 1; i__ <= i__2; ++i__) {
- w = dx[kx];
- z__ = dy[ky];
- dx[kx] = w * dh11 + z__;
- dy[ky] = -w + dh22 * z__;
- kx += *incx;
- ky += *incy;
-/* L110: */
- }
- goto L140;
-L120:
- dh11 = dparam[2];
- dh12 = dparam[4];
- dh21 = dparam[3];
- dh22 = dparam[5];
- i__2 = *n;
- for (i__ = 1; i__ <= i__2; ++i__) {
- w = dx[kx];
- z__ = dy[ky];
- dx[kx] = w * dh11 + z__ * dh12;
- dy[ky] = w * dh21 + z__ * dh22;
- kx += *incx;
- ky += *incy;
-/* L130: */
- }
-L140:
- return 0;
-} /* drotm_ */
-
-/* Subroutine */ int drotmg_(doublereal *dd1, doublereal *dd2, doublereal *
- dx1, doublereal *dy1, doublereal *dparam)
-{
- /* Initialized data */
-
- static doublereal zero = 0.;
- static doublereal one = 1.;
- static doublereal two = 2.;
- static doublereal gam = 4096.;
- static doublereal gamsq = 16777216.;
- static doublereal rgamsq = 5.9604645e-8;
-
- /* Format strings */
- static char fmt_120[] = "";
- static char fmt_150[] = "";
- static char fmt_180[] = "";
- static char fmt_210[] = "";
-
- /* System generated locals */
- doublereal d__1;
-
- /* Local variables */
- static doublereal du, dp1, dp2, dq2, dq1, dh11, dh21, dh12, dh22;
- static integer igo;
- static doublereal dflag, dtemp;
-
- /* Assigned format variables */
- static char *igo_fmt;
-
-
-/* CONSTRUCT THE MODIFIED GIVENS TRANSFORMATION MATRIX H WHICH ZEROS */
-/* THE SECOND COMPONENT OF THE 2-VECTOR (DSQRT(DD1)*DX1,DSQRT(DD2)* */
-/* DY2)**T. */
-/* WITH DPARAM(1)=DFLAG, H HAS ONE OF THE FOLLOWING FORMS.. */
-
-/* DFLAG=-1.D0 DFLAG=0.D0 DFLAG=1.D0 DFLAG=-2.D0 */
-
-/* (DH11 DH12) (1.D0 DH12) (DH11 1.D0) (1.D0 0.D0) */
-/* H=( ) ( ) ( ) ( ) */
-/* (DH21 DH22), (DH21 1.D0), (-1.D0 DH22), (0.D0 1.D0). */
-/* LOCATIONS 2-4 OF DPARAM CONTAIN DH11, DH21, DH12, AND DH22 */
-/* RESPECTIVELY. (VALUES OF 1.D0, -1.D0, OR 0.D0 IMPLIED BY THE */
-/* VALUE OF DPARAM(1) ARE NOT STORED IN DPARAM.) */
-
-/* THE VALUES OF GAMSQ AND RGAMSQ SET IN THE DATA STATEMENT MAY BE */
-/* INEXACT. THIS IS OK AS THEY ARE ONLY USED FOR TESTING THE SIZE */
-/* OF DD1 AND DD2. ALL ACTUAL SCALING OF DATA IS DONE USING GAM. */
-
-
- /* Parameter adjustments */
- --dparam;
-
- /* Function Body */
- if (! (*dd1 < zero)) {
- goto L10;
- }
-/* GO ZERO-H-D-AND-DX1.. */
- goto L60;
-L10:
-/* CASE-DD1-NONNEGATIVE */
- dp2 = *dd2 * *dy1;
- if (! (dp2 == zero)) {
- goto L20;
- }
- dflag = -two;
- goto L260;
-/* REGULAR-CASE.. */
-L20:
- dp1 = *dd1 * *dx1;
- dq2 = dp2 * *dy1;
- dq1 = dp1 * *dx1;
-
- if (! (abs(dq1) > abs(dq2))) {
- goto L40;
- }
- dh21 = -(*dy1) / *dx1;
- dh12 = dp2 / dp1;
-
- du = one - dh12 * dh21;
-
- if (! (du <= zero)) {
- goto L30;
- }
-/* GO ZERO-H-D-AND-DX1.. */
- goto L60;
-L30:
- dflag = zero;
- *dd1 /= du;
- *dd2 /= du;
- *dx1 *= du;
-/* GO SCALE-CHECK.. */
- goto L100;
-L40:
- if (! (dq2 < zero)) {
- goto L50;
- }
-/* GO ZERO-H-D-AND-DX1.. */
- goto L60;
-L50:
- dflag = one;
- dh11 = dp1 / dp2;
- dh22 = *dx1 / *dy1;
- du = one + dh11 * dh22;
- dtemp = *dd2 / du;
- *dd2 = *dd1 / du;
- *dd1 = dtemp;
- *dx1 = *dy1 * du;
-/* GO SCALE-CHECK */
- goto L100;
-/* PROCEDURE..ZERO-H-D-AND-DX1.. */
-L60:
- dflag = -one;
- dh11 = zero;
- dh12 = zero;
- dh21 = zero;
- dh22 = zero;
-
- *dd1 = zero;
- *dd2 = zero;
- *dx1 = zero;
-/* RETURN.. */
- goto L220;
-/* PROCEDURE..FIX-H.. */
-L70:
- if (! (dflag >= zero)) {
- goto L90;
- }
-
- if (! (dflag == zero)) {
- goto L80;
- }
- dh11 = one;
- dh22 = one;
- dflag = -one;
- goto L90;
-L80:
- dh21 = -one;
- dh12 = one;
- dflag = -one;
-L90:
- switch (igo) {
- case 0: goto L120;
- case 1: goto L150;
- case 2: goto L180;
- case 3: goto L210;
- }
-/* PROCEDURE..SCALE-CHECK */
-L100:
-L110:
- if (! (*dd1 <= rgamsq)) {
- goto L130;
- }
- if (*dd1 == zero) {
- goto L160;
- }
- igo = 0;
- igo_fmt = fmt_120;
-/* FIX-H.. */
- goto L70;
-L120:
-/* Computing 2nd power */
- d__1 = gam;
- *dd1 *= d__1 * d__1;
- *dx1 /= gam;
- dh11 /= gam;
- dh12 /= gam;
- goto L110;
-L130:
-L140:
- if (! (*dd1 >= gamsq)) {
- goto L160;
- }
- igo = 1;
- igo_fmt = fmt_150;
-/* FIX-H.. */
- goto L70;
-L150:
-/* Computing 2nd power */
- d__1 = gam;
- *dd1 /= d__1 * d__1;
- *dx1 *= gam;
- dh11 *= gam;
- dh12 *= gam;
- goto L140;
-L160:
-L170:
- if (! (abs(*dd2) <= rgamsq)) {
- goto L190;
- }
- if (*dd2 == zero) {
- goto L220;
- }
- igo = 2;
- igo_fmt = fmt_180;
-/* FIX-H.. */
- goto L70;
-L180:
-/* Computing 2nd power */
- d__1 = gam;
- *dd2 *= d__1 * d__1;
- dh21 /= gam;
- dh22 /= gam;
- goto L170;
-L190:
-L200:
- if (! (abs(*dd2) >= gamsq)) {
- goto L220;
- }
- igo = 3;
- igo_fmt = fmt_210;
-/* FIX-H.. */
- goto L70;
-L210:
-/* Computing 2nd power */
- d__1 = gam;
- *dd2 /= d__1 * d__1;
- dh21 *= gam;
- dh22 *= gam;
- goto L200;
-L220:
- if (dflag < 0.) {
- goto L250;
- } else if (dflag == 0) {
- goto L230;
- } else {
- goto L240;
- }
-L230:
- dparam[3] = dh21;
- dparam[4] = dh12;
- goto L260;
-L240:
- dparam[2] = dh11;
- dparam[5] = dh22;
- goto L260;
-L250:
- dparam[2] = dh11;
- dparam[3] = dh21;
- dparam[4] = dh12;
- dparam[5] = dh22;
-L260:
- dparam[1] = dflag;
- return 0;
-} /* drotmg_ */
-
-/* Subroutine */ int dsbmv_(char *uplo, integer *n, integer *k, doublereal *
- alpha, doublereal *a, integer *lda, doublereal *x, integer *incx,
- doublereal *beta, doublereal *y, integer *incy, ftnlen uplo_len)
-{
- /* System generated locals */
- integer a_dim1, a_offset, i__1, i__2, i__3, i__4;
-
- /* Local variables */
- static integer i__, j, l, ix, iy, jx, jy, kx, ky, info;
- static doublereal temp1, temp2;
- extern logical lsame_(char *, char *, ftnlen, ftnlen);
- static integer kplus1;
- extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen);
-
-/* .. Scalar Arguments .. */
-/* .. Array Arguments .. */
-/* .. */
-
-/* Purpose */
-/* ======= */
-
-/* DSBMV performs the matrix-vector operation */
-
-/* y := alpha*A*x + beta*y, */
-
-/* where alpha and beta are scalars, x and y are n element vectors and */
-/* A is an n by n symmetric band matrix, with k super-diagonals. */
-
-/* Parameters */
-/* ========== */
-
-/* UPLO - CHARACTER*1. */
-/* On entry, UPLO specifies whether the upper or lower */
-/* triangular part of the band matrix A is being supplied as */
-/* follows: */
-
-/* UPLO = 'U' or 'u' The upper triangular part of A is */
-/* being supplied. */
-
-/* UPLO = 'L' or 'l' The lower triangular part of A is */
-/* being supplied. */
-
-/* Unchanged on exit. */
-
-/* N - INTEGER. */
-/* On entry, N specifies the order of the matrix A. */
-/* N must be at least zero. */
-/* Unchanged on exit. */
-
-/* K - INTEGER. */
-/* On entry, K specifies the number of super-diagonals of the */
-/* matrix A. K must satisfy 0 .le. K. */
-/* Unchanged on exit. */
-
-/* ALPHA - DOUBLE PRECISION. */
-/* On entry, ALPHA specifies the scalar alpha. */
-/* Unchanged on exit. */
-
-/* A - DOUBLE PRECISION array of DIMENSION ( LDA, n ). */
-/* Before entry with UPLO = 'U' or 'u', the leading ( k + 1 ) */
-/* by n part of the array A must contain the upper triangular */
-/* band part of the symmetric matrix, supplied column by */
-/* column, with the leading diagonal of the matrix in row */
-/* ( k + 1 ) of the array, the first super-diagonal starting at */
-/* position 2 in row k, and so on. The top left k by k triangle */
-/* of the array A is not referenced. */
-/* The following program segment will transfer the upper */
-/* triangular part of a symmetric band matrix from conventional */
-/* full matrix storage to band storage: */
-
-/* DO 20, J = 1, N */
-/* M = K + 1 - J */
-/* DO 10, I = MAX( 1, J - K ), J */
-/* A( M + I, J ) = matrix( I, J ) */
-/* 10 CONTINUE */
-/* 20 CONTINUE */
-
-/* Before entry with UPLO = 'L' or 'l', the leading ( k + 1 ) */
-/* by n part of the array A must contain the lower triangular */
-/* band part of the symmetric matrix, supplied column by */
-/* column, with the leading diagonal of the matrix in row 1 of */
-/* the array, the first sub-diagonal starting at position 1 in */
-/* row 2, and so on. The bottom right k by k triangle of the */
-/* array A is not referenced. */
-/* The following program segment will transfer the lower */
-/* triangular part of a symmetric band matrix from conventional */
-/* full matrix storage to band storage: */
-
-/* DO 20, J = 1, N */
-/* M = 1 - J */
-/* DO 10, I = J, MIN( N, J + K ) */
-/* A( M + I, J ) = matrix( I, J ) */
-/* 10 CONTINUE */
-/* 20 CONTINUE */
-
-/* Unchanged on exit. */
-
-/* LDA - INTEGER. */
-/* On entry, LDA specifies the first dimension of A as declared */
-/* in the calling (sub) program. LDA must be at least */
-/* ( k + 1 ). */
-/* Unchanged on exit. */
-
-/* X - DOUBLE PRECISION array of DIMENSION at least */
-/* ( 1 + ( n - 1 )*abs( INCX ) ). */
-/* Before entry, the incremented array X must contain the */
-/* vector x. */
-/* Unchanged on exit. */
-
-/* INCX - INTEGER. */
-/* On entry, INCX specifies the increment for the elements of */
-/* X. INCX must not be zero. */
-/* Unchanged on exit. */
-
-/* BETA - DOUBLE PRECISION. */
-/* On entry, BETA specifies the scalar beta. */
-/* Unchanged on exit. */
-
-/* Y - DOUBLE PRECISION array of DIMENSION at least */
-/* ( 1 + ( n - 1 )*abs( INCY ) ). */
-/* Before entry, the incremented array Y must contain the */
-/* vector y. On exit, Y is overwritten by the updated vector y. */
-
-/* INCY - INTEGER. */
-/* On entry, INCY specifies the increment for the elements of */
-/* Y. INCY must not be zero. */
-/* Unchanged on exit. */
-
-
-/* Level 2 Blas routine. */
-
-/* -- Written on 22-October-1986. */
-/* Jack Dongarra, Argonne National Lab. */
-/* Jeremy Du Croz, Nag Central Office. */
-/* Sven Hammarling, Nag Central Office. */
-/* Richard Hanson, Sandia National Labs. */
-
-
-/* .. Parameters .. */
-/* .. Local Scalars .. */
-/* .. External Functions .. */
-/* .. External Subroutines .. */
-/* .. Intrinsic Functions .. */
-/* .. */
-/* .. Executable Statements .. */
-
-/* Test the input parameters. */
-
- /* Parameter adjustments */
- a_dim1 = *lda;
- a_offset = 1 + a_dim1 * 1;
- a -= a_offset;
- --x;
- --y;
-
- /* Function Body */
- info = 0;
- if (! lsame_(uplo, "U", (ftnlen)1, (ftnlen)1) && ! lsame_(uplo, "L", (
- ftnlen)1, (ftnlen)1)) {
- info = 1;
- } else if (*n < 0) {
- info = 2;
- } else if (*k < 0) {
- info = 3;
- } else if (*lda < *k + 1) {
- info = 6;
- } else if (*incx == 0) {
- info = 8;
- } else if (*incy == 0) {
- info = 11;
- }
- if (info != 0) {
- xerbla_("DSBMV ", &info, (ftnlen)6);
- return 0;
- }
-
-/* Quick return if possible. */
-
- if (*n == 0 || *alpha == 0. && *beta == 1.) {
- return 0;
- }
-
-/* Set up the start points in X and Y. */
-
- if (*incx > 0) {
- kx = 1;
- } else {
- kx = 1 - (*n - 1) * *incx;
- }
- if (*incy > 0) {
- ky = 1;
- } else {
- ky = 1 - (*n - 1) * *incy;
- }
-
-/* Start the operations. In this version the elements of the array A */
-/* are accessed sequentially with one pass through A. */
-
-/* First form y := beta*y. */
-
- if (*beta != 1.) {
- if (*incy == 1) {
- if (*beta == 0.) {
- i__1 = *n;
- for (i__ = 1; i__ <= i__1; ++i__) {
- y[i__] = 0.;
-/* L10: */
- }
- } else {
- i__1 = *n;
- for (i__ = 1; i__ <= i__1; ++i__) {
- y[i__] = *beta * y[i__];
-/* L20: */
- }
- }
- } else {
- iy = ky;
- if (*beta == 0.) {
- i__1 = *n;
- for (i__ = 1; i__ <= i__1; ++i__) {
- y[iy] = 0.;
- iy += *incy;
-/* L30: */
- }
- } else {
- i__1 = *n;
- for (i__ = 1; i__ <= i__1; ++i__) {
- y[iy] = *beta * y[iy];
- iy += *incy;
-/* L40: */
- }
- }
- }
- }
- if (*alpha == 0.) {
- return 0;
- }
- if (lsame_(uplo, "U", (ftnlen)1, (ftnlen)1)) {
-
-/* Form y when upper triangle of A is stored. */
-
- kplus1 = *k + 1;
- if (*incx == 1 && *incy == 1) {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- temp1 = *alpha * x[j];
- temp2 = 0.;
- l = kplus1 - j;
-/* Computing MAX */
- i__2 = 1, i__3 = j - *k;
- i__4 = j - 1;
- for (i__ = max(i__2,i__3); i__ <= i__4; ++i__) {
- y[i__] += temp1 * a[l + i__ + j * a_dim1];
- temp2 += a[l + i__ + j * a_dim1] * x[i__];
-/* L50: */
- }
- y[j] = y[j] + temp1 * a[kplus1 + j * a_dim1] + *alpha * temp2;
-/* L60: */
- }
- } else {
- jx = kx;
- jy = ky;
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- temp1 = *alpha * x[jx];
- temp2 = 0.;
- ix = kx;
- iy = ky;
- l = kplus1 - j;
-/* Computing MAX */
- i__4 = 1, i__2 = j - *k;
- i__3 = j - 1;
- for (i__ = max(i__4,i__2); i__ <= i__3; ++i__) {
- y[iy] += temp1 * a[l + i__ + j * a_dim1];
- temp2 += a[l + i__ + j * a_dim1] * x[ix];
- ix += *incx;
- iy += *incy;
-/* L70: */
- }
- y[jy] = y[jy] + temp1 * a[kplus1 + j * a_dim1] + *alpha *
- temp2;
- jx += *incx;
- jy += *incy;
- if (j > *k) {
- kx += *incx;
- ky += *incy;
- }
-/* L80: */
- }
- }
- } else {
-
-/* Form y when lower triangle of A is stored. */
-
- if (*incx == 1 && *incy == 1) {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- temp1 = *alpha * x[j];
- temp2 = 0.;
- y[j] += temp1 * a[j * a_dim1 + 1];
- l = 1 - j;
-/* Computing MIN */
- i__4 = *n, i__2 = j + *k;
- i__3 = min(i__4,i__2);
- for (i__ = j + 1; i__ <= i__3; ++i__) {
- y[i__] += temp1 * a[l + i__ + j * a_dim1];
- temp2 += a[l + i__ + j * a_dim1] * x[i__];
-/* L90: */
- }
- y[j] += *alpha * temp2;
-/* L100: */
- }
- } else {
- jx = kx;
- jy = ky;
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- temp1 = *alpha * x[jx];
- temp2 = 0.;
- y[jy] += temp1 * a[j * a_dim1 + 1];
- l = 1 - j;
- ix = jx;
- iy = jy;
-/* Computing MIN */
- i__4 = *n, i__2 = j + *k;
- i__3 = min(i__4,i__2);
- for (i__ = j + 1; i__ <= i__3; ++i__) {
- ix += *incx;
- iy += *incy;
- y[iy] += temp1 * a[l + i__ + j * a_dim1];
- temp2 += a[l + i__ + j * a_dim1] * x[ix];
-/* L110: */
- }
- y[jy] += *alpha * temp2;
- jx += *incx;
- jy += *incy;
-/* L120: */
- }
- }
- }
-
- return 0;
-
-/* End of DSBMV . */
-
-} /* dsbmv_ */
-
-/* Subroutine */ int dscal_(integer *n, doublereal *da, doublereal *dx,
- integer *incx)
-{
- /* System generated locals */
- integer i__1, i__2;
-
- /* Local variables */
- static integer i__, m, mp1, nincx;
-
-
-/* scales a vector by a constant. */
-/* uses unrolled loops for increment equal to one. */
-/* jack dongarra, linpack, 3/11/78. */
-/* modified 3/93 to return if incx .le. 0. */
-/* modified 12/3/93, array(1) declarations changed to array(*) */
-
-
- /* Parameter adjustments */
- --dx;
-
- /* Function Body */
- if (*n <= 0 || *incx <= 0) {
- return 0;
- }
- if (*incx == 1) {
- goto L20;
- }
-
-/* code for increment not equal to 1 */
-
- nincx = *n * *incx;
- i__1 = nincx;
- i__2 = *incx;
- for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
- dx[i__] = *da * dx[i__];
-/* L10: */
- }
- return 0;
-
-/* code for increment equal to 1 */
-
-
-/* clean-up loop */
-
-L20:
- m = *n % 5;
- if (m == 0) {
- goto L40;
- }
- i__2 = m;
- for (i__ = 1; i__ <= i__2; ++i__) {
- dx[i__] = *da * dx[i__];
-/* L30: */
- }
- if (*n < 5) {
- return 0;
- }
-L40:
- mp1 = m + 1;
- i__2 = *n;
- for (i__ = mp1; i__ <= i__2; i__ += 5) {
- dx[i__] = *da * dx[i__];
- dx[i__ + 1] = *da * dx[i__ + 1];
- dx[i__ + 2] = *da * dx[i__ + 2];
- dx[i__ + 3] = *da * dx[i__ + 3];
- dx[i__ + 4] = *da * dx[i__ + 4];
-/* L50: */
- }
- return 0;
-} /* dscal_ */
-
-/* DECK DSDOT */
-doublereal dsdot_(integer *n, real *sx, integer *incx, real *sy, integer *
- incy)
-{
- /* System generated locals */
- integer i__1, i__2;
- doublereal ret_val;
-
- /* Local variables */
- static integer i__, ns, kx, ky;
-
-/* ***BEGIN PROLOGUE DSDOT */
-/* ***PURPOSE Compute the inner product of two vectors with extended */
-/* precision accumulation and result. */
-/* ***LIBRARY SLATEC (BLAS) */
-/* ***CATEGORY D1A4 */
-/* ***TYPE DOUBLE PRECISION (DSDOT-D, DCDOT-C) */
-/* ***KEYWORDS BLAS, COMPLEX VECTORS, DOT PRODUCT, INNER PRODUCT, */
-/* LINEAR ALGEBRA, VECTOR */
-/* ***AUTHOR Lawson, C. L., (JPL) */
-/* Hanson, R. J., (SNLA) */
-/* Kincaid, D. R., (U. of Texas) */
-/* Krogh, F. T., (JPL) */
-/* ***DESCRIPTION */
-
-/* B L A S Subprogram */
-/* Description of Parameters */
-
-/* --Input-- */
-/* N number of elements in input vector(s) */
-/* SX single precision vector with N elements */
-/* INCX storage spacing between elements of SX */
-/* SY single precision vector with N elements */
-/* INCY storage spacing between elements of SY */
-
-/* --Output-- */
-/* DSDOT double precision dot product (zero if N.LE.0) */
-
-/* Returns D.P. dot product accumulated in D.P., for S.P. SX and SY */
-/* DSDOT = sum for I = 0 to N-1 of SX(LX+I*INCX) * SY(LY+I*INCY), */
-/* where LX = 1 if INCX .GE. 0, else LX = 1+(1-N)*INCX, and LY is */
-/* defined in a similar way using INCY. */
-
-/* ***REFERENCES C. L. Lawson, R. J. Hanson, D. R. Kincaid and F. T. */
-/* Krogh, Basic linear algebra subprograms for Fortran */
-/* usage, Algorithm No. 539, Transactions on Mathematical */
-/* Software 5, 3 (September 1979), pp. 308-323. */
-/* ***ROUTINES CALLED (NONE) */
-/* ***REVISION HISTORY (YYMMDD) */
-/* 791001 DATE WRITTEN */
-/* 890831 Modified array declarations. (WRB) */
-/* 890831 REVISION DATE from Version 3.2 */
-/* 891214 Prologue converted to Version 4.0 format. (BAB) */
-/* 920310 Corrected definition of LX in DESCRIPTION. (WRB) */
-/* 920501 Reformatted the REFERENCES section. (WRB) */
-/* ***END PROLOGUE DSDOT */
-/* ***FIRST EXECUTABLE STATEMENT DSDOT */
- /* Parameter adjustments */
- --sy;
- --sx;
-
- /* Function Body */
- ret_val = 0.;
- if (*n <= 0) {
- return ret_val;
- }
- if (*incx == *incy && *incx > 0) {
- goto L20;
- }
-
-/* Code for unequal or nonpositive increments. */
-
- kx = 1;
- ky = 1;
- if (*incx < 0) {
- kx = (1 - *n) * *incx + 1;
- }
- if (*incy < 0) {
- ky = (1 - *n) * *incy + 1;
- }
- i__1 = *n;
- for (i__ = 1; i__ <= i__1; ++i__) {
- ret_val += (doublereal) sx[kx] * (doublereal) sy[ky];
- kx += *incx;
- ky += *incy;
-/* L10: */
- }
- return ret_val;
-
-/* Code for equal, positive, non-unit increments. */
-
-L20:
- ns = *n * *incx;
- i__1 = ns;
- i__2 = *incx;
- for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
- ret_val += (doublereal) sx[i__] * (doublereal) sy[i__];
-/* L30: */
- }
- return ret_val;
-} /* dsdot_ */
-
-/* Subroutine */ int dspmv_(char *uplo, integer *n, doublereal *alpha,
- doublereal *ap, doublereal *x, integer *incx, doublereal *beta,
- doublereal *y, integer *incy, ftnlen uplo_len)
-{
- /* System generated locals */
- integer i__1, i__2;
-
- /* Local variables */
- static integer i__, j, k, kk, ix, iy, jx, jy, kx, ky, info;
- static doublereal temp1, temp2;
- extern logical lsame_(char *, char *, ftnlen, ftnlen);
- extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen);
-
-/* .. Scalar Arguments .. */
-/* .. Array Arguments .. */
-/* .. */
-
-/* Purpose */
-/* ======= */
-
-/* DSPMV performs the matrix-vector operation */
-
-/* y := alpha*A*x + beta*y, */
-
-/* where alpha and beta are scalars, x and y are n element vectors and */
-/* A is an n by n symmetric matrix, supplied in packed form. */
-
-/* Parameters */
-/* ========== */
-
-/* UPLO - CHARACTER*1. */
-/* On entry, UPLO specifies whether the upper or lower */
-/* triangular part of the matrix A is supplied in the packed */
-/* array AP as follows: */
-
-/* UPLO = 'U' or 'u' The upper triangular part of A is */
-/* supplied in AP. */
-
-/* UPLO = 'L' or 'l' The lower triangular part of A is */
-/* supplied in AP. */
-
-/* Unchanged on exit. */
-
-/* N - INTEGER. */
-/* On entry, N specifies the order of the matrix A. */
-/* N must be at least zero. */
-/* Unchanged on exit. */
-
-/* ALPHA - DOUBLE PRECISION. */
-/* On entry, ALPHA specifies the scalar alpha. */
-/* Unchanged on exit. */
-
-/* AP - DOUBLE PRECISION array of DIMENSION at least */
-/* ( ( n*( n + 1 ) )/2 ). */
-/* Before entry with UPLO = 'U' or 'u', the array AP must */
-/* contain the upper triangular part of the symmetric matrix */
-/* packed sequentially, column by column, so that AP( 1 ) */
-/* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 ) */
-/* and a( 2, 2 ) respectively, and so on. */
-/* Before entry with UPLO = 'L' or 'l', the array AP must */
-/* contain the lower triangular part of the symmetric matrix */
-/* packed sequentially, column by column, so that AP( 1 ) */
-/* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 ) */
-/* and a( 3, 1 ) respectively, and so on. */
-/* Unchanged on exit. */
-
-/* X - DOUBLE PRECISION array of dimension at least */
-/* ( 1 + ( n - 1 )*abs( INCX ) ). */
-/* Before entry, the incremented array X must contain the n */
-/* element vector x. */
-/* Unchanged on exit. */
-
-/* INCX - INTEGER. */
-/* On entry, INCX specifies the increment for the elements of */
-/* X. INCX must not be zero. */
-/* Unchanged on exit. */
-
-/* BETA - DOUBLE PRECISION. */
-/* On entry, BETA specifies the scalar beta. When BETA is */
-/* supplied as zero then Y need not be set on input. */
-/* Unchanged on exit. */
-
-/* Y - DOUBLE PRECISION array of dimension at least */
-/* ( 1 + ( n - 1 )*abs( INCY ) ). */
-/* Before entry, the incremented array Y must contain the n */
-/* element vector y. On exit, Y is overwritten by the updated */
-/* vector y. */
-
-/* INCY - INTEGER. */
-/* On entry, INCY specifies the increment for the elements of */
-/* Y. INCY must not be zero. */
-/* Unchanged on exit. */
-
-
-/* Level 2 Blas routine. */
-
-/* -- Written on 22-October-1986. */
-/* Jack Dongarra, Argonne National Lab. */
-/* Jeremy Du Croz, Nag Central Office. */
-/* Sven Hammarling, Nag Central Office. */
-/* Richard Hanson, Sandia National Labs. */
-
-
-/* .. Parameters .. */
-/* .. Local Scalars .. */
-/* .. External Functions .. */
-/* .. External Subroutines .. */
-/* .. */
-/* .. Executable Statements .. */
-
-/* Test the input parameters. */
-
- /* Parameter adjustments */
- --y;
- --x;
- --ap;
-
- /* Function Body */
- info = 0;
- if (! lsame_(uplo, "U", (ftnlen)1, (ftnlen)1) && ! lsame_(uplo, "L", (
- ftnlen)1, (ftnlen)1)) {
- info = 1;
- } else if (*n < 0) {
- info = 2;
- } else if (*incx == 0) {
- info = 6;
- } else if (*incy == 0) {
- info = 9;
- }
- if (info != 0) {
- xerbla_("DSPMV ", &info, (ftnlen)6);
- return 0;
- }
-
-/* Quick return if possible. */
-
- if (*n == 0 || *alpha == 0. && *beta == 1.) {
- return 0;
- }
-
-/* Set up the start points in X and Y. */
-
- if (*incx > 0) {
- kx = 1;
- } else {
- kx = 1 - (*n - 1) * *incx;
- }
- if (*incy > 0) {
- ky = 1;
- } else {
- ky = 1 - (*n - 1) * *incy;
- }
-
-/* Start the operations. In this version the elements of the array AP */
-/* are accessed sequentially with one pass through AP. */
-
-/* First form y := beta*y. */
-
- if (*beta != 1.) {
- if (*incy == 1) {
- if (*beta == 0.) {
- i__1 = *n;
- for (i__ = 1; i__ <= i__1; ++i__) {
- y[i__] = 0.;
-/* L10: */
- }
- } else {
- i__1 = *n;
- for (i__ = 1; i__ <= i__1; ++i__) {
- y[i__] = *beta * y[i__];
-/* L20: */
- }
- }
- } else {
- iy = ky;
- if (*beta == 0.) {
- i__1 = *n;
- for (i__ = 1; i__ <= i__1; ++i__) {
- y[iy] = 0.;
- iy += *incy;
-/* L30: */
- }
- } else {
- i__1 = *n;
- for (i__ = 1; i__ <= i__1; ++i__) {
- y[iy] = *beta * y[iy];
- iy += *incy;
-/* L40: */
- }
- }
- }
- }
- if (*alpha == 0.) {
- return 0;
- }
- kk = 1;
- if (lsame_(uplo, "U", (ftnlen)1, (ftnlen)1)) {
-
-/* Form y when AP contains the upper triangle. */
-
- if (*incx == 1 && *incy == 1) {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- temp1 = *alpha * x[j];
- temp2 = 0.;
- k = kk;
- i__2 = j - 1;
- for (i__ = 1; i__ <= i__2; ++i__) {
- y[i__] += temp1 * ap[k];
- temp2 += ap[k] * x[i__];
- ++k;
-/* L50: */
- }
- y[j] = y[j] + temp1 * ap[kk + j - 1] + *alpha * temp2;
- kk += j;
-/* L60: */
- }
- } else {
- jx = kx;
- jy = ky;
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- temp1 = *alpha * x[jx];
- temp2 = 0.;
- ix = kx;
- iy = ky;
- i__2 = kk + j - 2;
- for (k = kk; k <= i__2; ++k) {
- y[iy] += temp1 * ap[k];
- temp2 += ap[k] * x[ix];
- ix += *incx;
- iy += *incy;
-/* L70: */
- }
- y[jy] = y[jy] + temp1 * ap[kk + j - 1] + *alpha * temp2;
- jx += *incx;
- jy += *incy;
- kk += j;
-/* L80: */
- }
- }
- } else {
-
-/* Form y when AP contains the lower triangle. */
-
- if (*incx == 1 && *incy == 1) {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- temp1 = *alpha * x[j];
- temp2 = 0.;
- y[j] += temp1 * ap[kk];
- k = kk + 1;
- i__2 = *n;
- for (i__ = j + 1; i__ <= i__2; ++i__) {
- y[i__] += temp1 * ap[k];
- temp2 += ap[k] * x[i__];
- ++k;
-/* L90: */
- }
- y[j] += *alpha * temp2;
- kk += *n - j + 1;
-/* L100: */
- }
- } else {
- jx = kx;
- jy = ky;
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- temp1 = *alpha * x[jx];
- temp2 = 0.;
- y[jy] += temp1 * ap[kk];
- ix = jx;
- iy = jy;
- i__2 = kk + *n - j;
- for (k = kk + 1; k <= i__2; ++k) {
- ix += *incx;
- iy += *incy;
- y[iy] += temp1 * ap[k];
- temp2 += ap[k] * x[ix];
-/* L110: */
- }
- y[jy] += *alpha * temp2;
- jx += *incx;
- jy += *incy;
- kk += *n - j + 1;
-/* L120: */
- }
- }
- }
-
- return 0;
-
-/* End of DSPMV . */
-
-} /* dspmv_ */
-
-/* Subroutine */ int dspr_(char *uplo, integer *n, doublereal *alpha,
- doublereal *x, integer *incx, doublereal *ap, ftnlen uplo_len)
-{
- /* System generated locals */
- integer i__1, i__2;
-
- /* Local variables */
- static integer i__, j, k, kk, ix, jx, kx, info;
- static doublereal temp;
- extern logical lsame_(char *, char *, ftnlen, ftnlen);
- extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen);
-
-/* .. Scalar Arguments .. */
-/* .. Array Arguments .. */
-/* .. */
-
-/* Purpose */
-/* ======= */
-
-/* DSPR performs the symmetric rank 1 operation */
-
-/* A := alpha*x*x' + A, */
-
-/* where alpha is a real scalar, x is an n element vector and A is an */
-/* n by n symmetric matrix, supplied in packed form. */
-
-/* Parameters */
-/* ========== */
-
-/* UPLO - CHARACTER*1. */
-/* On entry, UPLO specifies whether the upper or lower */
-/* triangular part of the matrix A is supplied in the packed */
-/* array AP as follows: */
-
-/* UPLO = 'U' or 'u' The upper triangular part of A is */
-/* supplied in AP. */
-
-/* UPLO = 'L' or 'l' The lower triangular part of A is */
-/* supplied in AP. */
-
-/* Unchanged on exit. */
-
-/* N - INTEGER. */
-/* On entry, N specifies the order of the matrix A. */
-/* N must be at least zero. */
-/* Unchanged on exit. */
-
-/* ALPHA - DOUBLE PRECISION. */
-/* On entry, ALPHA specifies the scalar alpha. */
-/* Unchanged on exit. */
-
-/* X - DOUBLE PRECISION array of dimension at least */
-/* ( 1 + ( n - 1 )*abs( INCX ) ). */
-/* Before entry, the incremented array X must contain the n */
-/* element vector x. */
-/* Unchanged on exit. */
-
-/* INCX - INTEGER. */
-/* On entry, INCX specifies the increment for the elements of */
-/* X. INCX must not be zero. */
-/* Unchanged on exit. */
-
-/* AP - DOUBLE PRECISION array of DIMENSION at least */
-/* ( ( n*( n + 1 ) )/2 ). */
-/* Before entry with UPLO = 'U' or 'u', the array AP must */
-/* contain the upper triangular part of the symmetric matrix */
-/* packed sequentially, column by column, so that AP( 1 ) */
-/* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 ) */
-/* and a( 2, 2 ) respectively, and so on. On exit, the array */
-/* AP is overwritten by the upper triangular part of the */
-/* updated matrix. */
-/* Before entry with UPLO = 'L' or 'l', the array AP must */
-/* contain the lower triangular part of the symmetric matrix */
-/* packed sequentially, column by column, so that AP( 1 ) */
-/* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 ) */
-/* and a( 3, 1 ) respectively, and so on. On exit, the array */
-/* AP is overwritten by the lower triangular part of the */
-/* updated matrix. */
-
-
-/* Level 2 Blas routine. */
-
-/* -- Written on 22-October-1986. */
-/* Jack Dongarra, Argonne National Lab. */
-/* Jeremy Du Croz, Nag Central Office. */
-/* Sven Hammarling, Nag Central Office. */
-/* Richard Hanson, Sandia National Labs. */
-
-
-/* .. Parameters .. */
-/* .. Local Scalars .. */
-/* .. External Functions .. */
-/* .. External Subroutines .. */
-/* .. */
-/* .. Executable Statements .. */
-
-/* Test the input parameters. */
-
- /* Parameter adjustments */
- --ap;
- --x;
-
- /* Function Body */
- info = 0;
- if (! lsame_(uplo, "U", (ftnlen)1, (ftnlen)1) && ! lsame_(uplo, "L", (
- ftnlen)1, (ftnlen)1)) {
- info = 1;
- } else if (*n < 0) {
- info = 2;
- } else if (*incx == 0) {
- info = 5;
- }
- if (info != 0) {
- xerbla_("DSPR ", &info, (ftnlen)6);
- return 0;
- }
-
-/* Quick return if possible. */
-
- if (*n == 0 || *alpha == 0.) {
- return 0;
- }
-
-/* Set the start point in X if the increment is not unity. */
-
- if (*incx <= 0) {
- kx = 1 - (*n - 1) * *incx;
- } else if (*incx != 1) {
- kx = 1;
- }
-
-/* Start the operations. In this version the elements of the array AP */
-/* are accessed sequentially with one pass through AP. */
-
- kk = 1;
- if (lsame_(uplo, "U", (ftnlen)1, (ftnlen)1)) {
-
-/* Form A when upper triangle is stored in AP. */
-
- if (*incx == 1) {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- if (x[j] != 0.) {
- temp = *alpha * x[j];
- k = kk;
- i__2 = j;
- for (i__ = 1; i__ <= i__2; ++i__) {
- ap[k] += x[i__] * temp;
- ++k;
-/* L10: */
- }
- }
- kk += j;
-/* L20: */
- }
- } else {
- jx = kx;
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- if (x[jx] != 0.) {
- temp = *alpha * x[jx];
- ix = kx;
- i__2 = kk + j - 1;
- for (k = kk; k <= i__2; ++k) {
- ap[k] += x[ix] * temp;
- ix += *incx;
-/* L30: */
- }
- }
- jx += *incx;
- kk += j;
-/* L40: */
- }
- }
- } else {
-
-/* Form A when lower triangle is stored in AP. */
-
- if (*incx == 1) {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- if (x[j] != 0.) {
- temp = *alpha * x[j];
- k = kk;
- i__2 = *n;
- for (i__ = j; i__ <= i__2; ++i__) {
- ap[k] += x[i__] * temp;
- ++k;
-/* L50: */
- }
- }
- kk = kk + *n - j + 1;
-/* L60: */
- }
- } else {
- jx = kx;
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- if (x[jx] != 0.) {
- temp = *alpha * x[jx];
- ix = jx;
- i__2 = kk + *n - j;
- for (k = kk; k <= i__2; ++k) {
- ap[k] += x[ix] * temp;
- ix += *incx;
-/* L70: */
- }
- }
- jx += *incx;
- kk = kk + *n - j + 1;
-/* L80: */
- }
- }
- }
-
- return 0;
-
-/* End of DSPR . */
-
-} /* dspr_ */
-
-/* Subroutine */ int dspr2_(char *uplo, integer *n, doublereal *alpha,
- doublereal *x, integer *incx, doublereal *y, integer *incy,
- doublereal *ap, ftnlen uplo_len)
-{
- /* System generated locals */
- integer i__1, i__2;
-
- /* Local variables */
- static integer i__, j, k, kk, ix, iy, jx, jy, kx, ky, info;
- static doublereal temp1, temp2;
- extern logical lsame_(char *, char *, ftnlen, ftnlen);
- extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen);
-
-/* .. Scalar Arguments .. */
-/* .. Array Arguments .. */
-/* .. */
-
-/* Purpose */
-/* ======= */
-
-/* DSPR2 performs the symmetric rank 2 operation */
-
-/* A := alpha*x*y' + alpha*y*x' + A, */
-
-/* where alpha is a scalar, x and y are n element vectors and A is an */
-/* n by n symmetric matrix, supplied in packed form. */
-
-/* Parameters */
-/* ========== */
-
-/* UPLO - CHARACTER*1. */
-/* On entry, UPLO specifies whether the upper or lower */
-/* triangular part of the matrix A is supplied in the packed */
-/* array AP as follows: */
-
-/* UPLO = 'U' or 'u' The upper triangular part of A is */
-/* supplied in AP. */
-
-/* UPLO = 'L' or 'l' The lower triangular part of A is */
-/* supplied in AP. */
-
-/* Unchanged on exit. */
-
-/* N - INTEGER. */
-/* On entry, N specifies the order of the matrix A. */
-/* N must be at least zero. */
-/* Unchanged on exit. */
-
-/* ALPHA - DOUBLE PRECISION. */
-/* On entry, ALPHA specifies the scalar alpha. */
-/* Unchanged on exit. */
-
-/* X - DOUBLE PRECISION array of dimension at least */
-/* ( 1 + ( n - 1 )*abs( INCX ) ). */
-/* Before entry, the incremented array X must contain the n */
-/* element vector x. */
-/* Unchanged on exit. */
-
-/* INCX - INTEGER. */
-/* On entry, INCX specifies the increment for the elements of */
-/* X. INCX must not be zero. */
-/* Unchanged on exit. */
-
-/* Y - DOUBLE PRECISION array of dimension at least */
-/* ( 1 + ( n - 1 )*abs( INCY ) ). */
-/* Before entry, the incremented array Y must contain the n */
-/* element vector y. */
-/* Unchanged on exit. */
-
-/* INCY - INTEGER. */
-/* On entry, INCY specifies the increment for the elements of */
-/* Y. INCY must not be zero. */
-/* Unchanged on exit. */
-
-/* AP - DOUBLE PRECISION array of DIMENSION at least */
-/* ( ( n*( n + 1 ) )/2 ). */
-/* Before entry with UPLO = 'U' or 'u', the array AP must */
-/* contain the upper triangular part of the symmetric matrix */
-/* packed sequentially, column by column, so that AP( 1 ) */
-/* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 ) */
-/* and a( 2, 2 ) respectively, and so on. On exit, the array */
-/* AP is overwritten by the upper triangular part of the */
-/* updated matrix. */
-/* Before entry with UPLO = 'L' or 'l', the array AP must */
-/* contain the lower triangular part of the symmetric matrix */
-/* packed sequentially, column by column, so that AP( 1 ) */
-/* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 ) */
-/* and a( 3, 1 ) respectively, and so on. On exit, the array */
-/* AP is overwritten by the lower triangular part of the */
-/* updated matrix. */
-
-
-/* Level 2 Blas routine. */
-
-/* -- Written on 22-October-1986. */
-/* Jack Dongarra, Argonne National Lab. */
-/* Jeremy Du Croz, Nag Central Office. */
-/* Sven Hammarling, Nag Central Office. */
-/* Richard Hanson, Sandia National Labs. */
-
-
-/* .. Parameters .. */
-/* .. Local Scalars .. */
-/* .. External Functions .. */
-/* .. External Subroutines .. */
-/* .. */
-/* .. Executable Statements .. */
-
-/* Test the input parameters. */
-
- /* Parameter adjustments */
- --ap;
- --y;
- --x;
-
- /* Function Body */
- info = 0;
- if (! lsame_(uplo, "U", (ftnlen)1, (ftnlen)1) && ! lsame_(uplo, "L", (
- ftnlen)1, (ftnlen)1)) {
- info = 1;
- } else if (*n < 0) {
- info = 2;
- } else if (*incx == 0) {
- info = 5;
- } else if (*incy == 0) {
- info = 7;
- }
- if (info != 0) {
- xerbla_("DSPR2 ", &info, (ftnlen)6);
- return 0;
- }
-
-/* Quick return if possible. */
-
- if (*n == 0 || *alpha == 0.) {
- return 0;
- }
-
-/* Set up the start points in X and Y if the increments are not both */
-/* unity. */
-
- if (*incx != 1 || *incy != 1) {
- if (*incx > 0) {
- kx = 1;
- } else {
- kx = 1 - (*n - 1) * *incx;
- }
- if (*incy > 0) {
- ky = 1;
- } else {
- ky = 1 - (*n - 1) * *incy;
- }
- jx = kx;
- jy = ky;
- }
-
-/* Start the operations. In this version the elements of the array AP */
-/* are accessed sequentially with one pass through AP. */
-
- kk = 1;
- if (lsame_(uplo, "U", (ftnlen)1, (ftnlen)1)) {
-
-/* Form A when upper triangle is stored in AP. */
-
- if (*incx == 1 && *incy == 1) {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- if (x[j] != 0. || y[j] != 0.) {
- temp1 = *alpha * y[j];
- temp2 = *alpha * x[j];
- k = kk;
- i__2 = j;
- for (i__ = 1; i__ <= i__2; ++i__) {
- ap[k] = ap[k] + x[i__] * temp1 + y[i__] * temp2;
- ++k;
-/* L10: */
- }
- }
- kk += j;
-/* L20: */
- }
- } else {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- if (x[jx] != 0. || y[jy] != 0.) {
- temp1 = *alpha * y[jy];
- temp2 = *alpha * x[jx];
- ix = kx;
- iy = ky;
- i__2 = kk + j - 1;
- for (k = kk; k <= i__2; ++k) {
- ap[k] = ap[k] + x[ix] * temp1 + y[iy] * temp2;
- ix += *incx;
- iy += *incy;
-/* L30: */
- }
- }
- jx += *incx;
- jy += *incy;
- kk += j;
-/* L40: */
- }
- }
- } else {
-
-/* Form A when lower triangle is stored in AP. */
-
- if (*incx == 1 && *incy == 1) {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- if (x[j] != 0. || y[j] != 0.) {
- temp1 = *alpha * y[j];
- temp2 = *alpha * x[j];
- k = kk;
- i__2 = *n;
- for (i__ = j; i__ <= i__2; ++i__) {
- ap[k] = ap[k] + x[i__] * temp1 + y[i__] * temp2;
- ++k;
-/* L50: */
- }
- }
- kk = kk + *n - j + 1;
-/* L60: */
- }
- } else {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- if (x[jx] != 0. || y[jy] != 0.) {
- temp1 = *alpha * y[jy];
- temp2 = *alpha * x[jx];
- ix = jx;
- iy = jy;
- i__2 = kk + *n - j;
- for (k = kk; k <= i__2; ++k) {
- ap[k] = ap[k] + x[ix] * temp1 + y[iy] * temp2;
- ix += *incx;
- iy += *incy;
-/* L70: */
- }
- }
- jx += *incx;
- jy += *incy;
- kk = kk + *n - j + 1;
-/* L80: */
- }
- }
- }
-
- return 0;
-
-/* End of DSPR2 . */
-
-} /* dspr2_ */
-
-/* Subroutine */ int dswap_(integer *n, doublereal *dx, integer *incx,
- doublereal *dy, integer *incy)
-{
- /* System generated locals */
- integer i__1;
-
- /* Local variables */
- static integer i__, m, ix, iy, mp1;
- static doublereal dtemp;
-
-
-/* interchanges two vectors. */
-/* uses unrolled loops for increments equal one. */
-/* jack dongarra, linpack, 3/11/78. */
-/* modified 12/3/93, array(1) declarations changed to array(*) */
-
-
- /* Parameter adjustments */
- --dy;
- --dx;
-
- /* Function Body */
- if (*n <= 0) {
- return 0;
- }
- if (*incx == 1 && *incy == 1) {
- goto L20;
- }
-
-/* code for unequal increments or equal increments not equal */
-/* to 1 */
-
- ix = 1;
- iy = 1;
- if (*incx < 0) {
- ix = (-(*n) + 1) * *incx + 1;
- }
- if (*incy < 0) {
- iy = (-(*n) + 1) * *incy + 1;
- }
- i__1 = *n;
- for (i__ = 1; i__ <= i__1; ++i__) {
- dtemp = dx[ix];
- dx[ix] = dy[iy];
- dy[iy] = dtemp;
- ix += *incx;
- iy += *incy;
-/* L10: */
- }
- return 0;
-
-/* code for both increments equal to 1 */
-
-
-/* clean-up loop */
-
-L20:
- m = *n % 3;
- if (m == 0) {
- goto L40;
- }
- i__1 = m;
- for (i__ = 1; i__ <= i__1; ++i__) {
- dtemp = dx[i__];
- dx[i__] = dy[i__];
- dy[i__] = dtemp;
-/* L30: */
- }
- if (*n < 3) {
- return 0;
- }
-L40:
- mp1 = m + 1;
- i__1 = *n;
- for (i__ = mp1; i__ <= i__1; i__ += 3) {
- dtemp = dx[i__];
- dx[i__] = dy[i__];
- dy[i__] = dtemp;
- dtemp = dx[i__ + 1];
- dx[i__ + 1] = dy[i__ + 1];
- dy[i__ + 1] = dtemp;
- dtemp = dx[i__ + 2];
- dx[i__ + 2] = dy[i__ + 2];
- dy[i__ + 2] = dtemp;
-/* L50: */
- }
- return 0;
-} /* dswap_ */
-
-/* Subroutine */ int dsymm_(char *side, char *uplo, integer *m, integer *n,
- doublereal *alpha, doublereal *a, integer *lda, doublereal *b,
- integer *ldb, doublereal *beta, doublereal *c__, integer *ldc, ftnlen
- side_len, ftnlen uplo_len)
-{
- /* System generated locals */
- integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2,
- i__3;
-
- /* Local variables */
- static integer i__, j, k, info;
- static doublereal temp1, temp2;
- extern logical lsame_(char *, char *, ftnlen, ftnlen);
- static integer nrowa;
- static logical upper;
- extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen);
-
-/* .. Scalar Arguments .. */
-/* .. Array Arguments .. */
-/* .. */
-
-/* Purpose */
-/* ======= */
-
-/* DSYMM performs one of the matrix-matrix operations */
-
-/* C := alpha*A*B + beta*C, */
-
-/* or */
-
-/* C := alpha*B*A + beta*C, */
-
-/* where alpha and beta are scalars, A is a symmetric matrix and B and */
-/* C are m by n matrices. */
-
-/* Parameters */
-/* ========== */
-
-/* SIDE - CHARACTER*1. */
-/* On entry, SIDE specifies whether the symmetric matrix A */
-/* appears on the left or right in the operation as follows: */
-
-/* SIDE = 'L' or 'l' C := alpha*A*B + beta*C, */
-
-/* SIDE = 'R' or 'r' C := alpha*B*A + beta*C, */
-
-/* Unchanged on exit. */
-
-/* UPLO - CHARACTER*1. */
-/* On entry, UPLO specifies whether the upper or lower */
-/* triangular part of the symmetric matrix A is to be */
-/* referenced as follows: */
-
-/* UPLO = 'U' or 'u' Only the upper triangular part of the */
-/* symmetric matrix is to be referenced. */
-
-/* UPLO = 'L' or 'l' Only the lower triangular part of the */
-/* symmetric matrix is to be referenced. */
-
-/* Unchanged on exit. */
-
-/* M - INTEGER. */
-/* On entry, M specifies the number of rows of the matrix C. */
-/* M must be at least zero. */
-/* Unchanged on exit. */
-
-/* N - INTEGER. */
-/* On entry, N specifies the number of columns of the matrix C. */
-/* N must be at least zero. */
-/* Unchanged on exit. */
-
-/* ALPHA - DOUBLE PRECISION. */
-/* On entry, ALPHA specifies the scalar alpha. */
-/* Unchanged on exit. */
-
-/* A - DOUBLE PRECISION array of DIMENSION ( LDA, ka ), where ka is */
-/* m when SIDE = 'L' or 'l' and is n otherwise. */
-/* Before entry with SIDE = 'L' or 'l', the m by m part of */
-/* the array A must contain the symmetric matrix, such that */
-/* when UPLO = 'U' or 'u', the leading m by m upper triangular */
-/* part of the array A must contain the upper triangular part */
-/* of the symmetric matrix and the strictly lower triangular */
-/* part of A is not referenced, and when UPLO = 'L' or 'l', */
-/* the leading m by m lower triangular part of the array A */
-/* must contain the lower triangular part of the symmetric */
-/* matrix and the strictly upper triangular part of A is not */
-/* referenced. */
-/* Before entry with SIDE = 'R' or 'r', the n by n part of */
-/* the array A must contain the symmetric matrix, such that */
-/* when UPLO = 'U' or 'u', the leading n by n upper triangular */
-/* part of the array A must contain the upper triangular part */
-/* of the symmetric matrix and the strictly lower triangular */
-/* part of A is not referenced, and when UPLO = 'L' or 'l', */
-/* the leading n by n lower triangular part of the array A */
-/* must contain the lower triangular part of the symmetric */
-/* matrix and the strictly upper triangular part of A is not */
-/* referenced. */
-/* Unchanged on exit. */
-
-/* LDA - INTEGER. */
-/* On entry, LDA specifies the first dimension of A as declared */
-/* in the calling (sub) program. When SIDE = 'L' or 'l' then */
-/* LDA must be at least max( 1, m ), otherwise LDA must be at */
-/* least max( 1, n ). */
-/* Unchanged on exit. */
-
-/* B - DOUBLE PRECISION array of DIMENSION ( LDB, n ). */
-/* Before entry, the leading m by n part of the array B must */
-/* contain the matrix B. */
-/* Unchanged on exit. */
-
-/* LDB - INTEGER. */
-/* On entry, LDB specifies the first dimension of B as declared */
-/* in the calling (sub) program. LDB must be at least */
-/* max( 1, m ). */
-/* Unchanged on exit. */
-
-/* BETA - DOUBLE PRECISION. */
-/* On entry, BETA specifies the scalar beta. When BETA is */
-/* supplied as zero then C need not be set on input. */
-/* Unchanged on exit. */
-
-/* C - DOUBLE PRECISION array of DIMENSION ( LDC, n ). */
-/* Before entry, the leading m by n part of the array C must */
-/* contain the matrix C, except when beta is zero, in which */
-/* case C need not be set on entry. */
-/* On exit, the array C is overwritten by the m by n updated */
-/* matrix. */
-
-/* LDC - INTEGER. */
-/* On entry, LDC specifies the first dimension of C as declared */
-/* in the calling (sub) program. LDC must be at least */
-/* max( 1, m ). */
-/* Unchanged on exit. */
-
-
-/* Level 3 Blas routine. */
-
-/* -- Written on 8-February-1989. */
-/* Jack Dongarra, Argonne National Laboratory. */
-/* Iain Duff, AERE Harwell. */
-/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */
-/* Sven Hammarling, Numerical Algorithms Group Ltd. */
-
-
-/* .. External Functions .. */
-/* .. External Subroutines .. */
-/* .. Intrinsic Functions .. */
-/* .. Local Scalars .. */
-/* .. Parameters .. */
-/* .. */
-/* .. Executable Statements .. */
-
-/* Set NROWA as the number of rows of A. */
-
- /* Parameter adjustments */
- a_dim1 = *lda;
- a_offset = 1 + a_dim1 * 1;
- a -= a_offset;
- b_dim1 = *ldb;
- b_offset = 1 + b_dim1 * 1;
- b -= b_offset;
- c_dim1 = *ldc;
- c_offset = 1 + c_dim1 * 1;
- c__ -= c_offset;
-
- /* Function Body */
- if (lsame_(side, "L", (ftnlen)1, (ftnlen)1)) {
- nrowa = *m;
- } else {
- nrowa = *n;
- }
- upper = lsame_(uplo, "U", (ftnlen)1, (ftnlen)1);
-
-/* Test the input parameters. */
-
- info = 0;
- if (! lsame_(side, "L", (ftnlen)1, (ftnlen)1) && ! lsame_(side, "R", (
- ftnlen)1, (ftnlen)1)) {
- info = 1;
- } else if (! upper && ! lsame_(uplo, "L", (ftnlen)1, (ftnlen)1)) {
- info = 2;
- } else if (*m < 0) {
- info = 3;
- } else if (*n < 0) {
- info = 4;
- } else if (*lda < max(1,nrowa)) {
- info = 7;
- } else if (*ldb < max(1,*m)) {
- info = 9;
- } else if (*ldc < max(1,*m)) {
- info = 12;
- }
- if (info != 0) {
- xerbla_("DSYMM ", &info, (ftnlen)6);
- return 0;
- }
-
-/* Quick return if possible. */
-
- if (*m == 0 || *n == 0 || *alpha == 0. && *beta == 1.) {
- return 0;
- }
-
-/* And when alpha.eq.zero. */
-
- if (*alpha == 0.) {
- if (*beta == 0.) {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- i__2 = *m;
- for (i__ = 1; i__ <= i__2; ++i__) {
- c__[i__ + j * c_dim1] = 0.;
-/* L10: */
- }
-/* L20: */
- }
- } else {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- i__2 = *m;
- for (i__ = 1; i__ <= i__2; ++i__) {
- c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1];
-/* L30: */
- }
-/* L40: */
- }
- }
- return 0;
- }
-
-/* Start the operations. */
-
- if (lsame_(side, "L", (ftnlen)1, (ftnlen)1)) {
-
-/* Form C := alpha*A*B + beta*C. */
-
- if (upper) {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- i__2 = *m;
- for (i__ = 1; i__ <= i__2; ++i__) {
- temp1 = *alpha * b[i__ + j * b_dim1];
- temp2 = 0.;
- i__3 = i__ - 1;
- for (k = 1; k <= i__3; ++k) {
- c__[k + j * c_dim1] += temp1 * a[k + i__ * a_dim1];
- temp2 += b[k + j * b_dim1] * a[k + i__ * a_dim1];
-/* L50: */
- }
- if (*beta == 0.) {
- c__[i__ + j * c_dim1] = temp1 * a[i__ + i__ * a_dim1]
- + *alpha * temp2;
- } else {
- c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1]
- + temp1 * a[i__ + i__ * a_dim1] + *alpha *
- temp2;
- }
-/* L60: */
- }
-/* L70: */
- }
- } else {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- for (i__ = *m; i__ >= 1; --i__) {
- temp1 = *alpha * b[i__ + j * b_dim1];
- temp2 = 0.;
- i__2 = *m;
- for (k = i__ + 1; k <= i__2; ++k) {
- c__[k + j * c_dim1] += temp1 * a[k + i__ * a_dim1];
- temp2 += b[k + j * b_dim1] * a[k + i__ * a_dim1];
-/* L80: */
- }
- if (*beta == 0.) {
- c__[i__ + j * c_dim1] = temp1 * a[i__ + i__ * a_dim1]
- + *alpha * temp2;
- } else {
- c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1]
- + temp1 * a[i__ + i__ * a_dim1] + *alpha *
- temp2;
- }
-/* L90: */
- }
-/* L100: */
- }
- }
- } else {
-
-/* Form C := alpha*B*A + beta*C. */
-
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- temp1 = *alpha * a[j + j * a_dim1];
- if (*beta == 0.) {
- i__2 = *m;
- for (i__ = 1; i__ <= i__2; ++i__) {
- c__[i__ + j * c_dim1] = temp1 * b[i__ + j * b_dim1];
-/* L110: */
- }
- } else {
- i__2 = *m;
- for (i__ = 1; i__ <= i__2; ++i__) {
- c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1] +
- temp1 * b[i__ + j * b_dim1];
-/* L120: */
- }
- }
- i__2 = j - 1;
- for (k = 1; k <= i__2; ++k) {
- if (upper) {
- temp1 = *alpha * a[k + j * a_dim1];
- } else {
- temp1 = *alpha * a[j + k * a_dim1];
- }
- i__3 = *m;
- for (i__ = 1; i__ <= i__3; ++i__) {
- c__[i__ + j * c_dim1] += temp1 * b[i__ + k * b_dim1];
-/* L130: */
- }
-/* L140: */
- }
- i__2 = *n;
- for (k = j + 1; k <= i__2; ++k) {
- if (upper) {
- temp1 = *alpha * a[j + k * a_dim1];
- } else {
- temp1 = *alpha * a[k + j * a_dim1];
- }
- i__3 = *m;
- for (i__ = 1; i__ <= i__3; ++i__) {
- c__[i__ + j * c_dim1] += temp1 * b[i__ + k * b_dim1];
-/* L150: */
- }
-/* L160: */
- }
-/* L170: */
- }
- }
-
- return 0;
-
-/* End of DSYMM . */
-
-} /* dsymm_ */
-
-/* Subroutine */ int dsymv_(char *uplo, integer *n, doublereal *alpha,
- doublereal *a, integer *lda, doublereal *x, integer *incx, doublereal
- *beta, doublereal *y, integer *incy, ftnlen uplo_len)
-{
- /* System generated locals */
- integer a_dim1, a_offset, i__1, i__2;
-
- /* Local variables */
- static integer i__, j, ix, iy, jx, jy, kx, ky, info;
- static doublereal temp1, temp2;
- extern logical lsame_(char *, char *, ftnlen, ftnlen);
- extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen);
-
-/* .. Scalar Arguments .. */
-/* .. Array Arguments .. */
-/* .. */
-
-/* Purpose */
-/* ======= */
-
-/* DSYMV performs the matrix-vector operation */
-
-/* y := alpha*A*x + beta*y, */
-
-/* where alpha and beta are scalars, x and y are n element vectors and */
-/* A is an n by n symmetric matrix. */
-
-/* Parameters */
-/* ========== */
-
-/* UPLO - CHARACTER*1. */
-/* On entry, UPLO specifies whether the upper or lower */
-/* triangular part of the array A is to be referenced as */
-/* follows: */
-
-/* UPLO = 'U' or 'u' Only the upper triangular part of A */
-/* is to be referenced. */
-
-/* UPLO = 'L' or 'l' Only the lower triangular part of A */
-/* is to be referenced. */
-
-/* Unchanged on exit. */
-
-/* N - INTEGER. */
-/* On entry, N specifies the order of the matrix A. */
-/* N must be at least zero. */
-/* Unchanged on exit. */
-
-/* ALPHA - DOUBLE PRECISION. */
-/* On entry, ALPHA specifies the scalar alpha. */
-/* Unchanged on exit. */
-
-/* A - DOUBLE PRECISION array of DIMENSION ( LDA, n ). */
-/* Before entry with UPLO = 'U' or 'u', the leading n by n */
-/* upper triangular part of the array A must contain the upper */
-/* triangular part of the symmetric matrix and the strictly */
-/* lower triangular part of A is not referenced. */
-/* Before entry with UPLO = 'L' or 'l', the leading n by n */
-/* lower triangular part of the array A must contain the lower */
-/* triangular part of the symmetric matrix and the strictly */
-/* upper triangular part of A is not referenced. */
-/* Unchanged on exit. */
-
-/* LDA - INTEGER. */
-/* On entry, LDA specifies the first dimension of A as declared */
-/* in the calling (sub) program. LDA must be at least */
-/* max( 1, n ). */
-/* Unchanged on exit. */
-
-/* X - DOUBLE PRECISION array of dimension at least */
-/* ( 1 + ( n - 1 )*abs( INCX ) ). */
-/* Before entry, the incremented array X must contain the n */
-/* element vector x. */
-/* Unchanged on exit. */
-
-/* INCX - INTEGER. */
-/* On entry, INCX specifies the increment for the elements of */
-/* X. INCX must not be zero. */
-/* Unchanged on exit. */
-
-/* BETA - DOUBLE PRECISION. */
-/* On entry, BETA specifies the scalar beta. When BETA is */
-/* supplied as zero then Y need not be set on input. */
-/* Unchanged on exit. */
-
-/* Y - DOUBLE PRECISION array of dimension at least */
-/* ( 1 + ( n - 1 )*abs( INCY ) ). */
-/* Before entry, the incremented array Y must contain the n */
-/* element vector y. On exit, Y is overwritten by the updated */
-/* vector y. */
-
-/* INCY - INTEGER. */
-/* On entry, INCY specifies the increment for the elements of */
-/* Y. INCY must not be zero. */
-/* Unchanged on exit. */
-
-
-/* Level 2 Blas routine. */
-
-/* -- Written on 22-October-1986. */
-/* Jack Dongarra, Argonne National Lab. */
-/* Jeremy Du Croz, Nag Central Office. */
-/* Sven Hammarling, Nag Central Office. */
-/* Richard Hanson, Sandia National Labs. */
-
-
-/* .. Parameters .. */
-/* .. Local Scalars .. */
-/* .. External Functions .. */
-/* .. External Subroutines .. */
-/* .. Intrinsic Functions .. */
-/* .. */
-/* .. Executable Statements .. */
-
-/* Test the input parameters. */
-
- /* Parameter adjustments */
- a_dim1 = *lda;
- a_offset = 1 + a_dim1 * 1;
- a -= a_offset;
- --x;
- --y;
-
- /* Function Body */
- info = 0;
- if (! lsame_(uplo, "U", (ftnlen)1, (ftnlen)1) && ! lsame_(uplo, "L", (
- ftnlen)1, (ftnlen)1)) {
- info = 1;
- } else if (*n < 0) {
- info = 2;
- } else if (*lda < max(1,*n)) {
- info = 5;
- } else if (*incx == 0) {
- info = 7;
- } else if (*incy == 0) {
- info = 10;
- }
- if (info != 0) {
- xerbla_("DSYMV ", &info, (ftnlen)6);
- return 0;
- }
-
-/* Quick return if possible. */
-
- if (*n == 0 || *alpha == 0. && *beta == 1.) {
- return 0;
- }
-
-/* Set up the start points in X and Y. */
-
- if (*incx > 0) {
- kx = 1;
- } else {
- kx = 1 - (*n - 1) * *incx;
- }
- if (*incy > 0) {
- ky = 1;
- } else {
- ky = 1 - (*n - 1) * *incy;
- }
-
-/* Start the operations. In this version the elements of A are */
-/* accessed sequentially with one pass through the triangular part */
-/* of A. */
-
-/* First form y := beta*y. */
-
- if (*beta != 1.) {
- if (*incy == 1) {
- if (*beta == 0.) {
- i__1 = *n;
- for (i__ = 1; i__ <= i__1; ++i__) {
- y[i__] = 0.;
-/* L10: */
- }
- } else {
- i__1 = *n;
- for (i__ = 1; i__ <= i__1; ++i__) {
- y[i__] = *beta * y[i__];
-/* L20: */
- }
- }
- } else {
- iy = ky;
- if (*beta == 0.) {
- i__1 = *n;
- for (i__ = 1; i__ <= i__1; ++i__) {
- y[iy] = 0.;
- iy += *incy;
-/* L30: */
- }
- } else {
- i__1 = *n;
- for (i__ = 1; i__ <= i__1; ++i__) {
- y[iy] = *beta * y[iy];
- iy += *incy;
-/* L40: */
- }
- }
- }
- }
- if (*alpha == 0.) {
- return 0;
- }
- if (lsame_(uplo, "U", (ftnlen)1, (ftnlen)1)) {
-
-/* Form y when A is stored in upper triangle. */
-
- if (*incx == 1 && *incy == 1) {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- temp1 = *alpha * x[j];
- temp2 = 0.;
- i__2 = j - 1;
- for (i__ = 1; i__ <= i__2; ++i__) {
- y[i__] += temp1 * a[i__ + j * a_dim1];
- temp2 += a[i__ + j * a_dim1] * x[i__];
-/* L50: */
- }
- y[j] = y[j] + temp1 * a[j + j * a_dim1] + *alpha * temp2;
-/* L60: */
- }
- } else {
- jx = kx;
- jy = ky;
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- temp1 = *alpha * x[jx];
- temp2 = 0.;
- ix = kx;
- iy = ky;
- i__2 = j - 1;
- for (i__ = 1; i__ <= i__2; ++i__) {
- y[iy] += temp1 * a[i__ + j * a_dim1];
- temp2 += a[i__ + j * a_dim1] * x[ix];
- ix += *incx;
- iy += *incy;
-/* L70: */
- }
- y[jy] = y[jy] + temp1 * a[j + j * a_dim1] + *alpha * temp2;
- jx += *incx;
- jy += *incy;
-/* L80: */
- }
- }
- } else {
-
-/* Form y when A is stored in lower triangle. */
-
- if (*incx == 1 && *incy == 1) {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- temp1 = *alpha * x[j];
- temp2 = 0.;
- y[j] += temp1 * a[j + j * a_dim1];
- i__2 = *n;
- for (i__ = j + 1; i__ <= i__2; ++i__) {
- y[i__] += temp1 * a[i__ + j * a_dim1];
- temp2 += a[i__ + j * a_dim1] * x[i__];
-/* L90: */
- }
- y[j] += *alpha * temp2;
-/* L100: */
- }
- } else {
- jx = kx;
- jy = ky;
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- temp1 = *alpha * x[jx];
- temp2 = 0.;
- y[jy] += temp1 * a[j + j * a_dim1];
- ix = jx;
- iy = jy;
- i__2 = *n;
- for (i__ = j + 1; i__ <= i__2; ++i__) {
- ix += *incx;
- iy += *incy;
- y[iy] += temp1 * a[i__ + j * a_dim1];
- temp2 += a[i__ + j * a_dim1] * x[ix];
-/* L110: */
- }
- y[jy] += *alpha * temp2;
- jx += *incx;
- jy += *incy;
-/* L120: */
- }
- }
- }
-
- return 0;
-
-/* End of DSYMV . */
-
-} /* dsymv_ */
-
-/* Subroutine */ int dsyr_(char *uplo, integer *n, doublereal *alpha,
- doublereal *x, integer *incx, doublereal *a, integer *lda, ftnlen
- uplo_len)
-{
- /* System generated locals */
- integer a_dim1, a_offset, i__1, i__2;
-
- /* Local variables */
- static integer i__, j, ix, jx, kx, info;
- static doublereal temp;
- extern logical lsame_(char *, char *, ftnlen, ftnlen);
- extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen);
-
-/* .. Scalar Arguments .. */
-/* .. Array Arguments .. */
-/* .. */
-
-/* Purpose */
-/* ======= */
-
-/* DSYR performs the symmetric rank 1 operation */
-
-/* A := alpha*x*x' + A, */
-
-/* where alpha is a real scalar, x is an n element vector and A is an */
-/* n by n symmetric matrix. */
-
-/* Parameters */
-/* ========== */
-
-/* UPLO - CHARACTER*1. */
-/* On entry, UPLO specifies whether the upper or lower */
-/* triangular part of the array A is to be referenced as */
-/* follows: */
-
-/* UPLO = 'U' or 'u' Only the upper triangular part of A */
-/* is to be referenced. */
-
-/* UPLO = 'L' or 'l' Only the lower triangular part of A */
-/* is to be referenced. */
-
-/* Unchanged on exit. */
-
-/* N - INTEGER. */
-/* On entry, N specifies the order of the matrix A. */
-/* N must be at least zero. */
-/* Unchanged on exit. */
-
-/* ALPHA - DOUBLE PRECISION. */
-/* On entry, ALPHA specifies the scalar alpha. */
-/* Unchanged on exit. */
-
-/* X - DOUBLE PRECISION array of dimension at least */
-/* ( 1 + ( n - 1 )*abs( INCX ) ). */
-/* Before entry, the incremented array X must contain the n */
-/* element vector x. */
-/* Unchanged on exit. */
-
-/* INCX - INTEGER. */
-/* On entry, INCX specifies the increment for the elements of */
-/* X. INCX must not be zero. */
-/* Unchanged on exit. */
-
-/* A - DOUBLE PRECISION array of DIMENSION ( LDA, n ). */
-/* Before entry with UPLO = 'U' or 'u', the leading n by n */
-/* upper triangular part of the array A must contain the upper */
-/* triangular part of the symmetric matrix and the strictly */
-/* lower triangular part of A is not referenced. On exit, the */
-/* upper triangular part of the array A is overwritten by the */
-/* upper triangular part of the updated matrix. */
-/* Before entry with UPLO = 'L' or 'l', the leading n by n */
-/* lower triangular part of the array A must contain the lower */
-/* triangular part of the symmetric matrix and the strictly */
-/* upper triangular part of A is not referenced. On exit, the */
-/* lower triangular part of the array A is overwritten by the */
-/* lower triangular part of the updated matrix. */
-
-/* LDA - INTEGER. */
-/* On entry, LDA specifies the first dimension of A as declared */
-/* in the calling (sub) program. LDA must be at least */
-/* max( 1, n ). */
-/* Unchanged on exit. */
-
-
-/* Level 2 Blas routine. */
-
-/* -- Written on 22-October-1986. */
-/* Jack Dongarra, Argonne National Lab. */
-/* Jeremy Du Croz, Nag Central Office. */
-/* Sven Hammarling, Nag Central Office. */
-/* Richard Hanson, Sandia National Labs. */
-
-
-/* .. Parameters .. */
-/* .. Local Scalars .. */
-/* .. External Functions .. */
-/* .. External Subroutines .. */
-/* .. Intrinsic Functions .. */
-/* .. */
-/* .. Executable Statements .. */
-
-/* Test the input parameters. */
-
- /* Parameter adjustments */
- --x;
- a_dim1 = *lda;
- a_offset = 1 + a_dim1 * 1;
- a -= a_offset;
-
- /* Function Body */
- info = 0;
- if (! lsame_(uplo, "U", (ftnlen)1, (ftnlen)1) && ! lsame_(uplo, "L", (
- ftnlen)1, (ftnlen)1)) {
- info = 1;
- } else if (*n < 0) {
- info = 2;
- } else if (*incx == 0) {
- info = 5;
- } else if (*lda < max(1,*n)) {
- info = 7;
- }
- if (info != 0) {
- xerbla_("DSYR ", &info, (ftnlen)6);
- return 0;
- }
-
-/* Quick return if possible. */
-
- if (*n == 0 || *alpha == 0.) {
- return 0;
- }
-
-/* Set the start point in X if the increment is not unity. */
-
- if (*incx <= 0) {
- kx = 1 - (*n - 1) * *incx;
- } else if (*incx != 1) {
- kx = 1;
- }
-
-/* Start the operations. In this version the elements of A are */
-/* accessed sequentially with one pass through the triangular part */
-/* of A. */
-
- if (lsame_(uplo, "U", (ftnlen)1, (ftnlen)1)) {
-
-/* Form A when A is stored in upper triangle. */
-
- if (*incx == 1) {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- if (x[j] != 0.) {
- temp = *alpha * x[j];
- i__2 = j;
- for (i__ = 1; i__ <= i__2; ++i__) {
- a[i__ + j * a_dim1] += x[i__] * temp;
-/* L10: */
- }
- }
-/* L20: */
- }
- } else {
- jx = kx;
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- if (x[jx] != 0.) {
- temp = *alpha * x[jx];
- ix = kx;
- i__2 = j;
- for (i__ = 1; i__ <= i__2; ++i__) {
- a[i__ + j * a_dim1] += x[ix] * temp;
- ix += *incx;
-/* L30: */
- }
- }
- jx += *incx;
-/* L40: */
- }
- }
- } else {
-
-/* Form A when A is stored in lower triangle. */
-
- if (*incx == 1) {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- if (x[j] != 0.) {
- temp = *alpha * x[j];
- i__2 = *n;
- for (i__ = j; i__ <= i__2; ++i__) {
- a[i__ + j * a_dim1] += x[i__] * temp;
-/* L50: */
- }
- }
-/* L60: */
- }
- } else {
- jx = kx;
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- if (x[jx] != 0.) {
- temp = *alpha * x[jx];
- ix = jx;
- i__2 = *n;
- for (i__ = j; i__ <= i__2; ++i__) {
- a[i__ + j * a_dim1] += x[ix] * temp;
- ix += *incx;
-/* L70: */
- }
- }
- jx += *incx;
-/* L80: */
- }
- }
- }
-
- return 0;
-
-/* End of DSYR . */
-
-} /* dsyr_ */
-
-/* Subroutine */ int dsyr2_(char *uplo, integer *n, doublereal *alpha,
- doublereal *x, integer *incx, doublereal *y, integer *incy,
- doublereal *a, integer *lda, ftnlen uplo_len)
-{
- /* System generated locals */
- integer a_dim1, a_offset, i__1, i__2;
-
- /* Local variables */
- static integer i__, j, ix, iy, jx, jy, kx, ky, info;
- static doublereal temp1, temp2;
- extern logical lsame_(char *, char *, ftnlen, ftnlen);
- extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen);
-
-/* .. Scalar Arguments .. */
-/* .. Array Arguments .. */
-/* .. */
-
-/* Purpose */
-/* ======= */
-
-/* DSYR2 performs the symmetric rank 2 operation */
-
-/* A := alpha*x*y' + alpha*y*x' + A, */
-
-/* where alpha is a scalar, x and y are n element vectors and A is an n */
-/* by n symmetric matrix. */
-
-/* Parameters */
-/* ========== */
-
-/* UPLO - CHARACTER*1. */
-/* On entry, UPLO specifies whether the upper or lower */
-/* triangular part of the array A is to be referenced as */
-/* follows: */
-
-/* UPLO = 'U' or 'u' Only the upper triangular part of A */
-/* is to be referenced. */
-
-/* UPLO = 'L' or 'l' Only the lower triangular part of A */
-/* is to be referenced. */
-
-/* Unchanged on exit. */
-
-/* N - INTEGER. */
-/* On entry, N specifies the order of the matrix A. */
-/* N must be at least zero. */
-/* Unchanged on exit. */
-
-/* ALPHA - DOUBLE PRECISION. */
-/* On entry, ALPHA specifies the scalar alpha. */
-/* Unchanged on exit. */
-
-/* X - DOUBLE PRECISION array of dimension at least */
-/* ( 1 + ( n - 1 )*abs( INCX ) ). */
-/* Before entry, the incremented array X must contain the n */
-/* element vector x. */
-/* Unchanged on exit. */
-
-/* INCX - INTEGER. */
-/* On entry, INCX specifies the increment for the elements of */
-/* X. INCX must not be zero. */
-/* Unchanged on exit. */
-
-/* Y - DOUBLE PRECISION array of dimension at least */
-/* ( 1 + ( n - 1 )*abs( INCY ) ). */
-/* Before entry, the incremented array Y must contain the n */
-/* element vector y. */
-/* Unchanged on exit. */
-
-/* INCY - INTEGER. */
-/* On entry, INCY specifies the increment for the elements of */
-/* Y. INCY must not be zero. */
-/* Unchanged on exit. */
-
-/* A - DOUBLE PRECISION array of DIMENSION ( LDA, n ). */
-/* Before entry with UPLO = 'U' or 'u', the leading n by n */
-/* upper triangular part of the array A must contain the upper */
-/* triangular part of the symmetric matrix and the strictly */
-/* lower triangular part of A is not referenced. On exit, the */
-/* upper triangular part of the array A is overwritten by the */
-/* upper triangular part of the updated matrix. */
-/* Before entry with UPLO = 'L' or 'l', the leading n by n */
-/* lower triangular part of the array A must contain the lower */
-/* triangular part of the symmetric matrix and the strictly */
-/* upper triangular part of A is not referenced. On exit, the */
-/* lower triangular part of the array A is overwritten by the */
-/* lower triangular part of the updated matrix. */
-
-/* LDA - INTEGER. */
-/* On entry, LDA specifies the first dimension of A as declared */
-/* in the calling (sub) program. LDA must be at least */
-/* max( 1, n ). */
-/* Unchanged on exit. */
-
-
-/* Level 2 Blas routine. */
-
-/* -- Written on 22-October-1986. */
-/* Jack Dongarra, Argonne National Lab. */
-/* Jeremy Du Croz, Nag Central Office. */
-/* Sven Hammarling, Nag Central Office. */
-/* Richard Hanson, Sandia National Labs. */
-
-
-/* .. Parameters .. */
-/* .. Local Scalars .. */
-/* .. External Functions .. */
-/* .. External Subroutines .. */
-/* .. Intrinsic Functions .. */
-/* .. */
-/* .. Executable Statements .. */
-
-/* Test the input parameters. */
-
- /* Parameter adjustments */
- --x;
- --y;
- a_dim1 = *lda;
- a_offset = 1 + a_dim1 * 1;
- a -= a_offset;
-
- /* Function Body */
- info = 0;
- if (! lsame_(uplo, "U", (ftnlen)1, (ftnlen)1) && ! lsame_(uplo, "L", (
- ftnlen)1, (ftnlen)1)) {
- info = 1;
- } else if (*n < 0) {
- info = 2;
- } else if (*incx == 0) {
- info = 5;
- } else if (*incy == 0) {
- info = 7;
- } else if (*lda < max(1,*n)) {
- info = 9;
- }
- if (info != 0) {
- xerbla_("DSYR2 ", &info, (ftnlen)6);
- return 0;
- }
-
-/* Quick return if possible. */
-
- if (*n == 0 || *alpha == 0.) {
- return 0;
- }
-
-/* Set up the start points in X and Y if the increments are not both */
-/* unity. */
-
- if (*incx != 1 || *incy != 1) {
- if (*incx > 0) {
- kx = 1;
- } else {
- kx = 1 - (*n - 1) * *incx;
- }
- if (*incy > 0) {
- ky = 1;
- } else {
- ky = 1 - (*n - 1) * *incy;
- }
- jx = kx;
- jy = ky;
- }
-
-/* Start the operations. In this version the elements of A are */
-/* accessed sequentially with one pass through the triangular part */
-/* of A. */
-
- if (lsame_(uplo, "U", (ftnlen)1, (ftnlen)1)) {
-
-/* Form A when A is stored in the upper triangle. */
-
- if (*incx == 1 && *incy == 1) {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- if (x[j] != 0. || y[j] != 0.) {
- temp1 = *alpha * y[j];
- temp2 = *alpha * x[j];
- i__2 = j;
- for (i__ = 1; i__ <= i__2; ++i__) {
- a[i__ + j * a_dim1] = a[i__ + j * a_dim1] + x[i__] *
- temp1 + y[i__] * temp2;
-/* L10: */
- }
- }
-/* L20: */
- }
- } else {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- if (x[jx] != 0. || y[jy] != 0.) {
- temp1 = *alpha * y[jy];
- temp2 = *alpha * x[jx];
- ix = kx;
- iy = ky;
- i__2 = j;
- for (i__ = 1; i__ <= i__2; ++i__) {
- a[i__ + j * a_dim1] = a[i__ + j * a_dim1] + x[ix] *
- temp1 + y[iy] * temp2;
- ix += *incx;
- iy += *incy;
-/* L30: */
- }
- }
- jx += *incx;
- jy += *incy;
-/* L40: */
- }
- }
- } else {
-
-/* Form A when A is stored in the lower triangle. */
-
- if (*incx == 1 && *incy == 1) {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- if (x[j] != 0. || y[j] != 0.) {
- temp1 = *alpha * y[j];
- temp2 = *alpha * x[j];
- i__2 = *n;
- for (i__ = j; i__ <= i__2; ++i__) {
- a[i__ + j * a_dim1] = a[i__ + j * a_dim1] + x[i__] *
- temp1 + y[i__] * temp2;
-/* L50: */
- }
- }
-/* L60: */
- }
- } else {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- if (x[jx] != 0. || y[jy] != 0.) {
- temp1 = *alpha * y[jy];
- temp2 = *alpha * x[jx];
- ix = jx;
- iy = jy;
- i__2 = *n;
- for (i__ = j; i__ <= i__2; ++i__) {
- a[i__ + j * a_dim1] = a[i__ + j * a_dim1] + x[ix] *
- temp1 + y[iy] * temp2;
- ix += *incx;
- iy += *incy;
-/* L70: */
- }
- }
- jx += *incx;
- jy += *incy;
-/* L80: */
- }
- }
- }
-
- return 0;
-
-/* End of DSYR2 . */
-
-} /* dsyr2_ */
-
-/* Subroutine */ int dsyr2k_(char *uplo, char *trans, integer *n, integer *k,
- doublereal *alpha, doublereal *a, integer *lda, doublereal *b,
- integer *ldb, doublereal *beta, doublereal *c__, integer *ldc, ftnlen
- uplo_len, ftnlen trans_len)
-{
- /* System generated locals */
- integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2,
- i__3;
-
- /* Local variables */
- static integer i__, j, l, info;
- static doublereal temp1, temp2;
- extern logical lsame_(char *, char *, ftnlen, ftnlen);
- static integer nrowa;
- static logical upper;
- extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen);
-
-/* .. Scalar Arguments .. */
-/* .. Array Arguments .. */
-/* .. */
-
-/* Purpose */
-/* ======= */
-
-/* DSYR2K performs one of the symmetric rank 2k operations */
-
-/* C := alpha*A*B' + alpha*B*A' + beta*C, */
-
-/* or */
-
-/* C := alpha*A'*B + alpha*B'*A + beta*C, */
-
-/* where alpha and beta are scalars, C is an n by n symmetric matrix */
-/* and A and B are n by k matrices in the first case and k by n */
-/* matrices in the second case. */
-
-/* Parameters */
-/* ========== */
-
-/* UPLO - CHARACTER*1. */
-/* On entry, UPLO specifies whether the upper or lower */
-/* triangular part of the array C is to be referenced as */
-/* follows: */
-
-/* UPLO = 'U' or 'u' Only the upper triangular part of C */
-/* is to be referenced. */
-
-/* UPLO = 'L' or 'l' Only the lower triangular part of C */
-/* is to be referenced. */
-
-/* Unchanged on exit. */
-
-/* TRANS - CHARACTER*1. */
-/* On entry, TRANS specifies the operation to be performed as */
-/* follows: */
-
-/* TRANS = 'N' or 'n' C := alpha*A*B' + alpha*B*A' + */
-/* beta*C. */
-
-/* TRANS = 'T' or 't' C := alpha*A'*B + alpha*B'*A + */
-/* beta*C. */
-
-/* TRANS = 'C' or 'c' C := alpha*A'*B + alpha*B'*A + */
-/* beta*C. */
-
-/* Unchanged on exit. */
-
-/* N - INTEGER. */
-/* On entry, N specifies the order of the matrix C. N must be */
-/* at least zero. */
-/* Unchanged on exit. */
-
-/* K - INTEGER. */
-/* On entry with TRANS = 'N' or 'n', K specifies the number */
-/* of columns of the matrices A and B, and on entry with */
-/* TRANS = 'T' or 't' or 'C' or 'c', K specifies the number */
-/* of rows of the matrices A and B. K must be at least zero. */
-/* Unchanged on exit. */
-
-/* ALPHA - DOUBLE PRECISION. */
-/* On entry, ALPHA specifies the scalar alpha. */
-/* Unchanged on exit. */
-
-/* A - DOUBLE PRECISION array of DIMENSION ( LDA, ka ), where ka is */
-/* k when TRANS = 'N' or 'n', and is n otherwise. */
-/* Before entry with TRANS = 'N' or 'n', the leading n by k */
-/* part of the array A must contain the matrix A, otherwise */
-/* the leading k by n part of the array A must contain the */
-/* matrix A. */
-/* Unchanged on exit. */
-
-/* LDA - INTEGER. */
-/* On entry, LDA specifies the first dimension of A as declared */
-/* in the calling (sub) program. When TRANS = 'N' or 'n' */
-/* then LDA must be at least max( 1, n ), otherwise LDA must */
-/* be at least max( 1, k ). */
-/* Unchanged on exit. */
-
-/* B - DOUBLE PRECISION array of DIMENSION ( LDB, kb ), where kb is */
-/* k when TRANS = 'N' or 'n', and is n otherwise. */
-/* Before entry with TRANS = 'N' or 'n', the leading n by k */
-/* part of the array B must contain the matrix B, otherwise */
-/* the leading k by n part of the array B must contain the */
-/* matrix B. */
-/* Unchanged on exit. */
-
-/* LDB - INTEGER. */
-/* On entry, LDB specifies the first dimension of B as declared */
-/* in the calling (sub) program. When TRANS = 'N' or 'n' */
-/* then LDB must be at least max( 1, n ), otherwise LDB must */
-/* be at least max( 1, k ). */
-/* Unchanged on exit. */
-
-/* BETA - DOUBLE PRECISION. */
-/* On entry, BETA specifies the scalar beta. */
-/* Unchanged on exit. */
-
-/* C - DOUBLE PRECISION array of DIMENSION ( LDC, n ). */
-/* Before entry with UPLO = 'U' or 'u', the leading n by n */
-/* upper triangular part of the array C must contain the upper */
-/* triangular part of the symmetric matrix and the strictly */
-/* lower triangular part of C is not referenced. On exit, the */
-/* upper triangular part of the array C is overwritten by the */
-/* upper triangular part of the updated matrix. */
-/* Before entry with UPLO = 'L' or 'l', the leading n by n */
-/* lower triangular part of the array C must contain the lower */
-/* triangular part of the symmetric matrix and the strictly */
-/* upper triangular part of C is not referenced. On exit, the */
-/* lower triangular part of the array C is overwritten by the */
-/* lower triangular part of the updated matrix. */
-
-/* LDC - INTEGER. */
-/* On entry, LDC specifies the first dimension of C as declared */
-/* in the calling (sub) program. LDC must be at least */
-/* max( 1, n ). */
-/* Unchanged on exit. */
-
-
-/* Level 3 Blas routine. */
-
-
-/* -- Written on 8-February-1989. */
-/* Jack Dongarra, Argonne National Laboratory. */
-/* Iain Duff, AERE Harwell. */
-/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */
-/* Sven Hammarling, Numerical Algorithms Group Ltd. */
-
-
-/* .. External Functions .. */
-/* .. External Subroutines .. */
-/* .. Intrinsic Functions .. */
-/* .. Local Scalars .. */
-/* .. Parameters .. */
-/* .. */
-/* .. Executable Statements .. */
-
-/* Test the input parameters. */
-
- /* Parameter adjustments */
- a_dim1 = *lda;
- a_offset = 1 + a_dim1 * 1;
- a -= a_offset;
- b_dim1 = *ldb;
- b_offset = 1 + b_dim1 * 1;
- b -= b_offset;
- c_dim1 = *ldc;
- c_offset = 1 + c_dim1 * 1;
- c__ -= c_offset;
-
- /* Function Body */
- if (lsame_(trans, "N", (ftnlen)1, (ftnlen)1)) {
- nrowa = *n;
- } else {
- nrowa = *k;
- }
- upper = lsame_(uplo, "U", (ftnlen)1, (ftnlen)1);
-
- info = 0;
- if (! upper && ! lsame_(uplo, "L", (ftnlen)1, (ftnlen)1)) {
- info = 1;
- } else if (! lsame_(trans, "N", (ftnlen)1, (ftnlen)1) && ! lsame_(trans,
- "T", (ftnlen)1, (ftnlen)1) && ! lsame_(trans, "C", (ftnlen)1, (
- ftnlen)1)) {
- info = 2;
- } else if (*n < 0) {
- info = 3;
- } else if (*k < 0) {
- info = 4;
- } else if (*lda < max(1,nrowa)) {
- info = 7;
- } else if (*ldb < max(1,nrowa)) {
- info = 9;
- } else if (*ldc < max(1,*n)) {
- info = 12;
- }
- if (info != 0) {
- xerbla_("DSYR2K", &info, (ftnlen)6);
- return 0;
- }
-
-/* Quick return if possible. */
-
- if (*n == 0 || (*alpha == 0. || *k == 0) && *beta == 1.) {
- return 0;
- }
-
-/* And when alpha.eq.zero. */
-
- if (*alpha == 0.) {
- if (upper) {
- if (*beta == 0.) {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- i__2 = j;
- for (i__ = 1; i__ <= i__2; ++i__) {
- c__[i__ + j * c_dim1] = 0.;
-/* L10: */
- }
-/* L20: */
- }
- } else {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- i__2 = j;
- for (i__ = 1; i__ <= i__2; ++i__) {
- c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1];
-/* L30: */
- }
-/* L40: */
- }
- }
- } else {
- if (*beta == 0.) {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- i__2 = *n;
- for (i__ = j; i__ <= i__2; ++i__) {
- c__[i__ + j * c_dim1] = 0.;
-/* L50: */
- }
-/* L60: */
- }
- } else {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- i__2 = *n;
- for (i__ = j; i__ <= i__2; ++i__) {
- c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1];
-/* L70: */
- }
-/* L80: */
- }
- }
- }
- return 0;
- }
-
-/* Start the operations. */
-
- if (lsame_(trans, "N", (ftnlen)1, (ftnlen)1)) {
-
-/* Form C := alpha*A*B' + alpha*B*A' + C. */
-
- if (upper) {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- if (*beta == 0.) {
- i__2 = j;
- for (i__ = 1; i__ <= i__2; ++i__) {
- c__[i__ + j * c_dim1] = 0.;
-/* L90: */
- }
- } else if (*beta != 1.) {
- i__2 = j;
- for (i__ = 1; i__ <= i__2; ++i__) {
- c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1];
-/* L100: */
- }
- }
- i__2 = *k;
- for (l = 1; l <= i__2; ++l) {
- if (a[j + l * a_dim1] != 0. || b[j + l * b_dim1] != 0.) {
- temp1 = *alpha * b[j + l * b_dim1];
- temp2 = *alpha * a[j + l * a_dim1];
- i__3 = j;
- for (i__ = 1; i__ <= i__3; ++i__) {
- c__[i__ + j * c_dim1] = c__[i__ + j * c_dim1] + a[
- i__ + l * a_dim1] * temp1 + b[i__ + l *
- b_dim1] * temp2;
-/* L110: */
- }
- }
-/* L120: */
- }
-/* L130: */
- }
- } else {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- if (*beta == 0.) {
- i__2 = *n;
- for (i__ = j; i__ <= i__2; ++i__) {
- c__[i__ + j * c_dim1] = 0.;
-/* L140: */
- }
- } else if (*beta != 1.) {
- i__2 = *n;
- for (i__ = j; i__ <= i__2; ++i__) {
- c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1];
-/* L150: */
- }
- }
- i__2 = *k;
- for (l = 1; l <= i__2; ++l) {
- if (a[j + l * a_dim1] != 0. || b[j + l * b_dim1] != 0.) {
- temp1 = *alpha * b[j + l * b_dim1];
- temp2 = *alpha * a[j + l * a_dim1];
- i__3 = *n;
- for (i__ = j; i__ <= i__3; ++i__) {
- c__[i__ + j * c_dim1] = c__[i__ + j * c_dim1] + a[
- i__ + l * a_dim1] * temp1 + b[i__ + l *
- b_dim1] * temp2;
-/* L160: */
- }
- }
-/* L170: */
- }
-/* L180: */
- }
- }
- } else {
-
-/* Form C := alpha*A'*B + alpha*B'*A + C. */
-
- if (upper) {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- i__2 = j;
- for (i__ = 1; i__ <= i__2; ++i__) {
- temp1 = 0.;
- temp2 = 0.;
- i__3 = *k;
- for (l = 1; l <= i__3; ++l) {
- temp1 += a[l + i__ * a_dim1] * b[l + j * b_dim1];
- temp2 += b[l + i__ * b_dim1] * a[l + j * a_dim1];
-/* L190: */
- }
- if (*beta == 0.) {
- c__[i__ + j * c_dim1] = *alpha * temp1 + *alpha *
- temp2;
- } else {
- c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1]
- + *alpha * temp1 + *alpha * temp2;
- }
-/* L200: */
- }
-/* L210: */
- }
- } else {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- i__2 = *n;
- for (i__ = j; i__ <= i__2; ++i__) {
- temp1 = 0.;
- temp2 = 0.;
- i__3 = *k;
- for (l = 1; l <= i__3; ++l) {
- temp1 += a[l + i__ * a_dim1] * b[l + j * b_dim1];
- temp2 += b[l + i__ * b_dim1] * a[l + j * a_dim1];
-/* L220: */
- }
- if (*beta == 0.) {
- c__[i__ + j * c_dim1] = *alpha * temp1 + *alpha *
- temp2;
- } else {
- c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1]
- + *alpha * temp1 + *alpha * temp2;
- }
-/* L230: */
- }
-/* L240: */
- }
- }
- }
-
- return 0;
-
-/* End of DSYR2K. */
-
-} /* dsyr2k_ */
-
-/* Subroutine */ int dsyrk_(char *uplo, char *trans, integer *n, integer *k,
- doublereal *alpha, doublereal *a, integer *lda, doublereal *beta,
- doublereal *c__, integer *ldc, ftnlen uplo_len, ftnlen trans_len)
-{
- /* System generated locals */
- integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2, i__3;
-
- /* Local variables */
- static integer i__, j, l, info;
- static doublereal temp;
- extern logical lsame_(char *, char *, ftnlen, ftnlen);
- static integer nrowa;
- static logical upper;
- extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen);
-
-/* .. Scalar Arguments .. */
-/* .. Array Arguments .. */
-/* .. */
-
-/* Purpose */
-/* ======= */
-
-/* DSYRK performs one of the symmetric rank k operations */
-
-/* C := alpha*A*A' + beta*C, */
-
-/* or */
-
-/* C := alpha*A'*A + beta*C, */
-
-/* where alpha and beta are scalars, C is an n by n symmetric matrix */
-/* and A is an n by k matrix in the first case and a k by n matrix */
-/* in the second case. */
-
-/* Parameters */
-/* ========== */
-
-/* UPLO - CHARACTER*1. */
-/* On entry, UPLO specifies whether the upper or lower */
-/* triangular part of the array C is to be referenced as */
-/* follows: */
-
-/* UPLO = 'U' or 'u' Only the upper triangular part of C */
-/* is to be referenced. */
-
-/* UPLO = 'L' or 'l' Only the lower triangular part of C */
-/* is to be referenced. */
-
-/* Unchanged on exit. */
-
-/* TRANS - CHARACTER*1. */
-/* On entry, TRANS specifies the operation to be performed as */
-/* follows: */
-
-/* TRANS = 'N' or 'n' C := alpha*A*A' + beta*C. */
-
-/* TRANS = 'T' or 't' C := alpha*A'*A + beta*C. */
-
-/* TRANS = 'C' or 'c' C := alpha*A'*A + beta*C. */
-
-/* Unchanged on exit. */
-
-/* N - INTEGER. */
-/* On entry, N specifies the order of the matrix C. N must be */
-/* at least zero. */
-/* Unchanged on exit. */
-
-/* K - INTEGER. */
-/* On entry with TRANS = 'N' or 'n', K specifies the number */
-/* of columns of the matrix A, and on entry with */
-/* TRANS = 'T' or 't' or 'C' or 'c', K specifies the number */
-/* of rows of the matrix A. K must be at least zero. */
-/* Unchanged on exit. */
-
-/* ALPHA - DOUBLE PRECISION. */
-/* On entry, ALPHA specifies the scalar alpha. */
-/* Unchanged on exit. */
-
-/* A - DOUBLE PRECISION array of DIMENSION ( LDA, ka ), where ka is */
-/* k when TRANS = 'N' or 'n', and is n otherwise. */
-/* Before entry with TRANS = 'N' or 'n', the leading n by k */
-/* part of the array A must contain the matrix A, otherwise */
-/* the leading k by n part of the array A must contain the */
-/* matrix A. */
-/* Unchanged on exit. */
-
-/* LDA - INTEGER. */
-/* On entry, LDA specifies the first dimension of A as declared */
-/* in the calling (sub) program. When TRANS = 'N' or 'n' */
-/* then LDA must be at least max( 1, n ), otherwise LDA must */
-/* be at least max( 1, k ). */
-/* Unchanged on exit. */
-
-/* BETA - DOUBLE PRECISION. */
-/* On entry, BETA specifies the scalar beta. */
-/* Unchanged on exit. */
-
-/* C - DOUBLE PRECISION array of DIMENSION ( LDC, n ). */
-/* Before entry with UPLO = 'U' or 'u', the leading n by n */
-/* upper triangular part of the array C must contain the upper */
-/* triangular part of the symmetric matrix and the strictly */
-/* lower triangular part of C is not referenced. On exit, the */
-/* upper triangular part of the array C is overwritten by the */
-/* upper triangular part of the updated matrix. */
-/* Before entry with UPLO = 'L' or 'l', the leading n by n */
-/* lower triangular part of the array C must contain the lower */
-/* triangular part of the symmetric matrix and the strictly */
-/* upper triangular part of C is not referenced. On exit, the */
-/* lower triangular part of the array C is overwritten by the */
-/* lower triangular part of the updated matrix. */
-
-/* LDC - INTEGER. */
-/* On entry, LDC specifies the first dimension of C as declared */
-/* in the calling (sub) program. LDC must be at least */
-/* max( 1, n ). */
-/* Unchanged on exit. */
-
-
-/* Level 3 Blas routine. */
-
-/* -- Written on 8-February-1989. */
-/* Jack Dongarra, Argonne National Laboratory. */
-/* Iain Duff, AERE Harwell. */
-/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */
-/* Sven Hammarling, Numerical Algorithms Group Ltd. */
-
-
-/* .. External Functions .. */
-/* .. External Subroutines .. */
-/* .. Intrinsic Functions .. */
-/* .. Local Scalars .. */
-/* .. Parameters .. */
-/* .. */
-/* .. Executable Statements .. */
-
-/* Test the input parameters. */
-
- /* Parameter adjustments */
- a_dim1 = *lda;
- a_offset = 1 + a_dim1 * 1;
- a -= a_offset;
- c_dim1 = *ldc;
- c_offset = 1 + c_dim1 * 1;
- c__ -= c_offset;
-
- /* Function Body */
- if (lsame_(trans, "N", (ftnlen)1, (ftnlen)1)) {
- nrowa = *n;
- } else {
- nrowa = *k;
- }
- upper = lsame_(uplo, "U", (ftnlen)1, (ftnlen)1);
-
- info = 0;
- if (! upper && ! lsame_(uplo, "L", (ftnlen)1, (ftnlen)1)) {
- info = 1;
- } else if (! lsame_(trans, "N", (ftnlen)1, (ftnlen)1) && ! lsame_(trans,
- "T", (ftnlen)1, (ftnlen)1) && ! lsame_(trans, "C", (ftnlen)1, (
- ftnlen)1)) {
- info = 2;
- } else if (*n < 0) {
- info = 3;
- } else if (*k < 0) {
- info = 4;
- } else if (*lda < max(1,nrowa)) {
- info = 7;
- } else if (*ldc < max(1,*n)) {
- info = 10;
- }
- if (info != 0) {
- xerbla_("DSYRK ", &info, (ftnlen)6);
- return 0;
- }
-
-/* Quick return if possible. */
-
- if (*n == 0 || (*alpha == 0. || *k == 0) && *beta == 1.) {
- return 0;
- }
-
-/* And when alpha.eq.zero. */
-
- if (*alpha == 0.) {
- if (upper) {
- if (*beta == 0.) {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- i__2 = j;
- for (i__ = 1; i__ <= i__2; ++i__) {
- c__[i__ + j * c_dim1] = 0.;
-/* L10: */
- }
-/* L20: */
- }
- } else {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- i__2 = j;
- for (i__ = 1; i__ <= i__2; ++i__) {
- c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1];
-/* L30: */
- }
-/* L40: */
- }
- }
- } else {
- if (*beta == 0.) {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- i__2 = *n;
- for (i__ = j; i__ <= i__2; ++i__) {
- c__[i__ + j * c_dim1] = 0.;
-/* L50: */
- }
-/* L60: */
- }
- } else {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- i__2 = *n;
- for (i__ = j; i__ <= i__2; ++i__) {
- c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1];
-/* L70: */
- }
-/* L80: */
- }
- }
- }
- return 0;
- }
-
-/* Start the operations. */
-
- if (lsame_(trans, "N", (ftnlen)1, (ftnlen)1)) {
-
-/* Form C := alpha*A*A' + beta*C. */
-
- if (upper) {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- if (*beta == 0.) {
- i__2 = j;
- for (i__ = 1; i__ <= i__2; ++i__) {
- c__[i__ + j * c_dim1] = 0.;
-/* L90: */
- }
- } else if (*beta != 1.) {
- i__2 = j;
- for (i__ = 1; i__ <= i__2; ++i__) {
- c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1];
-/* L100: */
- }
- }
- i__2 = *k;
- for (l = 1; l <= i__2; ++l) {
- if (a[j + l * a_dim1] != 0.) {
- temp = *alpha * a[j + l * a_dim1];
- i__3 = j;
- for (i__ = 1; i__ <= i__3; ++i__) {
- c__[i__ + j * c_dim1] += temp * a[i__ + l *
- a_dim1];
-/* L110: */
- }
- }
-/* L120: */
- }
-/* L130: */
- }
- } else {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- if (*beta == 0.) {
- i__2 = *n;
- for (i__ = j; i__ <= i__2; ++i__) {
- c__[i__ + j * c_dim1] = 0.;
-/* L140: */
- }
- } else if (*beta != 1.) {
- i__2 = *n;
- for (i__ = j; i__ <= i__2; ++i__) {
- c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1];
-/* L150: */
- }
- }
- i__2 = *k;
- for (l = 1; l <= i__2; ++l) {
- if (a[j + l * a_dim1] != 0.) {
- temp = *alpha * a[j + l * a_dim1];
- i__3 = *n;
- for (i__ = j; i__ <= i__3; ++i__) {
- c__[i__ + j * c_dim1] += temp * a[i__ + l *
- a_dim1];
-/* L160: */
- }
- }
-/* L170: */
- }
-/* L180: */
- }
- }
- } else {
-
-/* Form C := alpha*A'*A + beta*C. */
-
- if (upper) {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- i__2 = j;
- for (i__ = 1; i__ <= i__2; ++i__) {
- temp = 0.;
- i__3 = *k;
- for (l = 1; l <= i__3; ++l) {
- temp += a[l + i__ * a_dim1] * a[l + j * a_dim1];
-/* L190: */
- }
- if (*beta == 0.) {
- c__[i__ + j * c_dim1] = *alpha * temp;
- } else {
- c__[i__ + j * c_dim1] = *alpha * temp + *beta * c__[
- i__ + j * c_dim1];
- }
-/* L200: */
- }
-/* L210: */
- }
- } else {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- i__2 = *n;
- for (i__ = j; i__ <= i__2; ++i__) {
- temp = 0.;
- i__3 = *k;
- for (l = 1; l <= i__3; ++l) {
- temp += a[l + i__ * a_dim1] * a[l + j * a_dim1];
-/* L220: */
- }
- if (*beta == 0.) {
- c__[i__ + j * c_dim1] = *alpha * temp;
- } else {
- c__[i__ + j * c_dim1] = *alpha * temp + *beta * c__[
- i__ + j * c_dim1];
- }
-/* L230: */
- }
-/* L240: */
- }
- }
- }
-
- return 0;
-
-/* End of DSYRK . */
-
-} /* dsyrk_ */
-
-/* Subroutine */ int dtbmv_(char *uplo, char *trans, char *diag, integer *n,
- integer *k, doublereal *a, integer *lda, doublereal *x, integer *incx,
- ftnlen uplo_len, ftnlen trans_len, ftnlen diag_len)
-{
- /* System generated locals */
- integer a_dim1, a_offset, i__1, i__2, i__3, i__4;
-
- /* Local variables */
- static integer i__, j, l, ix, jx, kx, info;
- static doublereal temp;
- extern logical lsame_(char *, char *, ftnlen, ftnlen);
- static integer kplus1;
- extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen);
- static logical nounit;
-
-/* .. Scalar Arguments .. */
-/* .. Array Arguments .. */
-/* .. */
-
-/* Purpose */
-/* ======= */
-
-/* DTBMV performs one of the matrix-vector operations */
-
-/* x := A*x, or x := A'*x, */
-
-/* where x is an n element vector and A is an n by n unit, or non-unit, */
-/* upper or lower triangular band matrix, with ( k + 1 ) diagonals. */
-
-/* Parameters */
-/* ========== */
-
-/* UPLO - CHARACTER*1. */
-/* On entry, UPLO specifies whether the matrix is an upper or */
-/* lower triangular matrix as follows: */
-
-/* UPLO = 'U' or 'u' A is an upper triangular matrix. */
-
-/* UPLO = 'L' or 'l' A is a lower triangular matrix. */
-
-/* Unchanged on exit. */
-
-/* TRANS - CHARACTER*1. */
-/* On entry, TRANS specifies the operation to be performed as */
-/* follows: */
-
-/* TRANS = 'N' or 'n' x := A*x. */
-
-/* TRANS = 'T' or 't' x := A'*x. */
-
-/* TRANS = 'C' or 'c' x := A'*x. */
-
-/* Unchanged on exit. */
-
-/* DIAG - CHARACTER*1. */
-/* On entry, DIAG specifies whether or not A is unit */
-/* triangular as follows: */
-
-/* DIAG = 'U' or 'u' A is assumed to be unit triangular. */
-
-/* DIAG = 'N' or 'n' A is not assumed to be unit */
-/* triangular. */
-
-/* Unchanged on exit. */
-
-/* N - INTEGER. */
-/* On entry, N specifies the order of the matrix A. */
-/* N must be at least zero. */
-/* Unchanged on exit. */
-
-/* K - INTEGER. */
-/* On entry with UPLO = 'U' or 'u', K specifies the number of */
-/* super-diagonals of the matrix A. */
-/* On entry with UPLO = 'L' or 'l', K specifies the number of */
-/* sub-diagonals of the matrix A. */
-/* K must satisfy 0 .le. K. */
-/* Unchanged on exit. */
-
-/* A - DOUBLE PRECISION array of DIMENSION ( LDA, n ). */
-/* Before entry with UPLO = 'U' or 'u', the leading ( k + 1 ) */
-/* by n part of the array A must contain the upper triangular */
-/* band part of the matrix of coefficients, supplied column by */
-/* column, with the leading diagonal of the matrix in row */
-/* ( k + 1 ) of the array, the first super-diagonal starting at */
-/* position 2 in row k, and so on. The top left k by k triangle */
-/* of the array A is not referenced. */
-/* The following program segment will transfer an upper */
-/* triangular band matrix from conventional full matrix storage */
-/* to band storage: */
-
-/* DO 20, J = 1, N */
-/* M = K + 1 - J */
-/* DO 10, I = MAX( 1, J - K ), J */
-/* A( M + I, J ) = matrix( I, J ) */
-/* 10 CONTINUE */
-/* 20 CONTINUE */
-
-/* Before entry with UPLO = 'L' or 'l', the leading ( k + 1 ) */
-/* by n part of the array A must contain the lower triangular */
-/* band part of the matrix of coefficients, supplied column by */
-/* column, with the leading diagonal of the matrix in row 1 of */
-/* the array, the first sub-diagonal starting at position 1 in */
-/* row 2, and so on. The bottom right k by k triangle of the */
-/* array A is not referenced. */
-/* The following program segment will transfer a lower */
-/* triangular band matrix from conventional full matrix storage */
-/* to band storage: */
-
-/* DO 20, J = 1, N */
-/* M = 1 - J */
-/* DO 10, I = J, MIN( N, J + K ) */
-/* A( M + I, J ) = matrix( I, J ) */
-/* 10 CONTINUE */
-/* 20 CONTINUE */
-
-/* Note that when DIAG = 'U' or 'u' the elements of the array A */
-/* corresponding to the diagonal elements of the matrix are not */
-/* referenced, but are assumed to be unity. */
-/* Unchanged on exit. */
-
-/* LDA - INTEGER. */
-/* On entry, LDA specifies the first dimension of A as declared */
-/* in the calling (sub) program. LDA must be at least */
-/* ( k + 1 ). */
-/* Unchanged on exit. */
-
-/* X - DOUBLE PRECISION array of dimension at least */
-/* ( 1 + ( n - 1 )*abs( INCX ) ). */
-/* Before entry, the incremented array X must contain the n */
-/* element vector x. On exit, X is overwritten with the */
-/* tranformed vector x. */
-
-/* INCX - INTEGER. */
-/* On entry, INCX specifies the increment for the elements of */
-/* X. INCX must not be zero. */
-/* Unchanged on exit. */
-
-
-/* Level 2 Blas routine. */
-
-/* -- Written on 22-October-1986. */
-/* Jack Dongarra, Argonne National Lab. */
-/* Jeremy Du Croz, Nag Central Office. */
-/* Sven Hammarling, Nag Central Office. */
-/* Richard Hanson, Sandia National Labs. */
-
-
-/* .. Parameters .. */
-/* .. Local Scalars .. */
-/* .. External Functions .. */
-/* .. External Subroutines .. */
-/* .. Intrinsic Functions .. */
-/* .. */
-/* .. Executable Statements .. */
-
-/* Test the input parameters. */
-
- /* Parameter adjustments */
- a_dim1 = *lda;
- a_offset = 1 + a_dim1 * 1;
- a -= a_offset;
- --x;
-
- /* Function Body */
- info = 0;
- if (! lsame_(uplo, "U", (ftnlen)1, (ftnlen)1) && ! lsame_(uplo, "L", (
- ftnlen)1, (ftnlen)1)) {
- info = 1;
- } else if (! lsame_(trans, "N", (ftnlen)1, (ftnlen)1) && ! lsame_(trans,
- "T", (ftnlen)1, (ftnlen)1) && ! lsame_(trans, "C", (ftnlen)1, (
- ftnlen)1)) {
- info = 2;
- } else if (! lsame_(diag, "U", (ftnlen)1, (ftnlen)1) && ! lsame_(diag,
- "N", (ftnlen)1, (ftnlen)1)) {
- info = 3;
- } else if (*n < 0) {
- info = 4;
- } else if (*k < 0) {
- info = 5;
- } else if (*lda < *k + 1) {
- info = 7;
- } else if (*incx == 0) {
- info = 9;
- }
- if (info != 0) {
- xerbla_("DTBMV ", &info, (ftnlen)6);
- return 0;
- }
-
-/* Quick return if possible. */
-
- if (*n == 0) {
- return 0;
- }
-
- nounit = lsame_(diag, "N", (ftnlen)1, (ftnlen)1);
-
-/* Set up the start point in X if the increment is not unity. This */
-/* will be ( N - 1 )*INCX too small for descending loops. */
-
- if (*incx <= 0) {
- kx = 1 - (*n - 1) * *incx;
- } else if (*incx != 1) {
- kx = 1;
- }
-
-/* Start the operations. In this version the elements of A are */
-/* accessed sequentially with one pass through A. */
-
- if (lsame_(trans, "N", (ftnlen)1, (ftnlen)1)) {
-
-/* Form x := A*x. */
-
- if (lsame_(uplo, "U", (ftnlen)1, (ftnlen)1)) {
- kplus1 = *k + 1;
- if (*incx == 1) {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- if (x[j] != 0.) {
- temp = x[j];
- l = kplus1 - j;
-/* Computing MAX */
- i__2 = 1, i__3 = j - *k;
- i__4 = j - 1;
- for (i__ = max(i__2,i__3); i__ <= i__4; ++i__) {
- x[i__] += temp * a[l + i__ + j * a_dim1];
-/* L10: */
- }
- if (nounit) {
- x[j] *= a[kplus1 + j * a_dim1];
- }
- }
-/* L20: */
- }
- } else {
- jx = kx;
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- if (x[jx] != 0.) {
- temp = x[jx];
- ix = kx;
- l = kplus1 - j;
-/* Computing MAX */
- i__4 = 1, i__2 = j - *k;
- i__3 = j - 1;
- for (i__ = max(i__4,i__2); i__ <= i__3; ++i__) {
- x[ix] += temp * a[l + i__ + j * a_dim1];
- ix += *incx;
-/* L30: */
- }
- if (nounit) {
- x[jx] *= a[kplus1 + j * a_dim1];
- }
- }
- jx += *incx;
- if (j > *k) {
- kx += *incx;
- }
-/* L40: */
- }
- }
- } else {
- if (*incx == 1) {
- for (j = *n; j >= 1; --j) {
- if (x[j] != 0.) {
- temp = x[j];
- l = 1 - j;
-/* Computing MIN */
- i__1 = *n, i__3 = j + *k;
- i__4 = j + 1;
- for (i__ = min(i__1,i__3); i__ >= i__4; --i__) {
- x[i__] += temp * a[l + i__ + j * a_dim1];
-/* L50: */
- }
- if (nounit) {
- x[j] *= a[j * a_dim1 + 1];
- }
- }
-/* L60: */
- }
- } else {
- kx += (*n - 1) * *incx;
- jx = kx;
- for (j = *n; j >= 1; --j) {
- if (x[jx] != 0.) {
- temp = x[jx];
- ix = kx;
- l = 1 - j;
-/* Computing MIN */
- i__4 = *n, i__1 = j + *k;
- i__3 = j + 1;
- for (i__ = min(i__4,i__1); i__ >= i__3; --i__) {
- x[ix] += temp * a[l + i__ + j * a_dim1];
- ix -= *incx;
-/* L70: */
- }
- if (nounit) {
- x[jx] *= a[j * a_dim1 + 1];
- }
- }
- jx -= *incx;
- if (*n - j >= *k) {
- kx -= *incx;
- }
-/* L80: */
- }
- }
- }
- } else {
-
-/* Form x := A'*x. */
-
- if (lsame_(uplo, "U", (ftnlen)1, (ftnlen)1)) {
- kplus1 = *k + 1;
- if (*incx == 1) {
- for (j = *n; j >= 1; --j) {
- temp = x[j];
- l = kplus1 - j;
- if (nounit) {
- temp *= a[kplus1 + j * a_dim1];
- }
-/* Computing MAX */
- i__4 = 1, i__1 = j - *k;
- i__3 = max(i__4,i__1);
- for (i__ = j - 1; i__ >= i__3; --i__) {
- temp += a[l + i__ + j * a_dim1] * x[i__];
-/* L90: */
- }
- x[j] = temp;
-/* L100: */
- }
- } else {
- kx += (*n - 1) * *incx;
- jx = kx;
- for (j = *n; j >= 1; --j) {
- temp = x[jx];
- kx -= *incx;
- ix = kx;
- l = kplus1 - j;
- if (nounit) {
- temp *= a[kplus1 + j * a_dim1];
- }
-/* Computing MAX */
- i__4 = 1, i__1 = j - *k;
- i__3 = max(i__4,i__1);
- for (i__ = j - 1; i__ >= i__3; --i__) {
- temp += a[l + i__ + j * a_dim1] * x[ix];
- ix -= *incx;
-/* L110: */
- }
- x[jx] = temp;
- jx -= *incx;
-/* L120: */
- }
- }
- } else {
- if (*incx == 1) {
- i__3 = *n;
- for (j = 1; j <= i__3; ++j) {
- temp = x[j];
- l = 1 - j;
- if (nounit) {
- temp *= a[j * a_dim1 + 1];
- }
-/* Computing MIN */
- i__1 = *n, i__2 = j + *k;
- i__4 = min(i__1,i__2);
- for (i__ = j + 1; i__ <= i__4; ++i__) {
- temp += a[l + i__ + j * a_dim1] * x[i__];
-/* L130: */
- }
- x[j] = temp;
-/* L140: */
- }
- } else {
- jx = kx;
- i__3 = *n;
- for (j = 1; j <= i__3; ++j) {
- temp = x[jx];
- kx += *incx;
- ix = kx;
- l = 1 - j;
- if (nounit) {
- temp *= a[j * a_dim1 + 1];
- }
-/* Computing MIN */
- i__1 = *n, i__2 = j + *k;
- i__4 = min(i__1,i__2);
- for (i__ = j + 1; i__ <= i__4; ++i__) {
- temp += a[l + i__ + j * a_dim1] * x[ix];
- ix += *incx;
-/* L150: */
- }
- x[jx] = temp;
- jx += *incx;
-/* L160: */
- }
- }
- }
- }
-
- return 0;
-
-/* End of DTBMV . */
-
-} /* dtbmv_ */
-
-/* Subroutine */ int dtbsv_(char *uplo, char *trans, char *diag, integer *n,
- integer *k, doublereal *a, integer *lda, doublereal *x, integer *incx,
- ftnlen uplo_len, ftnlen trans_len, ftnlen diag_len)
-{
- /* System generated locals */
- integer a_dim1, a_offset, i__1, i__2, i__3, i__4;
-
- /* Local variables */
- static integer i__, j, l, ix, jx, kx, info;
- static doublereal temp;
- extern logical lsame_(char *, char *, ftnlen, ftnlen);
- static integer kplus1;
- extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen);
- static logical nounit;
-
-/* .. Scalar Arguments .. */
-/* .. Array Arguments .. */
-/* .. */
-
-/* Purpose */
-/* ======= */
-
-/* DTBSV solves one of the systems of equations */
-
-/* A*x = b, or A'*x = b, */
-
-/* where b and x are n element vectors and A is an n by n unit, or */
-/* non-unit, upper or lower triangular band matrix, with ( k + 1 ) */
-/* diagonals. */
-
-/* No test for singularity or near-singularity is included in this */
-/* routine. Such tests must be performed before calling this routine. */
-
-/* Parameters */
-/* ========== */
-
-/* UPLO - CHARACTER*1. */
-/* On entry, UPLO specifies whether the matrix is an upper or */
-/* lower triangular matrix as follows: */
-
-/* UPLO = 'U' or 'u' A is an upper triangular matrix. */
-
-/* UPLO = 'L' or 'l' A is a lower triangular matrix. */
-
-/* Unchanged on exit. */
-
-/* TRANS - CHARACTER*1. */
-/* On entry, TRANS specifies the equations to be solved as */
-/* follows: */
-
-/* TRANS = 'N' or 'n' A*x = b. */
-
-/* TRANS = 'T' or 't' A'*x = b. */
-
-/* TRANS = 'C' or 'c' A'*x = b. */
-
-/* Unchanged on exit. */
-
-/* DIAG - CHARACTER*1. */
-/* On entry, DIAG specifies whether or not A is unit */
-/* triangular as follows: */
-
-/* DIAG = 'U' or 'u' A is assumed to be unit triangular. */
-
-/* DIAG = 'N' or 'n' A is not assumed to be unit */
-/* triangular. */
-
-/* Unchanged on exit. */
-
-/* N - INTEGER. */
-/* On entry, N specifies the order of the matrix A. */
-/* N must be at least zero. */
-/* Unchanged on exit. */
-
-/* K - INTEGER. */
-/* On entry with UPLO = 'U' or 'u', K specifies the number of */
-/* super-diagonals of the matrix A. */
-/* On entry with UPLO = 'L' or 'l', K specifies the number of */
-/* sub-diagonals of the matrix A. */
-/* K must satisfy 0 .le. K. */
-/* Unchanged on exit. */
-
-/* A - DOUBLE PRECISION array of DIMENSION ( LDA, n ). */
-/* Before entry with UPLO = 'U' or 'u', the leading ( k + 1 ) */
-/* by n part of the array A must contain the upper triangular */
-/* band part of the matrix of coefficients, supplied column by */
-/* column, with the leading diagonal of the matrix in row */
-/* ( k + 1 ) of the array, the first super-diagonal starting at */
-/* position 2 in row k, and so on. The top left k by k triangle */
-/* of the array A is not referenced. */
-/* The following program segment will transfer an upper */
-/* triangular band matrix from conventional full matrix storage */
-/* to band storage: */
-
-/* DO 20, J = 1, N */
-/* M = K + 1 - J */
-/* DO 10, I = MAX( 1, J - K ), J */
-/* A( M + I, J ) = matrix( I, J ) */
-/* 10 CONTINUE */
-/* 20 CONTINUE */
-
-/* Before entry with UPLO = 'L' or 'l', the leading ( k + 1 ) */
-/* by n part of the array A must contain the lower triangular */
-/* band part of the matrix of coefficients, supplied column by */
-/* column, with the leading diagonal of the matrix in row 1 of */
-/* the array, the first sub-diagonal starting at position 1 in */
-/* row 2, and so on. The bottom right k by k triangle of the */
-/* array A is not referenced. */
-/* The following program segment will transfer a lower */
-/* triangular band matrix from conventional full matrix storage */
-/* to band storage: */
-
-/* DO 20, J = 1, N */
-/* M = 1 - J */
-/* DO 10, I = J, MIN( N, J + K ) */
-/* A( M + I, J ) = matrix( I, J ) */
-/* 10 CONTINUE */
-/* 20 CONTINUE */
-
-/* Note that when DIAG = 'U' or 'u' the elements of the array A */
-/* corresponding to the diagonal elements of the matrix are not */
-/* referenced, but are assumed to be unity. */
-/* Unchanged on exit. */
-
-/* LDA - INTEGER. */
-/* On entry, LDA specifies the first dimension of A as declared */
-/* in the calling (sub) program. LDA must be at least */
-/* ( k + 1 ). */
-/* Unchanged on exit. */
-
-/* X - DOUBLE PRECISION array of dimension at least */
-/* ( 1 + ( n - 1 )*abs( INCX ) ). */
-/* Before entry, the incremented array X must contain the n */
-/* element right-hand side vector b. On exit, X is overwritten */
-/* with the solution vector x. */
-
-/* INCX - INTEGER. */
-/* On entry, INCX specifies the increment for the elements of */
-/* X. INCX must not be zero. */
-/* Unchanged on exit. */
-
-
-/* Level 2 Blas routine. */
-
-/* -- Written on 22-October-1986. */
-/* Jack Dongarra, Argonne National Lab. */
-/* Jeremy Du Croz, Nag Central Office. */
-/* Sven Hammarling, Nag Central Office. */
-/* Richard Hanson, Sandia National Labs. */
-
-
-/* .. Parameters .. */
-/* .. Local Scalars .. */
-/* .. External Functions .. */
-/* .. External Subroutines .. */
-/* .. Intrinsic Functions .. */
-/* .. */
-/* .. Executable Statements .. */
-
-/* Test the input parameters. */
-
- /* Parameter adjustments */
- a_dim1 = *lda;
- a_offset = 1 + a_dim1 * 1;
- a -= a_offset;
- --x;
-
- /* Function Body */
- info = 0;
- if (! lsame_(uplo, "U", (ftnlen)1, (ftnlen)1) && ! lsame_(uplo, "L", (
- ftnlen)1, (ftnlen)1)) {
- info = 1;
- } else if (! lsame_(trans, "N", (ftnlen)1, (ftnlen)1) && ! lsame_(trans,
- "T", (ftnlen)1, (ftnlen)1) && ! lsame_(trans, "C", (ftnlen)1, (
- ftnlen)1)) {
- info = 2;
- } else if (! lsame_(diag, "U", (ftnlen)1, (ftnlen)1) && ! lsame_(diag,
- "N", (ftnlen)1, (ftnlen)1)) {
- info = 3;
- } else if (*n < 0) {
- info = 4;
- } else if (*k < 0) {
- info = 5;
- } else if (*lda < *k + 1) {
- info = 7;
- } else if (*incx == 0) {
- info = 9;
- }
- if (info != 0) {
- xerbla_("DTBSV ", &info, (ftnlen)6);
- return 0;
- }
-
-/* Quick return if possible. */
-
- if (*n == 0) {
- return 0;
- }
-
- nounit = lsame_(diag, "N", (ftnlen)1, (ftnlen)1);
-
-/* Set up the start point in X if the increment is not unity. This */
-/* will be ( N - 1 )*INCX too small for descending loops. */
-
- if (*incx <= 0) {
- kx = 1 - (*n - 1) * *incx;
- } else if (*incx != 1) {
- kx = 1;
- }
-
-/* Start the operations. In this version the elements of A are */
-/* accessed by sequentially with one pass through A. */
-
- if (lsame_(trans, "N", (ftnlen)1, (ftnlen)1)) {
-
-/* Form x := inv( A )*x. */
-
- if (lsame_(uplo, "U", (ftnlen)1, (ftnlen)1)) {
- kplus1 = *k + 1;
- if (*incx == 1) {
- for (j = *n; j >= 1; --j) {
- if (x[j] != 0.) {
- l = kplus1 - j;
- if (nounit) {
- x[j] /= a[kplus1 + j * a_dim1];
- }
- temp = x[j];
-/* Computing MAX */
- i__2 = 1, i__3 = j - *k;
- i__1 = max(i__2,i__3);
- for (i__ = j - 1; i__ >= i__1; --i__) {
- x[i__] -= temp * a[l + i__ + j * a_dim1];
-/* L10: */
- }
- }
-/* L20: */
- }
- } else {
- kx += (*n - 1) * *incx;
- jx = kx;
- for (j = *n; j >= 1; --j) {
- kx -= *incx;
- if (x[jx] != 0.) {
- ix = kx;
- l = kplus1 - j;
- if (nounit) {
- x[jx] /= a[kplus1 + j * a_dim1];
- }
- temp = x[jx];
-/* Computing MAX */
- i__2 = 1, i__3 = j - *k;
- i__1 = max(i__2,i__3);
- for (i__ = j - 1; i__ >= i__1; --i__) {
- x[ix] -= temp * a[l + i__ + j * a_dim1];
- ix -= *incx;
-/* L30: */
- }
- }
- jx -= *incx;
-/* L40: */
- }
- }
- } else {
- if (*incx == 1) {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- if (x[j] != 0.) {
- l = 1 - j;
- if (nounit) {
- x[j] /= a[j * a_dim1 + 1];
- }
- temp = x[j];
-/* Computing MIN */
- i__3 = *n, i__4 = j + *k;
- i__2 = min(i__3,i__4);
- for (i__ = j + 1; i__ <= i__2; ++i__) {
- x[i__] -= temp * a[l + i__ + j * a_dim1];
-/* L50: */
- }
- }
-/* L60: */
- }
- } else {
- jx = kx;
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- kx += *incx;
- if (x[jx] != 0.) {
- ix = kx;
- l = 1 - j;
- if (nounit) {
- x[jx] /= a[j * a_dim1 + 1];
- }
- temp = x[jx];
-/* Computing MIN */
- i__3 = *n, i__4 = j + *k;
- i__2 = min(i__3,i__4);
- for (i__ = j + 1; i__ <= i__2; ++i__) {
- x[ix] -= temp * a[l + i__ + j * a_dim1];
- ix += *incx;
-/* L70: */
- }
- }
- jx += *incx;
-/* L80: */
- }
- }
- }
- } else {
-
-/* Form x := inv( A')*x. */
-
- if (lsame_(uplo, "U", (ftnlen)1, (ftnlen)1)) {
- kplus1 = *k + 1;
- if (*incx == 1) {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- temp = x[j];
- l = kplus1 - j;
-/* Computing MAX */
- i__2 = 1, i__3 = j - *k;
- i__4 = j - 1;
- for (i__ = max(i__2,i__3); i__ <= i__4; ++i__) {
- temp -= a[l + i__ + j * a_dim1] * x[i__];
-/* L90: */
- }
- if (nounit) {
- temp /= a[kplus1 + j * a_dim1];
- }
- x[j] = temp;
-/* L100: */
- }
- } else {
- jx = kx;
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- temp = x[jx];
- ix = kx;
- l = kplus1 - j;
-/* Computing MAX */
- i__4 = 1, i__2 = j - *k;
- i__3 = j - 1;
- for (i__ = max(i__4,i__2); i__ <= i__3; ++i__) {
- temp -= a[l + i__ + j * a_dim1] * x[ix];
- ix += *incx;
-/* L110: */
- }
- if (nounit) {
- temp /= a[kplus1 + j * a_dim1];
- }
- x[jx] = temp;
- jx += *incx;
- if (j > *k) {
- kx += *incx;
- }
-/* L120: */
- }
- }
- } else {
- if (*incx == 1) {
- for (j = *n; j >= 1; --j) {
- temp = x[j];
- l = 1 - j;
-/* Computing MIN */
- i__1 = *n, i__3 = j + *k;
- i__4 = j + 1;
- for (i__ = min(i__1,i__3); i__ >= i__4; --i__) {
- temp -= a[l + i__ + j * a_dim1] * x[i__];
-/* L130: */
- }
- if (nounit) {
- temp /= a[j * a_dim1 + 1];
- }
- x[j] = temp;
-/* L140: */
- }
- } else {
- kx += (*n - 1) * *incx;
- jx = kx;
- for (j = *n; j >= 1; --j) {
- temp = x[jx];
- ix = kx;
- l = 1 - j;
-/* Computing MIN */
- i__4 = *n, i__1 = j + *k;
- i__3 = j + 1;
- for (i__ = min(i__4,i__1); i__ >= i__3; --i__) {
- temp -= a[l + i__ + j * a_dim1] * x[ix];
- ix -= *incx;
-/* L150: */
- }
- if (nounit) {
- temp /= a[j * a_dim1 + 1];
- }
- x[jx] = temp;
- jx -= *incx;
- if (*n - j >= *k) {
- kx -= *incx;
- }
-/* L160: */
- }
- }
- }
- }
-
- return 0;
-
-/* End of DTBSV . */
-
-} /* dtbsv_ */
-
-/* Subroutine */ int dtpmv_(char *uplo, char *trans, char *diag, integer *n,
- doublereal *ap, doublereal *x, integer *incx, ftnlen uplo_len, ftnlen
- trans_len, ftnlen diag_len)
-{
- /* System generated locals */
- integer i__1, i__2;
-
- /* Local variables */
- static integer i__, j, k, kk, ix, jx, kx, info;
- static doublereal temp;
- extern logical lsame_(char *, char *, ftnlen, ftnlen);
- extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen);
- static logical nounit;
-
-/* .. Scalar Arguments .. */
-/* .. Array Arguments .. */
-/* .. */
-
-/* Purpose */
-/* ======= */
-
-/* DTPMV performs one of the matrix-vector operations */
-
-/* x := A*x, or x := A'*x, */
-
-/* where x is an n element vector and A is an n by n unit, or non-unit, */
-/* upper or lower triangular matrix, supplied in packed form. */
-
-/* Parameters */
-/* ========== */
-
-/* UPLO - CHARACTER*1. */
-/* On entry, UPLO specifies whether the matrix is an upper or */
-/* lower triangular matrix as follows: */
-
-/* UPLO = 'U' or 'u' A is an upper triangular matrix. */
-
-/* UPLO = 'L' or 'l' A is a lower triangular matrix. */
-
-/* Unchanged on exit. */
-
-/* TRANS - CHARACTER*1. */
-/* On entry, TRANS specifies the operation to be performed as */
-/* follows: */
-
-/* TRANS = 'N' or 'n' x := A*x. */
-
-/* TRANS = 'T' or 't' x := A'*x. */
-
-/* TRANS = 'C' or 'c' x := A'*x. */
-
-/* Unchanged on exit. */
-
-/* DIAG - CHARACTER*1. */
-/* On entry, DIAG specifies whether or not A is unit */
-/* triangular as follows: */
-
-/* DIAG = 'U' or 'u' A is assumed to be unit triangular. */
-
-/* DIAG = 'N' or 'n' A is not assumed to be unit */
-/* triangular. */
-
-/* Unchanged on exit. */
-
-/* N - INTEGER. */
-/* On entry, N specifies the order of the matrix A. */
-/* N must be at least zero. */
-/* Unchanged on exit. */
-
-/* AP - DOUBLE PRECISION array of DIMENSION at least */
-/* ( ( n*( n + 1 ) )/2 ). */
-/* Before entry with UPLO = 'U' or 'u', the array AP must */
-/* contain the upper triangular matrix packed sequentially, */
-/* column by column, so that AP( 1 ) contains a( 1, 1 ), */
-/* AP( 2 ) and AP( 3 ) contain a( 1, 2 ) and a( 2, 2 ) */
-/* respectively, and so on. */
-/* Before entry with UPLO = 'L' or 'l', the array AP must */
-/* contain the lower triangular matrix packed sequentially, */
-/* column by column, so that AP( 1 ) contains a( 1, 1 ), */
-/* AP( 2 ) and AP( 3 ) contain a( 2, 1 ) and a( 3, 1 ) */
-/* respectively, and so on. */
-/* Note that when DIAG = 'U' or 'u', the diagonal elements of */
-/* A are not referenced, but are assumed to be unity. */
-/* Unchanged on exit. */
-
-/* X - DOUBLE PRECISION array of dimension at least */
-/* ( 1 + ( n - 1 )*abs( INCX ) ). */
-/* Before entry, the incremented array X must contain the n */
-/* element vector x. On exit, X is overwritten with the */
-/* tranformed vector x. */
-
-/* INCX - INTEGER. */
-/* On entry, INCX specifies the increment for the elements of */
-/* X. INCX must not be zero. */
-/* Unchanged on exit. */
-
-
-/* Level 2 Blas routine. */
-
-/* -- Written on 22-October-1986. */
-/* Jack Dongarra, Argonne National Lab. */
-/* Jeremy Du Croz, Nag Central Office. */
-/* Sven Hammarling, Nag Central Office. */
-/* Richard Hanson, Sandia National Labs. */
-
-
-/* .. Parameters .. */
-/* .. Local Scalars .. */
-/* .. External Functions .. */
-/* .. External Subroutines .. */
-/* .. */
-/* .. Executable Statements .. */
-
-/* Test the input parameters. */
-
- /* Parameter adjustments */
- --x;
- --ap;
-
- /* Function Body */
- info = 0;
- if (! lsame_(uplo, "U", (ftnlen)1, (ftnlen)1) && ! lsame_(uplo, "L", (
- ftnlen)1, (ftnlen)1)) {
- info = 1;
- } else if (! lsame_(trans, "N", (ftnlen)1, (ftnlen)1) && ! lsame_(trans,
- "T", (ftnlen)1, (ftnlen)1) && ! lsame_(trans, "C", (ftnlen)1, (
- ftnlen)1)) {
- info = 2;
- } else if (! lsame_(diag, "U", (ftnlen)1, (ftnlen)1) && ! lsame_(diag,
- "N", (ftnlen)1, (ftnlen)1)) {
- info = 3;
- } else if (*n < 0) {
- info = 4;
- } else if (*incx == 0) {
- info = 7;
- }
- if (info != 0) {
- xerbla_("DTPMV ", &info, (ftnlen)6);
- return 0;
- }
-
-/* Quick return if possible. */
-
- if (*n == 0) {
- return 0;
- }
-
- nounit = lsame_(diag, "N", (ftnlen)1, (ftnlen)1);
-
-/* Set up the start point in X if the increment is not unity. This */
-/* will be ( N - 1 )*INCX too small for descending loops. */
-
- if (*incx <= 0) {
- kx = 1 - (*n - 1) * *incx;
- } else if (*incx != 1) {
- kx = 1;
- }
-
-/* Start the operations. In this version the elements of AP are */
-/* accessed sequentially with one pass through AP. */
-
- if (lsame_(trans, "N", (ftnlen)1, (ftnlen)1)) {
-
-/* Form x:= A*x. */
-
- if (lsame_(uplo, "U", (ftnlen)1, (ftnlen)1)) {
- kk = 1;
- if (*incx == 1) {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- if (x[j] != 0.) {
- temp = x[j];
- k = kk;
- i__2 = j - 1;
- for (i__ = 1; i__ <= i__2; ++i__) {
- x[i__] += temp * ap[k];
- ++k;
-/* L10: */
- }
- if (nounit) {
- x[j] *= ap[kk + j - 1];
- }
- }
- kk += j;
-/* L20: */
- }
- } else {
- jx = kx;
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- if (x[jx] != 0.) {
- temp = x[jx];
- ix = kx;
- i__2 = kk + j - 2;
- for (k = kk; k <= i__2; ++k) {
- x[ix] += temp * ap[k];
- ix += *incx;
-/* L30: */
- }
- if (nounit) {
- x[jx] *= ap[kk + j - 1];
- }
- }
- jx += *incx;
- kk += j;
-/* L40: */
- }
- }
- } else {
- kk = *n * (*n + 1) / 2;
- if (*incx == 1) {
- for (j = *n; j >= 1; --j) {
- if (x[j] != 0.) {
- temp = x[j];
- k = kk;
- i__1 = j + 1;
- for (i__ = *n; i__ >= i__1; --i__) {
- x[i__] += temp * ap[k];
- --k;
-/* L50: */
- }
- if (nounit) {
- x[j] *= ap[kk - *n + j];
- }
- }
- kk -= *n - j + 1;
-/* L60: */
- }
- } else {
- kx += (*n - 1) * *incx;
- jx = kx;
- for (j = *n; j >= 1; --j) {
- if (x[jx] != 0.) {
- temp = x[jx];
- ix = kx;
- i__1 = kk - (*n - (j + 1));
- for (k = kk; k >= i__1; --k) {
- x[ix] += temp * ap[k];
- ix -= *incx;
-/* L70: */
- }
- if (nounit) {
- x[jx] *= ap[kk - *n + j];
- }
- }
- jx -= *incx;
- kk -= *n - j + 1;
-/* L80: */
- }
- }
- }
- } else {
-
-/* Form x := A'*x. */
-
- if (lsame_(uplo, "U", (ftnlen)1, (ftnlen)1)) {
- kk = *n * (*n + 1) / 2;
- if (*incx == 1) {
- for (j = *n; j >= 1; --j) {
- temp = x[j];
- if (nounit) {
- temp *= ap[kk];
- }
- k = kk - 1;
- for (i__ = j - 1; i__ >= 1; --i__) {
- temp += ap[k] * x[i__];
- --k;
-/* L90: */
- }
- x[j] = temp;
- kk -= j;
-/* L100: */
- }
- } else {
- jx = kx + (*n - 1) * *incx;
- for (j = *n; j >= 1; --j) {
- temp = x[jx];
- ix = jx;
- if (nounit) {
- temp *= ap[kk];
- }
- i__1 = kk - j + 1;
- for (k = kk - 1; k >= i__1; --k) {
- ix -= *incx;
- temp += ap[k] * x[ix];
-/* L110: */
- }
- x[jx] = temp;
- jx -= *incx;
- kk -= j;
-/* L120: */
- }
- }
- } else {
- kk = 1;
- if (*incx == 1) {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- temp = x[j];
- if (nounit) {
- temp *= ap[kk];
- }
- k = kk + 1;
- i__2 = *n;
- for (i__ = j + 1; i__ <= i__2; ++i__) {
- temp += ap[k] * x[i__];
- ++k;
-/* L130: */
- }
- x[j] = temp;
- kk += *n - j + 1;
-/* L140: */
- }
- } else {
- jx = kx;
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- temp = x[jx];
- ix = jx;
- if (nounit) {
- temp *= ap[kk];
- }
- i__2 = kk + *n - j;
- for (k = kk + 1; k <= i__2; ++k) {
- ix += *incx;
- temp += ap[k] * x[ix];
-/* L150: */
- }
- x[jx] = temp;
- jx += *incx;
- kk += *n - j + 1;
-/* L160: */
- }
- }
- }
- }
-
- return 0;
-
-/* End of DTPMV . */
-
-} /* dtpmv_ */
-
-/* Subroutine */ int dtpsv_(char *uplo, char *trans, char *diag, integer *n,
- doublereal *ap, doublereal *x, integer *incx, ftnlen uplo_len, ftnlen
- trans_len, ftnlen diag_len)
-{
- /* System generated locals */
- integer i__1, i__2;
-
- /* Local variables */
- static integer i__, j, k, kk, ix, jx, kx, info;
- static doublereal temp;
- extern logical lsame_(char *, char *, ftnlen, ftnlen);
- extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen);
- static logical nounit;
-
-/* .. Scalar Arguments .. */
-/* .. Array Arguments .. */
-/* .. */
-
-/* Purpose */
-/* ======= */
-
-/* DTPSV solves one of the systems of equations */
-
-/* A*x = b, or A'*x = b, */
-
-/* where b and x are n element vectors and A is an n by n unit, or */
-/* non-unit, upper or lower triangular matrix, supplied in packed form. */
-
-/* No test for singularity or near-singularity is included in this */
-/* routine. Such tests must be performed before calling this routine. */
-
-/* Parameters */
-/* ========== */
-
-/* UPLO - CHARACTER*1. */
-/* On entry, UPLO specifies whether the matrix is an upper or */
-/* lower triangular matrix as follows: */
-
-/* UPLO = 'U' or 'u' A is an upper triangular matrix. */
-
-/* UPLO = 'L' or 'l' A is a lower triangular matrix. */
-
-/* Unchanged on exit. */
-
-/* TRANS - CHARACTER*1. */
-/* On entry, TRANS specifies the equations to be solved as */
-/* follows: */
-
-/* TRANS = 'N' or 'n' A*x = b. */
-
-/* TRANS = 'T' or 't' A'*x = b. */
-
-/* TRANS = 'C' or 'c' A'*x = b. */
-
-/* Unchanged on exit. */
-
-/* DIAG - CHARACTER*1. */
-/* On entry, DIAG specifies whether or not A is unit */
-/* triangular as follows: */
-
-/* DIAG = 'U' or 'u' A is assumed to be unit triangular. */
-
-/* DIAG = 'N' or 'n' A is not assumed to be unit */
-/* triangular. */
-
-/* Unchanged on exit. */
-
-/* N - INTEGER. */
-/* On entry, N specifies the order of the matrix A. */
-/* N must be at least zero. */
-/* Unchanged on exit. */
-
-/* AP - DOUBLE PRECISION array of DIMENSION at least */
-/* ( ( n*( n + 1 ) )/2 ). */
-/* Before entry with UPLO = 'U' or 'u', the array AP must */
-/* contain the upper triangular matrix packed sequentially, */
-/* column by column, so that AP( 1 ) contains a( 1, 1 ), */
-/* AP( 2 ) and AP( 3 ) contain a( 1, 2 ) and a( 2, 2 ) */
-/* respectively, and so on. */
-/* Before entry with UPLO = 'L' or 'l', the array AP must */
-/* contain the lower triangular matrix packed sequentially, */
-/* column by column, so that AP( 1 ) contains a( 1, 1 ), */
-/* AP( 2 ) and AP( 3 ) contain a( 2, 1 ) and a( 3, 1 ) */
-/* respectively, and so on. */
-/* Note that when DIAG = 'U' or 'u', the diagonal elements of */
-/* A are not referenced, but are assumed to be unity. */
-/* Unchanged on exit. */
-
-/* X - DOUBLE PRECISION array of dimension at least */
-/* ( 1 + ( n - 1 )*abs( INCX ) ). */
-/* Before entry, the incremented array X must contain the n */
-/* element right-hand side vector b. On exit, X is overwritten */
-/* with the solution vector x. */
-
-/* INCX - INTEGER. */
-/* On entry, INCX specifies the increment for the elements of */
-/* X. INCX must not be zero. */
-/* Unchanged on exit. */
-
-
-/* Level 2 Blas routine. */
-
-/* -- Written on 22-October-1986. */
-/* Jack Dongarra, Argonne National Lab. */
-/* Jeremy Du Croz, Nag Central Office. */
-/* Sven Hammarling, Nag Central Office. */
-/* Richard Hanson, Sandia National Labs. */
-
-
-/* .. Parameters .. */
-/* .. Local Scalars .. */
-/* .. External Functions .. */
-/* .. External Subroutines .. */
-/* .. */
-/* .. Executable Statements .. */
-
-/* Test the input parameters. */
-
- /* Parameter adjustments */
- --x;
- --ap;
-
- /* Function Body */
- info = 0;
- if (! lsame_(uplo, "U", (ftnlen)1, (ftnlen)1) && ! lsame_(uplo, "L", (
- ftnlen)1, (ftnlen)1)) {
- info = 1;
- } else if (! lsame_(trans, "N", (ftnlen)1, (ftnlen)1) && ! lsame_(trans,
- "T", (ftnlen)1, (ftnlen)1) && ! lsame_(trans, "C", (ftnlen)1, (
- ftnlen)1)) {
- info = 2;
- } else if (! lsame_(diag, "U", (ftnlen)1, (ftnlen)1) && ! lsame_(diag,
- "N", (ftnlen)1, (ftnlen)1)) {
- info = 3;
- } else if (*n < 0) {
- info = 4;
- } else if (*incx == 0) {
- info = 7;
- }
- if (info != 0) {
- xerbla_("DTPSV ", &info, (ftnlen)6);
- return 0;
- }
-
-/* Quick return if possible. */
-
- if (*n == 0) {
- return 0;
- }
-
- nounit = lsame_(diag, "N", (ftnlen)1, (ftnlen)1);
-
-/* Set up the start point in X if the increment is not unity. This */
-/* will be ( N - 1 )*INCX too small for descending loops. */
-
- if (*incx <= 0) {
- kx = 1 - (*n - 1) * *incx;
- } else if (*incx != 1) {
- kx = 1;
- }
-
-/* Start the operations. In this version the elements of AP are */
-/* accessed sequentially with one pass through AP. */
-
- if (lsame_(trans, "N", (ftnlen)1, (ftnlen)1)) {
-
-/* Form x := inv( A )*x. */
-
- if (lsame_(uplo, "U", (ftnlen)1, (ftnlen)1)) {
- kk = *n * (*n + 1) / 2;
- if (*incx == 1) {
- for (j = *n; j >= 1; --j) {
- if (x[j] != 0.) {
- if (nounit) {
- x[j] /= ap[kk];
- }
- temp = x[j];
- k = kk - 1;
- for (i__ = j - 1; i__ >= 1; --i__) {
- x[i__] -= temp * ap[k];
- --k;
-/* L10: */
- }
- }
- kk -= j;
-/* L20: */
- }
- } else {
- jx = kx + (*n - 1) * *incx;
- for (j = *n; j >= 1; --j) {
- if (x[jx] != 0.) {
- if (nounit) {
- x[jx] /= ap[kk];
- }
- temp = x[jx];
- ix = jx;
- i__1 = kk - j + 1;
- for (k = kk - 1; k >= i__1; --k) {
- ix -= *incx;
- x[ix] -= temp * ap[k];
-/* L30: */
- }
- }
- jx -= *incx;
- kk -= j;
-/* L40: */
- }
- }
- } else {
- kk = 1;
- if (*incx == 1) {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- if (x[j] != 0.) {
- if (nounit) {
- x[j] /= ap[kk];
- }
- temp = x[j];
- k = kk + 1;
- i__2 = *n;
- for (i__ = j + 1; i__ <= i__2; ++i__) {
- x[i__] -= temp * ap[k];
- ++k;
-/* L50: */
- }
- }
- kk += *n - j + 1;
-/* L60: */
- }
- } else {
- jx = kx;
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- if (x[jx] != 0.) {
- if (nounit) {
- x[jx] /= ap[kk];
- }
- temp = x[jx];
- ix = jx;
- i__2 = kk + *n - j;
- for (k = kk + 1; k <= i__2; ++k) {
- ix += *incx;
- x[ix] -= temp * ap[k];
-/* L70: */
- }
- }
- jx += *incx;
- kk += *n - j + 1;
-/* L80: */
- }
- }
- }
- } else {
-
-/* Form x := inv( A' )*x. */
-
- if (lsame_(uplo, "U", (ftnlen)1, (ftnlen)1)) {
- kk = 1;
- if (*incx == 1) {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- temp = x[j];
- k = kk;
- i__2 = j - 1;
- for (i__ = 1; i__ <= i__2; ++i__) {
- temp -= ap[k] * x[i__];
- ++k;
-/* L90: */
- }
- if (nounit) {
- temp /= ap[kk + j - 1];
- }
- x[j] = temp;
- kk += j;
-/* L100: */
- }
- } else {
- jx = kx;
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- temp = x[jx];
- ix = kx;
- i__2 = kk + j - 2;
- for (k = kk; k <= i__2; ++k) {
- temp -= ap[k] * x[ix];
- ix += *incx;
-/* L110: */
- }
- if (nounit) {
- temp /= ap[kk + j - 1];
- }
- x[jx] = temp;
- jx += *incx;
- kk += j;
-/* L120: */
- }
- }
- } else {
- kk = *n * (*n + 1) / 2;
- if (*incx == 1) {
- for (j = *n; j >= 1; --j) {
- temp = x[j];
- k = kk;
- i__1 = j + 1;
- for (i__ = *n; i__ >= i__1; --i__) {
- temp -= ap[k] * x[i__];
- --k;
-/* L130: */
- }
- if (nounit) {
- temp /= ap[kk - *n + j];
- }
- x[j] = temp;
- kk -= *n - j + 1;
-/* L140: */
- }
- } else {
- kx += (*n - 1) * *incx;
- jx = kx;
- for (j = *n; j >= 1; --j) {
- temp = x[jx];
- ix = kx;
- i__1 = kk - (*n - (j + 1));
- for (k = kk; k >= i__1; --k) {
- temp -= ap[k] * x[ix];
- ix -= *incx;
-/* L150: */
- }
- if (nounit) {
- temp /= ap[kk - *n + j];
- }
- x[jx] = temp;
- jx -= *incx;
- kk -= *n - j + 1;
-/* L160: */
- }
- }
- }
- }
-
- return 0;
-
-/* End of DTPSV . */
-
-} /* dtpsv_ */
-
-/* Subroutine */ int dtrmm_(char *side, char *uplo, char *transa, char *diag,
- integer *m, integer *n, doublereal *alpha, doublereal *a, integer *
- lda, doublereal *b, integer *ldb, ftnlen side_len, ftnlen uplo_len,
- ftnlen transa_len, ftnlen diag_len)
-{
- /* System generated locals */
- integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2, i__3;
-
- /* Local variables */
- static integer i__, j, k, info;
- static doublereal temp;
- static logical lside;
- extern logical lsame_(char *, char *, ftnlen, ftnlen);
- static integer nrowa;
- static logical upper;
- extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen);
- static logical nounit;
-
-/* .. Scalar Arguments .. */
-/* .. Array Arguments .. */
-/* .. */
-
-/* Purpose */
-/* ======= */
-
-/* DTRMM performs one of the matrix-matrix operations */
-
-/* B := alpha*op( A )*B, or B := alpha*B*op( A ), */
-
-/* where alpha is a scalar, B is an m by n matrix, A is a unit, or */
-/* non-unit, upper or lower triangular matrix and op( A ) is one of */
-
-/* op( A ) = A or op( A ) = A'. */
-
-/* Parameters */
-/* ========== */
-
-/* SIDE - CHARACTER*1. */
-/* On entry, SIDE specifies whether op( A ) multiplies B from */
-/* the left or right as follows: */
-
-/* SIDE = 'L' or 'l' B := alpha*op( A )*B. */
-
-/* SIDE = 'R' or 'r' B := alpha*B*op( A ). */
-
-/* Unchanged on exit. */
-
-/* UPLO - CHARACTER*1. */
-/* On entry, UPLO specifies whether the matrix A is an upper or */
-/* lower triangular matrix as follows: */
-
-/* UPLO = 'U' or 'u' A is an upper triangular matrix. */
-
-/* UPLO = 'L' or 'l' A is a lower triangular matrix. */
-
-/* Unchanged on exit. */
-
-/* TRANSA - CHARACTER*1. */
-/* On entry, TRANSA specifies the form of op( A ) to be used in */
-/* the matrix multiplication as follows: */
-
-/* TRANSA = 'N' or 'n' op( A ) = A. */
-
-/* TRANSA = 'T' or 't' op( A ) = A'. */
-
-/* TRANSA = 'C' or 'c' op( A ) = A'. */
-
-/* Unchanged on exit. */
-
-/* DIAG - CHARACTER*1. */
-/* On entry, DIAG specifies whether or not A is unit triangular */
-/* as follows: */
-
-/* DIAG = 'U' or 'u' A is assumed to be unit triangular. */
-
-/* DIAG = 'N' or 'n' A is not assumed to be unit */
-/* triangular. */
-
-/* Unchanged on exit. */
-
-/* M - INTEGER. */
-/* On entry, M specifies the number of rows of B. M must be at */
-/* least zero. */
-/* Unchanged on exit. */
-
-/* N - INTEGER. */
-/* On entry, N specifies the number of columns of B. N must be */
-/* at least zero. */
-/* Unchanged on exit. */
-
-/* ALPHA - DOUBLE PRECISION. */
-/* On entry, ALPHA specifies the scalar alpha. When alpha is */
-/* zero then A is not referenced and B need not be set before */
-/* entry. */
-/* Unchanged on exit. */
-
-/* A - DOUBLE PRECISION array of DIMENSION ( LDA, k ), where k is m */
-/* when SIDE = 'L' or 'l' and is n when SIDE = 'R' or 'r'. */
-/* Before entry with UPLO = 'U' or 'u', the leading k by k */
-/* upper triangular part of the array A must contain the upper */
-/* triangular matrix and the strictly lower triangular part of */
-/* A is not referenced. */
-/* Before entry with UPLO = 'L' or 'l', the leading k by k */
-/* lower triangular part of the array A must contain the lower */
-/* triangular matrix and the strictly upper triangular part of */
-/* A is not referenced. */
-/* Note that when DIAG = 'U' or 'u', the diagonal elements of */
-/* A are not referenced either, but are assumed to be unity. */
-/* Unchanged on exit. */
-
-/* LDA - INTEGER. */
-/* On entry, LDA specifies the first dimension of A as declared */
-/* in the calling (sub) program. When SIDE = 'L' or 'l' then */
-/* LDA must be at least max( 1, m ), when SIDE = 'R' or 'r' */
-/* then LDA must be at least max( 1, n ). */
-/* Unchanged on exit. */
-
-/* B - DOUBLE PRECISION array of DIMENSION ( LDB, n ). */
-/* Before entry, the leading m by n part of the array B must */
-/* contain the matrix B, and on exit is overwritten by the */
-/* transformed matrix. */
-
-/* LDB - INTEGER. */
-/* On entry, LDB specifies the first dimension of B as declared */
-/* in the calling (sub) program. LDB must be at least */
-/* max( 1, m ). */
-/* Unchanged on exit. */
-
-
-/* Level 3 Blas routine. */
-
-/* -- Written on 8-February-1989. */
-/* Jack Dongarra, Argonne National Laboratory. */
-/* Iain Duff, AERE Harwell. */
-/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */
-/* Sven Hammarling, Numerical Algorithms Group Ltd. */
-
-
-/* .. External Functions .. */
-/* .. External Subroutines .. */
-/* .. Intrinsic Functions .. */
-/* .. Local Scalars .. */
-/* .. Parameters .. */
-/* .. */
-/* .. Executable Statements .. */
-
-/* Test the input parameters. */
-
- /* Parameter adjustments */
- a_dim1 = *lda;
- a_offset = 1 + a_dim1 * 1;
- a -= a_offset;
- b_dim1 = *ldb;
- b_offset = 1 + b_dim1 * 1;
- b -= b_offset;
-
- /* Function Body */
- lside = lsame_(side, "L", (ftnlen)1, (ftnlen)1);
- if (lside) {
- nrowa = *m;
- } else {
- nrowa = *n;
- }
- nounit = lsame_(diag, "N", (ftnlen)1, (ftnlen)1);
- upper = lsame_(uplo, "U", (ftnlen)1, (ftnlen)1);
-
- info = 0;
- if (! lside && ! lsame_(side, "R", (ftnlen)1, (ftnlen)1)) {
- info = 1;
- } else if (! upper && ! lsame_(uplo, "L", (ftnlen)1, (ftnlen)1)) {
- info = 2;
- } else if (! lsame_(transa, "N", (ftnlen)1, (ftnlen)1) && ! lsame_(transa,
- "T", (ftnlen)1, (ftnlen)1) && ! lsame_(transa, "C", (ftnlen)1, (
- ftnlen)1)) {
- info = 3;
- } else if (! lsame_(diag, "U", (ftnlen)1, (ftnlen)1) && ! lsame_(diag,
- "N", (ftnlen)1, (ftnlen)1)) {
- info = 4;
- } else if (*m < 0) {
- info = 5;
- } else if (*n < 0) {
- info = 6;
- } else if (*lda < max(1,nrowa)) {
- info = 9;
- } else if (*ldb < max(1,*m)) {
- info = 11;
- }
- if (info != 0) {
- xerbla_("DTRMM ", &info, (ftnlen)6);
- return 0;
- }
-
-/* Quick return if possible. */
-
- if (*n == 0) {
- return 0;
- }
-
-/* And when alpha.eq.zero. */
-
- if (*alpha == 0.) {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- i__2 = *m;
- for (i__ = 1; i__ <= i__2; ++i__) {
- b[i__ + j * b_dim1] = 0.;
-/* L10: */
- }
-/* L20: */
- }
- return 0;
- }
-
-/* Start the operations. */
-
- if (lside) {
- if (lsame_(transa, "N", (ftnlen)1, (ftnlen)1)) {
-
-/* Form B := alpha*A*B. */
-
- if (upper) {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- i__2 = *m;
- for (k = 1; k <= i__2; ++k) {
- if (b[k + j * b_dim1] != 0.) {
- temp = *alpha * b[k + j * b_dim1];
- i__3 = k - 1;
- for (i__ = 1; i__ <= i__3; ++i__) {
- b[i__ + j * b_dim1] += temp * a[i__ + k *
- a_dim1];
-/* L30: */
- }
- if (nounit) {
- temp *= a[k + k * a_dim1];
- }
- b[k + j * b_dim1] = temp;
- }
-/* L40: */
- }
-/* L50: */
- }
- } else {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- for (k = *m; k >= 1; --k) {
- if (b[k + j * b_dim1] != 0.) {
- temp = *alpha * b[k + j * b_dim1];
- b[k + j * b_dim1] = temp;
- if (nounit) {
- b[k + j * b_dim1] *= a[k + k * a_dim1];
- }
- i__2 = *m;
- for (i__ = k + 1; i__ <= i__2; ++i__) {
- b[i__ + j * b_dim1] += temp * a[i__ + k *
- a_dim1];
-/* L60: */
- }
- }
-/* L70: */
- }
-/* L80: */
- }
- }
- } else {
-
-/* Form B := alpha*A'*B. */
-
- if (upper) {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- for (i__ = *m; i__ >= 1; --i__) {
- temp = b[i__ + j * b_dim1];
- if (nounit) {
- temp *= a[i__ + i__ * a_dim1];
- }
- i__2 = i__ - 1;
- for (k = 1; k <= i__2; ++k) {
- temp += a[k + i__ * a_dim1] * b[k + j * b_dim1];
-/* L90: */
- }
- b[i__ + j * b_dim1] = *alpha * temp;
-/* L100: */
- }
-/* L110: */
- }
- } else {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- i__2 = *m;
- for (i__ = 1; i__ <= i__2; ++i__) {
- temp = b[i__ + j * b_dim1];
- if (nounit) {
- temp *= a[i__ + i__ * a_dim1];
- }
- i__3 = *m;
- for (k = i__ + 1; k <= i__3; ++k) {
- temp += a[k + i__ * a_dim1] * b[k + j * b_dim1];
-/* L120: */
- }
- b[i__ + j * b_dim1] = *alpha * temp;
-/* L130: */
- }
-/* L140: */
- }
- }
- }
- } else {
- if (lsame_(transa, "N", (ftnlen)1, (ftnlen)1)) {
-
-/* Form B := alpha*B*A. */
-
- if (upper) {
- for (j = *n; j >= 1; --j) {
- temp = *alpha;
- if (nounit) {
- temp *= a[j + j * a_dim1];
- }
- i__1 = *m;
- for (i__ = 1; i__ <= i__1; ++i__) {
- b[i__ + j * b_dim1] = temp * b[i__ + j * b_dim1];
-/* L150: */
- }
- i__1 = j - 1;
- for (k = 1; k <= i__1; ++k) {
- if (a[k + j * a_dim1] != 0.) {
- temp = *alpha * a[k + j * a_dim1];
- i__2 = *m;
- for (i__ = 1; i__ <= i__2; ++i__) {
- b[i__ + j * b_dim1] += temp * b[i__ + k *
- b_dim1];
-/* L160: */
- }
- }
-/* L170: */
- }
-/* L180: */
- }
- } else {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- temp = *alpha;
- if (nounit) {
- temp *= a[j + j * a_dim1];
- }
- i__2 = *m;
- for (i__ = 1; i__ <= i__2; ++i__) {
- b[i__ + j * b_dim1] = temp * b[i__ + j * b_dim1];
-/* L190: */
- }
- i__2 = *n;
- for (k = j + 1; k <= i__2; ++k) {
- if (a[k + j * a_dim1] != 0.) {
- temp = *alpha * a[k + j * a_dim1];
- i__3 = *m;
- for (i__ = 1; i__ <= i__3; ++i__) {
- b[i__ + j * b_dim1] += temp * b[i__ + k *
- b_dim1];
-/* L200: */
- }
- }
-/* L210: */
- }
-/* L220: */
- }
- }
- } else {
-
-/* Form B := alpha*B*A'. */
-
- if (upper) {
- i__1 = *n;
- for (k = 1; k <= i__1; ++k) {
- i__2 = k - 1;
- for (j = 1; j <= i__2; ++j) {
- if (a[j + k * a_dim1] != 0.) {
- temp = *alpha * a[j + k * a_dim1];
- i__3 = *m;
- for (i__ = 1; i__ <= i__3; ++i__) {
- b[i__ + j * b_dim1] += temp * b[i__ + k *
- b_dim1];
-/* L230: */
- }
- }
-/* L240: */
- }
- temp = *alpha;
- if (nounit) {
- temp *= a[k + k * a_dim1];
- }
- if (temp != 1.) {
- i__2 = *m;
- for (i__ = 1; i__ <= i__2; ++i__) {
- b[i__ + k * b_dim1] = temp * b[i__ + k * b_dim1];
-/* L250: */
- }
- }
-/* L260: */
- }
- } else {
- for (k = *n; k >= 1; --k) {
- i__1 = *n;
- for (j = k + 1; j <= i__1; ++j) {
- if (a[j + k * a_dim1] != 0.) {
- temp = *alpha * a[j + k * a_dim1];
- i__2 = *m;
- for (i__ = 1; i__ <= i__2; ++i__) {
- b[i__ + j * b_dim1] += temp * b[i__ + k *
- b_dim1];
-/* L270: */
- }
- }
-/* L280: */
- }
- temp = *alpha;
- if (nounit) {
- temp *= a[k + k * a_dim1];
- }
- if (temp != 1.) {
- i__1 = *m;
- for (i__ = 1; i__ <= i__1; ++i__) {
- b[i__ + k * b_dim1] = temp * b[i__ + k * b_dim1];
-/* L290: */
- }
- }
-/* L300: */
- }
- }
- }
- }
-
- return 0;
-
-/* End of DTRMM . */
-
-} /* dtrmm_ */
-
-/* Subroutine */ int dtrmv_(char *uplo, char *trans, char *diag, integer *n,
- doublereal *a, integer *lda, doublereal *x, integer *incx, ftnlen
- uplo_len, ftnlen trans_len, ftnlen diag_len)
-{
- /* System generated locals */
- integer a_dim1, a_offset, i__1, i__2;
-
- /* Local variables */
- static integer i__, j, ix, jx, kx, info;
- static doublereal temp;
- extern logical lsame_(char *, char *, ftnlen, ftnlen);
- extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen);
- static logical nounit;
-
-/* .. Scalar Arguments .. */
-/* .. Array Arguments .. */
-/* .. */
-
-/* Purpose */
-/* ======= */
-
-/* DTRMV performs one of the matrix-vector operations */
-
-/* x := A*x, or x := A'*x, */
-
-/* where x is an n element vector and A is an n by n unit, or non-unit, */
-/* upper or lower triangular matrix. */
-
-/* Parameters */
-/* ========== */
-
-/* UPLO - CHARACTER*1. */
-/* On entry, UPLO specifies whether the matrix is an upper or */
-/* lower triangular matrix as follows: */
-
-/* UPLO = 'U' or 'u' A is an upper triangular matrix. */
-
-/* UPLO = 'L' or 'l' A is a lower triangular matrix. */
-
-/* Unchanged on exit. */
-
-/* TRANS - CHARACTER*1. */
-/* On entry, TRANS specifies the operation to be performed as */
-/* follows: */
-
-/* TRANS = 'N' or 'n' x := A*x. */
-
-/* TRANS = 'T' or 't' x := A'*x. */
-
-/* TRANS = 'C' or 'c' x := A'*x. */
-
-/* Unchanged on exit. */
-
-/* DIAG - CHARACTER*1. */
-/* On entry, DIAG specifies whether or not A is unit */
-/* triangular as follows: */
-
-/* DIAG = 'U' or 'u' A is assumed to be unit triangular. */
-
-/* DIAG = 'N' or 'n' A is not assumed to be unit */
-/* triangular. */
-
-/* Unchanged on exit. */
-
-/* N - INTEGER. */
-/* On entry, N specifies the order of the matrix A. */
-/* N must be at least zero. */
-/* Unchanged on exit. */
-
-/* A - DOUBLE PRECISION array of DIMENSION ( LDA, n ). */
-/* Before entry with UPLO = 'U' or 'u', the leading n by n */
-/* upper triangular part of the array A must contain the upper */
-/* triangular matrix and the strictly lower triangular part of */
-/* A is not referenced. */
-/* Before entry with UPLO = 'L' or 'l', the leading n by n */
-/* lower triangular part of the array A must contain the lower */
-/* triangular matrix and the strictly upper triangular part of */
-/* A is not referenced. */
-/* Note that when DIAG = 'U' or 'u', the diagonal elements of */
-/* A are not referenced either, but are assumed to be unity. */
-/* Unchanged on exit. */
-
-/* LDA - INTEGER. */
-/* On entry, LDA specifies the first dimension of A as declared */
-/* in the calling (sub) program. LDA must be at least */
-/* max( 1, n ). */
-/* Unchanged on exit. */
-
-/* X - DOUBLE PRECISION array of dimension at least */
-/* ( 1 + ( n - 1 )*abs( INCX ) ). */
-/* Before entry, the incremented array X must contain the n */
-/* element vector x. On exit, X is overwritten with the */
-/* tranformed vector x. */
-
-/* INCX - INTEGER. */
-/* On entry, INCX specifies the increment for the elements of */
-/* X. INCX must not be zero. */
-/* Unchanged on exit. */
-
-
-/* Level 2 Blas routine. */
-
-/* -- Written on 22-October-1986. */
-/* Jack Dongarra, Argonne National Lab. */
-/* Jeremy Du Croz, Nag Central Office. */
-/* Sven Hammarling, Nag Central Office. */
-/* Richard Hanson, Sandia National Labs. */
-
-
-/* .. Parameters .. */
-/* .. Local Scalars .. */
-/* .. External Functions .. */
-/* .. External Subroutines .. */
-/* .. Intrinsic Functions .. */
-/* .. */
-/* .. Executable Statements .. */
-
-/* Test the input parameters. */
-
- /* Parameter adjustments */
- a_dim1 = *lda;
- a_offset = 1 + a_dim1 * 1;
- a -= a_offset;
- --x;
-
- /* Function Body */
- info = 0;
- if (! lsame_(uplo, "U", (ftnlen)1, (ftnlen)1) && ! lsame_(uplo, "L", (
- ftnlen)1, (ftnlen)1)) {
- info = 1;
- } else if (! lsame_(trans, "N", (ftnlen)1, (ftnlen)1) && ! lsame_(trans,
- "T", (ftnlen)1, (ftnlen)1) && ! lsame_(trans, "C", (ftnlen)1, (
- ftnlen)1)) {
- info = 2;
- } else if (! lsame_(diag, "U", (ftnlen)1, (ftnlen)1) && ! lsame_(diag,
- "N", (ftnlen)1, (ftnlen)1)) {
- info = 3;
- } else if (*n < 0) {
- info = 4;
- } else if (*lda < max(1,*n)) {
- info = 6;
- } else if (*incx == 0) {
- info = 8;
- }
- if (info != 0) {
- xerbla_("DTRMV ", &info, (ftnlen)6);
- return 0;
- }
-
-/* Quick return if possible. */
-
- if (*n == 0) {
- return 0;
- }
-
- nounit = lsame_(diag, "N", (ftnlen)1, (ftnlen)1);
-
-/* Set up the start point in X if the increment is not unity. This */
-/* will be ( N - 1 )*INCX too small for descending loops. */
-
- if (*incx <= 0) {
- kx = 1 - (*n - 1) * *incx;
- } else if (*incx != 1) {
- kx = 1;
- }
-
-/* Start the operations. In this version the elements of A are */
-/* accessed sequentially with one pass through A. */
-
- if (lsame_(trans, "N", (ftnlen)1, (ftnlen)1)) {
-
-/* Form x := A*x. */
-
- if (lsame_(uplo, "U", (ftnlen)1, (ftnlen)1)) {
- if (*incx == 1) {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- if (x[j] != 0.) {
- temp = x[j];
- i__2 = j - 1;
- for (i__ = 1; i__ <= i__2; ++i__) {
- x[i__] += temp * a[i__ + j * a_dim1];
-/* L10: */
- }
- if (nounit) {
- x[j] *= a[j + j * a_dim1];
- }
- }
-/* L20: */
- }
- } else {
- jx = kx;
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- if (x[jx] != 0.) {
- temp = x[jx];
- ix = kx;
- i__2 = j - 1;
- for (i__ = 1; i__ <= i__2; ++i__) {
- x[ix] += temp * a[i__ + j * a_dim1];
- ix += *incx;
-/* L30: */
- }
- if (nounit) {
- x[jx] *= a[j + j * a_dim1];
- }
- }
- jx += *incx;
-/* L40: */
- }
- }
- } else {
- if (*incx == 1) {
- for (j = *n; j >= 1; --j) {
- if (x[j] != 0.) {
- temp = x[j];
- i__1 = j + 1;
- for (i__ = *n; i__ >= i__1; --i__) {
- x[i__] += temp * a[i__ + j * a_dim1];
-/* L50: */
- }
- if (nounit) {
- x[j] *= a[j + j * a_dim1];
- }
- }
-/* L60: */
- }
- } else {
- kx += (*n - 1) * *incx;
- jx = kx;
- for (j = *n; j >= 1; --j) {
- if (x[jx] != 0.) {
- temp = x[jx];
- ix = kx;
- i__1 = j + 1;
- for (i__ = *n; i__ >= i__1; --i__) {
- x[ix] += temp * a[i__ + j * a_dim1];
- ix -= *incx;
-/* L70: */
- }
- if (nounit) {
- x[jx] *= a[j + j * a_dim1];
- }
- }
- jx -= *incx;
-/* L80: */
- }
- }
- }
- } else {
-
-/* Form x := A'*x. */
-
- if (lsame_(uplo, "U", (ftnlen)1, (ftnlen)1)) {
- if (*incx == 1) {
- for (j = *n; j >= 1; --j) {
- temp = x[j];
- if (nounit) {
- temp *= a[j + j * a_dim1];
- }
- for (i__ = j - 1; i__ >= 1; --i__) {
- temp += a[i__ + j * a_dim1] * x[i__];
-/* L90: */
- }
- x[j] = temp;
-/* L100: */
- }
- } else {
- jx = kx + (*n - 1) * *incx;
- for (j = *n; j >= 1; --j) {
- temp = x[jx];
- ix = jx;
- if (nounit) {
- temp *= a[j + j * a_dim1];
- }
- for (i__ = j - 1; i__ >= 1; --i__) {
- ix -= *incx;
- temp += a[i__ + j * a_dim1] * x[ix];
-/* L110: */
- }
- x[jx] = temp;
- jx -= *incx;
-/* L120: */
- }
- }
- } else {
- if (*incx == 1) {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- temp = x[j];
- if (nounit) {
- temp *= a[j + j * a_dim1];
- }
- i__2 = *n;
- for (i__ = j + 1; i__ <= i__2; ++i__) {
- temp += a[i__ + j * a_dim1] * x[i__];
-/* L130: */
- }
- x[j] = temp;
-/* L140: */
- }
- } else {
- jx = kx;
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- temp = x[jx];
- ix = jx;
- if (nounit) {
- temp *= a[j + j * a_dim1];
- }
- i__2 = *n;
- for (i__ = j + 1; i__ <= i__2; ++i__) {
- ix += *incx;
- temp += a[i__ + j * a_dim1] * x[ix];
-/* L150: */
- }
- x[jx] = temp;
- jx += *incx;
-/* L160: */
- }
- }
- }
- }
-
- return 0;
-
-/* End of DTRMV . */
-
-} /* dtrmv_ */
-
-/* Subroutine */ int dtrsm_(char *side, char *uplo, char *transa, char *diag,
- integer *m, integer *n, doublereal *alpha, doublereal *a, integer *
- lda, doublereal *b, integer *ldb, ftnlen side_len, ftnlen uplo_len,
- ftnlen transa_len, ftnlen diag_len)
-{
- /* System generated locals */
- integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2, i__3;
-
- /* Local variables */
- static integer i__, j, k, info;
- static doublereal temp;
- static logical lside;
- extern logical lsame_(char *, char *, ftnlen, ftnlen);
- static integer nrowa;
- static logical upper;
- extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen);
- static logical nounit;
-
-/* .. Scalar Arguments .. */
-/* .. Array Arguments .. */
-/* .. */
-
-/* Purpose */
-/* ======= */
-
-/* DTRSM solves one of the matrix equations */
-
-/* op( A )*X = alpha*B, or X*op( A ) = alpha*B, */
-
-/* where alpha is a scalar, X and B are m by n matrices, A is a unit, or */
-/* non-unit, upper or lower triangular matrix and op( A ) is one of */
-
-/* op( A ) = A or op( A ) = A'. */
-
-/* The matrix X is overwritten on B. */
-
-/* Parameters */
-/* ========== */
-
-/* SIDE - CHARACTER*1. */
-/* On entry, SIDE specifies whether op( A ) appears on the left */
-/* or right of X as follows: */
-
-/* SIDE = 'L' or 'l' op( A )*X = alpha*B. */
-
-/* SIDE = 'R' or 'r' X*op( A ) = alpha*B. */
-
-/* Unchanged on exit. */
-
-/* UPLO - CHARACTER*1. */
-/* On entry, UPLO specifies whether the matrix A is an upper or */
-/* lower triangular matrix as follows: */
-
-/* UPLO = 'U' or 'u' A is an upper triangular matrix. */
-
-/* UPLO = 'L' or 'l' A is a lower triangular matrix. */
-
-/* Unchanged on exit. */
-
-/* TRANSA - CHARACTER*1. */
-/* On entry, TRANSA specifies the form of op( A ) to be used in */
-/* the matrix multiplication as follows: */
-
-/* TRANSA = 'N' or 'n' op( A ) = A. */
-
-/* TRANSA = 'T' or 't' op( A ) = A'. */
-
-/* TRANSA = 'C' or 'c' op( A ) = A'. */
-
-/* Unchanged on exit. */
-
-/* DIAG - CHARACTER*1. */
-/* On entry, DIAG specifies whether or not A is unit triangular */
-/* as follows: */
-
-/* DIAG = 'U' or 'u' A is assumed to be unit triangular. */
-
-/* DIAG = 'N' or 'n' A is not assumed to be unit */
-/* triangular. */
-
-/* Unchanged on exit. */
-
-/* M - INTEGER. */
-/* On entry, M specifies the number of rows of B. M must be at */
-/* least zero. */
-/* Unchanged on exit. */
-
-/* N - INTEGER. */
-/* On entry, N specifies the number of columns of B. N must be */
-/* at least zero. */
-/* Unchanged on exit. */
-
-/* ALPHA - DOUBLE PRECISION. */
-/* On entry, ALPHA specifies the scalar alpha. When alpha is */
-/* zero then A is not referenced and B need not be set before */
-/* entry. */
-/* Unchanged on exit. */
-
-/* A - DOUBLE PRECISION array of DIMENSION ( LDA, k ), where k is m */
-/* when SIDE = 'L' or 'l' and is n when SIDE = 'R' or 'r'. */
-/* Before entry with UPLO = 'U' or 'u', the leading k by k */
-/* upper triangular part of the array A must contain the upper */
-/* triangular matrix and the strictly lower triangular part of */
-/* A is not referenced. */
-/* Before entry with UPLO = 'L' or 'l', the leading k by k */
-/* lower triangular part of the array A must contain the lower */
-/* triangular matrix and the strictly upper triangular part of */
-/* A is not referenced. */
-/* Note that when DIAG = 'U' or 'u', the diagonal elements of */
-/* A are not referenced either, but are assumed to be unity. */
-/* Unchanged on exit. */
-
-/* LDA - INTEGER. */
-/* On entry, LDA specifies the first dimension of A as declared */
-/* in the calling (sub) program. When SIDE = 'L' or 'l' then */
-/* LDA must be at least max( 1, m ), when SIDE = 'R' or 'r' */
-/* then LDA must be at least max( 1, n ). */
-/* Unchanged on exit. */
-
-/* B - DOUBLE PRECISION array of DIMENSION ( LDB, n ). */
-/* Before entry, the leading m by n part of the array B must */
-/* contain the right-hand side matrix B, and on exit is */
-/* overwritten by the solution matrix X. */
-
-/* LDB - INTEGER. */
-/* On entry, LDB specifies the first dimension of B as declared */
-/* in the calling (sub) program. LDB must be at least */
-/* max( 1, m ). */
-/* Unchanged on exit. */
-
-
-/* Level 3 Blas routine. */
-
-
-/* -- Written on 8-February-1989. */
-/* Jack Dongarra, Argonne National Laboratory. */
-/* Iain Duff, AERE Harwell. */
-/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */
-/* Sven Hammarling, Numerical Algorithms Group Ltd. */
-
-
-/* .. External Functions .. */
-/* .. External Subroutines .. */
-/* .. Intrinsic Functions .. */
-/* .. Local Scalars .. */
-/* .. Parameters .. */
-/* .. */
-/* .. Executable Statements .. */
-
-/* Test the input parameters. */
-
- /* Parameter adjustments */
- a_dim1 = *lda;
- a_offset = 1 + a_dim1 * 1;
- a -= a_offset;
- b_dim1 = *ldb;
- b_offset = 1 + b_dim1 * 1;
- b -= b_offset;
-
- /* Function Body */
- lside = lsame_(side, "L", (ftnlen)1, (ftnlen)1);
- if (lside) {
- nrowa = *m;
- } else {
- nrowa = *n;
- }
- nounit = lsame_(diag, "N", (ftnlen)1, (ftnlen)1);
- upper = lsame_(uplo, "U", (ftnlen)1, (ftnlen)1);
-
- info = 0;
- if (! lside && ! lsame_(side, "R", (ftnlen)1, (ftnlen)1)) {
- info = 1;
- } else if (! upper && ! lsame_(uplo, "L", (ftnlen)1, (ftnlen)1)) {
- info = 2;
- } else if (! lsame_(transa, "N", (ftnlen)1, (ftnlen)1) && ! lsame_(transa,
- "T", (ftnlen)1, (ftnlen)1) && ! lsame_(transa, "C", (ftnlen)1, (
- ftnlen)1)) {
- info = 3;
- } else if (! lsame_(diag, "U", (ftnlen)1, (ftnlen)1) && ! lsame_(diag,
- "N", (ftnlen)1, (ftnlen)1)) {
- info = 4;
- } else if (*m < 0) {
- info = 5;
- } else if (*n < 0) {
- info = 6;
- } else if (*lda < max(1,nrowa)) {
- info = 9;
- } else if (*ldb < max(1,*m)) {
- info = 11;
- }
- if (info != 0) {
- xerbla_("DTRSM ", &info, (ftnlen)6);
- return 0;
- }
-
-/* Quick return if possible. */
-
- if (*n == 0) {
- return 0;
- }
-
-/* And when alpha.eq.zero. */
-
- if (*alpha == 0.) {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- i__2 = *m;
- for (i__ = 1; i__ <= i__2; ++i__) {
- b[i__ + j * b_dim1] = 0.;
-/* L10: */
- }
-/* L20: */
- }
- return 0;
- }
-
-/* Start the operations. */
-
- if (lside) {
- if (lsame_(transa, "N", (ftnlen)1, (ftnlen)1)) {
-
-/* Form B := alpha*inv( A )*B. */
-
- if (upper) {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- if (*alpha != 1.) {
- i__2 = *m;
- for (i__ = 1; i__ <= i__2; ++i__) {
- b[i__ + j * b_dim1] = *alpha * b[i__ + j * b_dim1]
- ;
-/* L30: */
- }
- }
- for (k = *m; k >= 1; --k) {
- if (b[k + j * b_dim1] != 0.) {
- if (nounit) {
- b[k + j * b_dim1] /= a[k + k * a_dim1];
- }
- i__2 = k - 1;
- for (i__ = 1; i__ <= i__2; ++i__) {
- b[i__ + j * b_dim1] -= b[k + j * b_dim1] * a[
- i__ + k * a_dim1];
-/* L40: */
- }
- }
-/* L50: */
- }
-/* L60: */
- }
- } else {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- if (*alpha != 1.) {
- i__2 = *m;
- for (i__ = 1; i__ <= i__2; ++i__) {
- b[i__ + j * b_dim1] = *alpha * b[i__ + j * b_dim1]
- ;
-/* L70: */
- }
- }
- i__2 = *m;
- for (k = 1; k <= i__2; ++k) {
- if (b[k + j * b_dim1] != 0.) {
- if (nounit) {
- b[k + j * b_dim1] /= a[k + k * a_dim1];
- }
- i__3 = *m;
- for (i__ = k + 1; i__ <= i__3; ++i__) {
- b[i__ + j * b_dim1] -= b[k + j * b_dim1] * a[
- i__ + k * a_dim1];
-/* L80: */
- }
- }
-/* L90: */
- }
-/* L100: */
- }
- }
- } else {
-
-/* Form B := alpha*inv( A' )*B. */
-
- if (upper) {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- i__2 = *m;
- for (i__ = 1; i__ <= i__2; ++i__) {
- temp = *alpha * b[i__ + j * b_dim1];
- i__3 = i__ - 1;
- for (k = 1; k <= i__3; ++k) {
- temp -= a[k + i__ * a_dim1] * b[k + j * b_dim1];
-/* L110: */
- }
- if (nounit) {
- temp /= a[i__ + i__ * a_dim1];
- }
- b[i__ + j * b_dim1] = temp;
-/* L120: */
- }
-/* L130: */
- }
- } else {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- for (i__ = *m; i__ >= 1; --i__) {
- temp = *alpha * b[i__ + j * b_dim1];
- i__2 = *m;
- for (k = i__ + 1; k <= i__2; ++k) {
- temp -= a[k + i__ * a_dim1] * b[k + j * b_dim1];
-/* L140: */
- }
- if (nounit) {
- temp /= a[i__ + i__ * a_dim1];
- }
- b[i__ + j * b_dim1] = temp;
-/* L150: */
- }
-/* L160: */
- }
- }
- }
- } else {
- if (lsame_(transa, "N", (ftnlen)1, (ftnlen)1)) {
-
-/* Form B := alpha*B*inv( A ). */
-
- if (upper) {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- if (*alpha != 1.) {
- i__2 = *m;
- for (i__ = 1; i__ <= i__2; ++i__) {
- b[i__ + j * b_dim1] = *alpha * b[i__ + j * b_dim1]
- ;
-/* L170: */
- }
- }
- i__2 = j - 1;
- for (k = 1; k <= i__2; ++k) {
- if (a[k + j * a_dim1] != 0.) {
- i__3 = *m;
- for (i__ = 1; i__ <= i__3; ++i__) {
- b[i__ + j * b_dim1] -= a[k + j * a_dim1] * b[
- i__ + k * b_dim1];
-/* L180: */
- }
- }
-/* L190: */
- }
- if (nounit) {
- temp = 1. / a[j + j * a_dim1];
- i__2 = *m;
- for (i__ = 1; i__ <= i__2; ++i__) {
- b[i__ + j * b_dim1] = temp * b[i__ + j * b_dim1];
-/* L200: */
- }
- }
-/* L210: */
- }
- } else {
- for (j = *n; j >= 1; --j) {
- if (*alpha != 1.) {
- i__1 = *m;
- for (i__ = 1; i__ <= i__1; ++i__) {
- b[i__ + j * b_dim1] = *alpha * b[i__ + j * b_dim1]
- ;
-/* L220: */
- }
- }
- i__1 = *n;
- for (k = j + 1; k <= i__1; ++k) {
- if (a[k + j * a_dim1] != 0.) {
- i__2 = *m;
- for (i__ = 1; i__ <= i__2; ++i__) {
- b[i__ + j * b_dim1] -= a[k + j * a_dim1] * b[
- i__ + k * b_dim1];
-/* L230: */
- }
- }
-/* L240: */
- }
- if (nounit) {
- temp = 1. / a[j + j * a_dim1];
- i__1 = *m;
- for (i__ = 1; i__ <= i__1; ++i__) {
- b[i__ + j * b_dim1] = temp * b[i__ + j * b_dim1];
-/* L250: */
- }
- }
-/* L260: */
- }
- }
- } else {
-
-/* Form B := alpha*B*inv( A' ). */
-
- if (upper) {
- for (k = *n; k >= 1; --k) {
- if (nounit) {
- temp = 1. / a[k + k * a_dim1];
- i__1 = *m;
- for (i__ = 1; i__ <= i__1; ++i__) {
- b[i__ + k * b_dim1] = temp * b[i__ + k * b_dim1];
-/* L270: */
- }
- }
- i__1 = k - 1;
- for (j = 1; j <= i__1; ++j) {
- if (a[j + k * a_dim1] != 0.) {
- temp = a[j + k * a_dim1];
- i__2 = *m;
- for (i__ = 1; i__ <= i__2; ++i__) {
- b[i__ + j * b_dim1] -= temp * b[i__ + k *
- b_dim1];
-/* L280: */
- }
- }
-/* L290: */
- }
- if (*alpha != 1.) {
- i__1 = *m;
- for (i__ = 1; i__ <= i__1; ++i__) {
- b[i__ + k * b_dim1] = *alpha * b[i__ + k * b_dim1]
- ;
-/* L300: */
- }
- }
-/* L310: */
- }
- } else {
- i__1 = *n;
- for (k = 1; k <= i__1; ++k) {
- if (nounit) {
- temp = 1. / a[k + k * a_dim1];
- i__2 = *m;
- for (i__ = 1; i__ <= i__2; ++i__) {
- b[i__ + k * b_dim1] = temp * b[i__ + k * b_dim1];
-/* L320: */
- }
- }
- i__2 = *n;
- for (j = k + 1; j <= i__2; ++j) {
- if (a[j + k * a_dim1] != 0.) {
- temp = a[j + k * a_dim1];
- i__3 = *m;
- for (i__ = 1; i__ <= i__3; ++i__) {
- b[i__ + j * b_dim1] -= temp * b[i__ + k *
- b_dim1];
-/* L330: */
- }
- }
-/* L340: */
- }
- if (*alpha != 1.) {
- i__2 = *m;
- for (i__ = 1; i__ <= i__2; ++i__) {
- b[i__ + k * b_dim1] = *alpha * b[i__ + k * b_dim1]
- ;
-/* L350: */
- }
- }
-/* L360: */
- }
- }
- }
- }
-
- return 0;
-
-/* End of DTRSM . */
-
-} /* dtrsm_ */
-
-/* Subroutine */ int dtrsv_(char *uplo, char *trans, char *diag, integer *n,
- doublereal *a, integer *lda, doublereal *x, integer *incx, ftnlen
- uplo_len, ftnlen trans_len, ftnlen diag_len)
-{
- /* System generated locals */
- integer a_dim1, a_offset, i__1, i__2;
-
- /* Local variables */
- static integer i__, j, ix, jx, kx, info;
- static doublereal temp;
- extern logical lsame_(char *, char *, ftnlen, ftnlen);
- extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen);
- static logical nounit;
-
-/* .. Scalar Arguments .. */
-/* .. Array Arguments .. */
-/* .. */
-
-/* Purpose */
-/* ======= */
-
-/* DTRSV solves one of the systems of equations */
-
-/* A*x = b, or A'*x = b, */
-
-/* where b and x are n element vectors and A is an n by n unit, or */
-/* non-unit, upper or lower triangular matrix. */
-
-/* No test for singularity or near-singularity is included in this */
-/* routine. Such tests must be performed before calling this routine. */
-
-/* Parameters */
-/* ========== */
-
-/* UPLO - CHARACTER*1. */
-/* On entry, UPLO specifies whether the matrix is an upper or */
-/* lower triangular matrix as follows: */
-
-/* UPLO = 'U' or 'u' A is an upper triangular matrix. */
-
-/* UPLO = 'L' or 'l' A is a lower triangular matrix. */
-
-/* Unchanged on exit. */
-
-/* TRANS - CHARACTER*1. */
-/* On entry, TRANS specifies the equations to be solved as */
-/* follows: */
-
-/* TRANS = 'N' or 'n' A*x = b. */
-
-/* TRANS = 'T' or 't' A'*x = b. */
-
-/* TRANS = 'C' or 'c' A'*x = b. */
-
-/* Unchanged on exit. */
-
-/* DIAG - CHARACTER*1. */
-/* On entry, DIAG specifies whether or not A is unit */
-/* triangular as follows: */
-
-/* DIAG = 'U' or 'u' A is assumed to be unit triangular. */
-
-/* DIAG = 'N' or 'n' A is not assumed to be unit */
-/* triangular. */
-
-/* Unchanged on exit. */
-
-/* N - INTEGER. */
-/* On entry, N specifies the order of the matrix A. */
-/* N must be at least zero. */
-/* Unchanged on exit. */
-
-/* A - DOUBLE PRECISION array of DIMENSION ( LDA, n ). */
-/* Before entry with UPLO = 'U' or 'u', the leading n by n */
-/* upper triangular part of the array A must contain the upper */
-/* triangular matrix and the strictly lower triangular part of */
-/* A is not referenced. */
-/* Before entry with UPLO = 'L' or 'l', the leading n by n */
-/* lower triangular part of the array A must contain the lower */
-/* triangular matrix and the strictly upper triangular part of */
-/* A is not referenced. */
-/* Note that when DIAG = 'U' or 'u', the diagonal elements of */
-/* A are not referenced either, but are assumed to be unity. */
-/* Unchanged on exit. */
-
-/* LDA - INTEGER. */
-/* On entry, LDA specifies the first dimension of A as declared */
-/* in the calling (sub) program. LDA must be at least */
-/* max( 1, n ). */
-/* Unchanged on exit. */
-
-/* X - DOUBLE PRECISION array of dimension at least */
-/* ( 1 + ( n - 1 )*abs( INCX ) ). */
-/* Before entry, the incremented array X must contain the n */
-/* element right-hand side vector b. On exit, X is overwritten */
-/* with the solution vector x. */
-
-/* INCX - INTEGER. */
-/* On entry, INCX specifies the increment for the elements of */
-/* X. INCX must not be zero. */
-/* Unchanged on exit. */
-
-
-/* Level 2 Blas routine. */
-
-/* -- Written on 22-October-1986. */
-/* Jack Dongarra, Argonne National Lab. */
-/* Jeremy Du Croz, Nag Central Office. */
-/* Sven Hammarling, Nag Central Office. */
-/* Richard Hanson, Sandia National Labs. */
-
-
-/* .. Parameters .. */
-/* .. Local Scalars .. */
-/* .. External Functions .. */
-/* .. External Subroutines .. */
-/* .. Intrinsic Functions .. */
-/* .. */
-/* .. Executable Statements .. */
-
-/* Test the input parameters. */
-
- /* Parameter adjustments */
- a_dim1 = *lda;
- a_offset = 1 + a_dim1 * 1;
- a -= a_offset;
- --x;
-
- /* Function Body */
- info = 0;
- if (! lsame_(uplo, "U", (ftnlen)1, (ftnlen)1) && ! lsame_(uplo, "L", (
- ftnlen)1, (ftnlen)1)) {
- info = 1;
- } else if (! lsame_(trans, "N", (ftnlen)1, (ftnlen)1) && ! lsame_(trans,
- "T", (ftnlen)1, (ftnlen)1) && ! lsame_(trans, "C", (ftnlen)1, (
- ftnlen)1)) {
- info = 2;
- } else if (! lsame_(diag, "U", (ftnlen)1, (ftnlen)1) && ! lsame_(diag,
- "N", (ftnlen)1, (ftnlen)1)) {
- info = 3;
- } else if (*n < 0) {
- info = 4;
- } else if (*lda < max(1,*n)) {
- info = 6;
- } else if (*incx == 0) {
- info = 8;
- }
- if (info != 0) {
- xerbla_("DTRSV ", &info, (ftnlen)6);
- return 0;
- }
-
-/* Quick return if possible. */
-
- if (*n == 0) {
- return 0;
- }
-
- nounit = lsame_(diag, "N", (ftnlen)1, (ftnlen)1);
-
-/* Set up the start point in X if the increment is not unity. This */
-/* will be ( N - 1 )*INCX too small for descending loops. */
-
- if (*incx <= 0) {
- kx = 1 - (*n - 1) * *incx;
- } else if (*incx != 1) {
- kx = 1;
- }
-
-/* Start the operations. In this version the elements of A are */
-/* accessed sequentially with one pass through A. */
-
- if (lsame_(trans, "N", (ftnlen)1, (ftnlen)1)) {
-
-/* Form x := inv( A )*x. */
-
- if (lsame_(uplo, "U", (ftnlen)1, (ftnlen)1)) {
- if (*incx == 1) {
- for (j = *n; j >= 1; --j) {
- if (x[j] != 0.) {
- if (nounit) {
- x[j] /= a[j + j * a_dim1];
- }
- temp = x[j];
- for (i__ = j - 1; i__ >= 1; --i__) {
- x[i__] -= temp * a[i__ + j * a_dim1];
-/* L10: */
- }
- }
-/* L20: */
- }
- } else {
- jx = kx + (*n - 1) * *incx;
- for (j = *n; j >= 1; --j) {
- if (x[jx] != 0.) {
- if (nounit) {
- x[jx] /= a[j + j * a_dim1];
- }
- temp = x[jx];
- ix = jx;
- for (i__ = j - 1; i__ >= 1; --i__) {
- ix -= *incx;
- x[ix] -= temp * a[i__ + j * a_dim1];
-/* L30: */
- }
- }
- jx -= *incx;
-/* L40: */
- }
- }
- } else {
- if (*incx == 1) {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- if (x[j] != 0.) {
- if (nounit) {
- x[j] /= a[j + j * a_dim1];
- }
- temp = x[j];
- i__2 = *n;
- for (i__ = j + 1; i__ <= i__2; ++i__) {
- x[i__] -= temp * a[i__ + j * a_dim1];
-/* L50: */
- }
- }
-/* L60: */
- }
- } else {
- jx = kx;
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- if (x[jx] != 0.) {
- if (nounit) {
- x[jx] /= a[j + j * a_dim1];
- }
- temp = x[jx];
- ix = jx;
- i__2 = *n;
- for (i__ = j + 1; i__ <= i__2; ++i__) {
- ix += *incx;
- x[ix] -= temp * a[i__ + j * a_dim1];
-/* L70: */
- }
- }
- jx += *incx;
-/* L80: */
- }
- }
- }
- } else {
-
-/* Form x := inv( A' )*x. */
-
- if (lsame_(uplo, "U", (ftnlen)1, (ftnlen)1)) {
- if (*incx == 1) {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- temp = x[j];
- i__2 = j - 1;
- for (i__ = 1; i__ <= i__2; ++i__) {
- temp -= a[i__ + j * a_dim1] * x[i__];
-/* L90: */
- }
- if (nounit) {
- temp /= a[j + j * a_dim1];
- }
- x[j] = temp;
-/* L100: */
- }
- } else {
- jx = kx;
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- temp = x[jx];
- ix = kx;
- i__2 = j - 1;
- for (i__ = 1; i__ <= i__2; ++i__) {
- temp -= a[i__ + j * a_dim1] * x[ix];
- ix += *incx;
-/* L110: */
- }
- if (nounit) {
- temp /= a[j + j * a_dim1];
- }
- x[jx] = temp;
- jx += *incx;
-/* L120: */
- }
- }
- } else {
- if (*incx == 1) {
- for (j = *n; j >= 1; --j) {
- temp = x[j];
- i__1 = j + 1;
- for (i__ = *n; i__ >= i__1; --i__) {
- temp -= a[i__ + j * a_dim1] * x[i__];
-/* L130: */
- }
- if (nounit) {
- temp /= a[j + j * a_dim1];
- }
- x[j] = temp;
-/* L140: */
- }
- } else {
- kx += (*n - 1) * *incx;
- jx = kx;
- for (j = *n; j >= 1; --j) {
- temp = x[jx];
- ix = kx;
- i__1 = j + 1;
- for (i__ = *n; i__ >= i__1; --i__) {
- temp -= a[i__ + j * a_dim1] * x[ix];
- ix -= *incx;
-/* L150: */
- }
- if (nounit) {
- temp /= a[j + j * a_dim1];
- }
- x[jx] = temp;
- jx -= *incx;
-/* L160: */
- }
- }
- }
- }
-
- return 0;
-
-/* End of DTRSV . */
-
-} /* dtrsv_ */
-
-doublereal dzasum_(integer *n, doublecomplex *zx, integer *incx)
-{
- /* System generated locals */
- integer i__1;
- doublereal ret_val;
-
- /* Local variables */
- static integer i__, ix;
- static doublereal stemp;
- extern doublereal dcabs1_(doublecomplex *);
-
-
-/* takes the sum of the absolute values. */
-/* jack dongarra, 3/11/78. */
-/* modified 3/93 to return if incx .le. 0. */
-/* modified 12/3/93, array(1) declarations changed to array(*) */
-
-
- /* Parameter adjustments */
- --zx;
-
- /* Function Body */
- ret_val = 0.;
- stemp = 0.;
- if (*n <= 0 || *incx <= 0) {
- return ret_val;
- }
- if (*incx == 1) {
- goto L20;
- }
-
-/* code for increment not equal to 1 */
-
- ix = 1;
- i__1 = *n;
- for (i__ = 1; i__ <= i__1; ++i__) {
- stemp += dcabs1_(&zx[ix]);
- ix += *incx;
-/* L10: */
- }
- ret_val = stemp;
- return ret_val;
-
-/* code for increment equal to 1 */
-
-L20:
- i__1 = *n;
- for (i__ = 1; i__ <= i__1; ++i__) {
- stemp += dcabs1_(&zx[i__]);
-/* L30: */
- }
- ret_val = stemp;
- return ret_val;
-} /* dzasum_ */
-
-doublereal dznrm2_(integer *n, doublecomplex *x, integer *incx)
-{
- /* System generated locals */
- integer i__1, i__2, i__3;
- doublereal ret_val, d__1;
-
- /* Builtin functions */
- double d_imag(doublecomplex *), sqrt(doublereal);
-
- /* Local variables */
- static integer ix;
- static doublereal ssq, temp, norm, scale;
-
-/* .. Scalar Arguments .. */
-/* .. Array Arguments .. */
-/* .. */
-
-/* DZNRM2 returns the euclidean norm of a vector via the function */
-/* name, so that */
-
-/* DZNRM2 := sqrt( conjg( x' )*x ) */
-
-
-
-/* -- This version written on 25-October-1982. */
-/* Modified on 14-October-1993 to inline the call to ZLASSQ. */
-/* Sven Hammarling, Nag Ltd. */
-
-
-/* .. Parameters .. */
-/* .. Local Scalars .. */
-/* .. Intrinsic Functions .. */
-/* .. */
-/* .. Executable Statements .. */
- /* Parameter adjustments */
- --x;
-
- /* Function Body */
- if (*n < 1 || *incx < 1) {
- norm = 0.;
- } else {
- scale = 0.;
- ssq = 1.;
-/* The following loop is equivalent to this call to the LAPACK */
-/* auxiliary routine: */
-/* CALL ZLASSQ( N, X, INCX, SCALE, SSQ ) */
-
- i__1 = (*n - 1) * *incx + 1;
- i__2 = *incx;
- for (ix = 1; i__2 < 0 ? ix >= i__1 : ix <= i__1; ix += i__2) {
- i__3 = ix;
- if (x[i__3].r != 0.) {
- i__3 = ix;
- temp = (d__1 = x[i__3].r, abs(d__1));
- if (scale < temp) {
-/* Computing 2nd power */
- d__1 = scale / temp;
- ssq = ssq * (d__1 * d__1) + 1.;
- scale = temp;
- } else {
-/* Computing 2nd power */
- d__1 = temp / scale;
- ssq += d__1 * d__1;
- }
- }
- if (d_imag(&x[ix]) != 0.) {
- temp = (d__1 = d_imag(&x[ix]), abs(d__1));
- if (scale < temp) {
-/* Computing 2nd power */
- d__1 = scale / temp;
- ssq = ssq * (d__1 * d__1) + 1.;
- scale = temp;
- } else {
-/* Computing 2nd power */
- d__1 = temp / scale;
- ssq += d__1 * d__1;
- }
- }
-/* L10: */
- }
- norm = scale * sqrt(ssq);
- }
-
- ret_val = norm;
- return ret_val;
-
-/* End of DZNRM2. */
-
-} /* dznrm2_ */
-
-integer icamax_(integer *n, complex *cx, integer *incx)
-{
- /* System generated locals */
- integer ret_val, i__1, i__2;
- real r__1, r__2;
-
- /* Builtin functions */
- double r_imag(complex *);
-
- /* Local variables */
- static integer i__, ix;
- static real smax;
-
-
-/* finds the index of element having max. absolute value. */
-/* jack dongarra, linpack, 3/11/78. */
-/* modified 3/93 to return if incx .le. 0. */
-/* modified 12/3/93, array(1) declarations changed to array(*) */
-
-
- /* Parameter adjustments */
- --cx;
-
- /* Function Body */
- ret_val = 0;
- if (*n < 1 || *incx <= 0) {
- return ret_val;
- }
- ret_val = 1;
- if (*n == 1) {
- return ret_val;
- }
- if (*incx == 1) {
- goto L20;
- }
-
-/* code for increment not equal to 1 */
-
- ix = 1;
- smax = (r__1 = cx[1].r, dabs(r__1)) + (r__2 = r_imag(&cx[1]), dabs(r__2));
- ix += *incx;
- i__1 = *n;
- for (i__ = 2; i__ <= i__1; ++i__) {
- i__2 = ix;
- if ((r__1 = cx[i__2].r, dabs(r__1)) + (r__2 = r_imag(&cx[ix]), dabs(
- r__2)) <= smax) {
- goto L5;
- }
- ret_val = i__;
- i__2 = ix;
- smax = (r__1 = cx[i__2].r, dabs(r__1)) + (r__2 = r_imag(&cx[ix]),
- dabs(r__2));
-L5:
- ix += *incx;
-/* L10: */
- }
- return ret_val;
-
-/* code for increment equal to 1 */
-
-L20:
- smax = (r__1 = cx[1].r, dabs(r__1)) + (r__2 = r_imag(&cx[1]), dabs(r__2));
- i__1 = *n;
- for (i__ = 2; i__ <= i__1; ++i__) {
- i__2 = i__;
- if ((r__1 = cx[i__2].r, dabs(r__1)) + (r__2 = r_imag(&cx[i__]), dabs(
- r__2)) <= smax) {
- goto L30;
- }
- ret_val = i__;
- i__2 = i__;
- smax = (r__1 = cx[i__2].r, dabs(r__1)) + (r__2 = r_imag(&cx[i__]),
- dabs(r__2));
-L30:
- ;
- }
- return ret_val;
-} /* icamax_ */
-
-integer idamax_(integer *n, doublereal *dx, integer *incx)
-{
- /* System generated locals */
- integer ret_val, i__1;
- doublereal d__1;
-
- /* Local variables */
- static integer i__, ix;
- static doublereal dmax__;
-
-
-/* finds the index of element having max. absolute value. */
-/* jack dongarra, linpack, 3/11/78. */
-/* modified 3/93 to return if incx .le. 0. */
-/* modified 12/3/93, array(1) declarations changed to array(*) */
-
-
- /* Parameter adjustments */
- --dx;
-
- /* Function Body */
- ret_val = 0;
- if (*n < 1 || *incx <= 0) {
- return ret_val;
- }
- ret_val = 1;
- if (*n == 1) {
- return ret_val;
- }
- if (*incx == 1) {
- goto L20;
- }
-
-/* code for increment not equal to 1 */
-
- ix = 1;
- dmax__ = abs(dx[1]);
- ix += *incx;
- i__1 = *n;
- for (i__ = 2; i__ <= i__1; ++i__) {
- if ((d__1 = dx[ix], abs(d__1)) <= dmax__) {
- goto L5;
- }
- ret_val = i__;
- dmax__ = (d__1 = dx[ix], abs(d__1));
-L5:
- ix += *incx;
-/* L10: */
- }
- return ret_val;
-
-/* code for increment equal to 1 */
-
-L20:
- dmax__ = abs(dx[1]);
- i__1 = *n;
- for (i__ = 2; i__ <= i__1; ++i__) {
- if ((d__1 = dx[i__], abs(d__1)) <= dmax__) {
- goto L30;
- }
- ret_val = i__;
- dmax__ = (d__1 = dx[i__], abs(d__1));
-L30:
- ;
- }
- return ret_val;
-} /* idamax_ */
-
-integer isamax_(integer *n, real *sx, integer *incx)
-{
- /* System generated locals */
- integer ret_val, i__1;
- real r__1;
-
- /* Local variables */
- static integer i__, ix;
- static real smax;
-
-
-/* finds the index of element having max. absolute value. */
-/* jack dongarra, linpack, 3/11/78. */
-/* modified 3/93 to return if incx .le. 0. */
-/* modified 12/3/93, array(1) declarations changed to array(*) */
-
-
- /* Parameter adjustments */
- --sx;
-
- /* Function Body */
- ret_val = 0;
- if (*n < 1 || *incx <= 0) {
- return ret_val;
- }
- ret_val = 1;
- if (*n == 1) {
- return ret_val;
- }
- if (*incx == 1) {
- goto L20;
- }
-
-/* code for increment not equal to 1 */
-
- ix = 1;
- smax = dabs(sx[1]);
- ix += *incx;
- i__1 = *n;
- for (i__ = 2; i__ <= i__1; ++i__) {
- if ((r__1 = sx[ix], dabs(r__1)) <= smax) {
- goto L5;
- }
- ret_val = i__;
- smax = (r__1 = sx[ix], dabs(r__1));
-L5:
- ix += *incx;
-/* L10: */
- }
- return ret_val;
-
-/* code for increment equal to 1 */
-
-L20:
- smax = dabs(sx[1]);
- i__1 = *n;
- for (i__ = 2; i__ <= i__1; ++i__) {
- if ((r__1 = sx[i__], dabs(r__1)) <= smax) {
- goto L30;
- }
- ret_val = i__;
- smax = (r__1 = sx[i__], dabs(r__1));
-L30:
- ;
- }
- return ret_val;
-} /* isamax_ */
-
-integer izamax_(integer *n, doublecomplex *zx, integer *incx)
-{
- /* System generated locals */
- integer ret_val, i__1;
-
- /* Local variables */
- static integer i__, ix;
- static doublereal smax;
- extern doublereal dcabs1_(doublecomplex *);
-
-
-/* finds the index of element having max. absolute value. */
-/* jack dongarra, 1/15/85. */
-/* modified 3/93 to return if incx .le. 0. */
-/* modified 12/3/93, array(1) declarations changed to array(*) */
-
-
- /* Parameter adjustments */
- --zx;
-
- /* Function Body */
- ret_val = 0;
- if (*n < 1 || *incx <= 0) {
- return ret_val;
- }
- ret_val = 1;
- if (*n == 1) {
- return ret_val;
- }
- if (*incx == 1) {
- goto L20;
- }
-
-/* code for increment not equal to 1 */
-
- ix = 1;
- smax = dcabs1_(&zx[1]);
- ix += *incx;
- i__1 = *n;
- for (i__ = 2; i__ <= i__1; ++i__) {
- if (dcabs1_(&zx[ix]) <= smax) {
- goto L5;
- }
- ret_val = i__;
- smax = dcabs1_(&zx[ix]);
-L5:
- ix += *incx;
-/* L10: */
- }
- return ret_val;
-
-/* code for increment equal to 1 */
-
-L20:
- smax = dcabs1_(&zx[1]);
- i__1 = *n;
- for (i__ = 2; i__ <= i__1; ++i__) {
- if (dcabs1_(&zx[i__]) <= smax) {
- goto L30;
- }
- ret_val = i__;
- smax = dcabs1_(&zx[i__]);
-L30:
- ;
- }
- return ret_val;
-} /* izamax_ */
-
-
-doublereal sasum_(integer *n, real *sx, integer *incx)
-{
- /* System generated locals */
- integer i__1, i__2;
- real ret_val, r__1, r__2, r__3, r__4, r__5, r__6;
-
- /* Local variables */
- static integer i__, m, mp1, nincx;
- static real stemp;
-
-
-/* takes the sum of the absolute values. */
-/* uses unrolled loops for increment equal to one. */
-/* jack dongarra, linpack, 3/11/78. */
-/* modified 3/93 to return if incx .le. 0. */
-/* modified 12/3/93, array(1) declarations changed to array(*) */
-
-
- /* Parameter adjustments */
- --sx;
-
- /* Function Body */
- ret_val = 0.f;
- stemp = 0.f;
- if (*n <= 0 || *incx <= 0) {
- return ret_val;
- }
- if (*incx == 1) {
- goto L20;
- }
-
-/* code for increment not equal to 1 */
-
- nincx = *n * *incx;
- i__1 = nincx;
- i__2 = *incx;
- for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
- stemp += (r__1 = sx[i__], dabs(r__1));
-/* L10: */
- }
- ret_val = stemp;
- return ret_val;
-
-/* code for increment equal to 1 */
-
-
-/* clean-up loop */
-
-L20:
- m = *n % 6;
- if (m == 0) {
- goto L40;
- }
- i__2 = m;
- for (i__ = 1; i__ <= i__2; ++i__) {
- stemp += (r__1 = sx[i__], dabs(r__1));
-/* L30: */
- }
- if (*n < 6) {
- goto L60;
- }
-L40:
- mp1 = m + 1;
- i__2 = *n;
- for (i__ = mp1; i__ <= i__2; i__ += 6) {
- stemp = stemp + (r__1 = sx[i__], dabs(r__1)) + (r__2 = sx[i__ + 1],
- dabs(r__2)) + (r__3 = sx[i__ + 2], dabs(r__3)) + (r__4 = sx[
- i__ + 3], dabs(r__4)) + (r__5 = sx[i__ + 4], dabs(r__5)) + (
- r__6 = sx[i__ + 5], dabs(r__6));
-/* L50: */
- }
-L60:
- ret_val = stemp;
- return ret_val;
-} /* sasum_ */
-
-/* Subroutine */ int saxpy_(integer *n, real *sa, real *sx, integer *incx,
- real *sy, integer *incy)
-{
- /* System generated locals */
- integer i__1;
-
- /* Local variables */
- static integer i__, m, ix, iy, mp1;
-
-
-/* constant times a vector plus a vector. */
-/* uses unrolled loop for increments equal to one. */
-/* jack dongarra, linpack, 3/11/78. */
-/* modified 12/3/93, array(1) declarations changed to array(*) */
-
-
- /* Parameter adjustments */
- --sy;
- --sx;
-
- /* Function Body */
- if (*n <= 0) {
- return 0;
- }
- if (*sa == 0.f) {
- return 0;
- }
- if (*incx == 1 && *incy == 1) {
- goto L20;
- }
-
-/* code for unequal increments or equal increments */
-/* not equal to 1 */
-
- ix = 1;
- iy = 1;
- if (*incx < 0) {
- ix = (-(*n) + 1) * *incx + 1;
- }
- if (*incy < 0) {
- iy = (-(*n) + 1) * *incy + 1;
- }
- i__1 = *n;
- for (i__ = 1; i__ <= i__1; ++i__) {
- sy[iy] += *sa * sx[ix];
- ix += *incx;
- iy += *incy;
-/* L10: */
- }
- return 0;
-
-/* code for both increments equal to 1 */
-
-
-/* clean-up loop */
-
-L20:
- m = *n % 4;
- if (m == 0) {
- goto L40;
- }
- i__1 = m;
- for (i__ = 1; i__ <= i__1; ++i__) {
- sy[i__] += *sa * sx[i__];
-/* L30: */
- }
- if (*n < 4) {
- return 0;
- }
-L40:
- mp1 = m + 1;
- i__1 = *n;
- for (i__ = mp1; i__ <= i__1; i__ += 4) {
- sy[i__] += *sa * sx[i__];
- sy[i__ + 1] += *sa * sx[i__ + 1];
- sy[i__ + 2] += *sa * sx[i__ + 2];
- sy[i__ + 3] += *sa * sx[i__ + 3];
-/* L50: */
- }
- return 0;
-} /* saxpy_ */
-
-doublereal scasum_(integer *n, complex *cx, integer *incx)
-{
- /* System generated locals */
- integer i__1, i__2, i__3;
- real ret_val, r__1, r__2;
-
- /* Builtin functions */
- double r_imag(complex *);
-
- /* Local variables */
- static integer i__, nincx;
- static real stemp;
-
-
-/* takes the sum of the absolute values of a complex vector and */
-/* returns a single precision result. */
-/* jack dongarra, linpack, 3/11/78. */
-/* modified 3/93 to return if incx .le. 0. */
-/* modified 12/3/93, array(1) declarations changed to array(*) */
-
-
- /* Parameter adjustments */
- --cx;
-
- /* Function Body */
- ret_val = 0.f;
- stemp = 0.f;
- if (*n <= 0 || *incx <= 0) {
- return ret_val;
- }
- if (*incx == 1) {
- goto L20;
- }
-
-/* code for increment not equal to 1 */
-
- nincx = *n * *incx;
- i__1 = nincx;
- i__2 = *incx;
- for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
- i__3 = i__;
- stemp = stemp + (r__1 = cx[i__3].r, dabs(r__1)) + (r__2 = r_imag(&cx[
- i__]), dabs(r__2));
-/* L10: */
- }
- ret_val = stemp;
- return ret_val;
-
-/* code for increment equal to 1 */
-
-L20:
- i__2 = *n;
- for (i__ = 1; i__ <= i__2; ++i__) {
- i__1 = i__;
- stemp = stemp + (r__1 = cx[i__1].r, dabs(r__1)) + (r__2 = r_imag(&cx[
- i__]), dabs(r__2));
-/* L30: */
- }
- ret_val = stemp;
- return ret_val;
-} /* scasum_ */
-
-doublereal scnrm2_(integer *n, complex *x, integer *incx)
-{
- /* System generated locals */
- integer i__1, i__2, i__3;
- real ret_val, r__1;
-
- /* Builtin functions */
- double r_imag(complex *), sqrt(doublereal);
-
- /* Local variables */
- static integer ix;
- static real ssq, temp, norm, scale;
-
-/* .. Scalar Arguments .. */
-/* .. Array Arguments .. */
-/* .. */
-
-/* SCNRM2 returns the euclidean norm of a vector via the function */
-/* name, so that */
-
-/* SCNRM2 := sqrt( conjg( x' )*x ) */
-
-
-
-/* -- This version written on 25-October-1982. */
-/* Modified on 14-October-1993 to inline the call to CLASSQ. */
-/* Sven Hammarling, Nag Ltd. */
-
-
-/* .. Parameters .. */
-/* .. Local Scalars .. */
-/* .. Intrinsic Functions .. */
-/* .. */
-/* .. Executable Statements .. */
- /* Parameter adjustments */
- --x;
-
- /* Function Body */
- if (*n < 1 || *incx < 1) {
- norm = 0.f;
- } else {
- scale = 0.f;
- ssq = 1.f;
-/* The following loop is equivalent to this call to the LAPACK */
-/* auxiliary routine: */
-/* CALL CLASSQ( N, X, INCX, SCALE, SSQ ) */
-
- i__1 = (*n - 1) * *incx + 1;
- i__2 = *incx;
- for (ix = 1; i__2 < 0 ? ix >= i__1 : ix <= i__1; ix += i__2) {
- i__3 = ix;
- if (x[i__3].r != 0.f) {
- i__3 = ix;
- temp = (r__1 = x[i__3].r, dabs(r__1));
- if (scale < temp) {
-/* Computing 2nd power */
- r__1 = scale / temp;
- ssq = ssq * (r__1 * r__1) + 1.f;
- scale = temp;
- } else {
-/* Computing 2nd power */
- r__1 = temp / scale;
- ssq += r__1 * r__1;
- }
- }
- if (r_imag(&x[ix]) != 0.f) {
- temp = (r__1 = r_imag(&x[ix]), dabs(r__1));
- if (scale < temp) {
-/* Computing 2nd power */
- r__1 = scale / temp;
- ssq = ssq * (r__1 * r__1) + 1.f;
- scale = temp;
- } else {
-/* Computing 2nd power */
- r__1 = temp / scale;
- ssq += r__1 * r__1;
- }
- }
-/* L10: */
- }
- norm = scale * sqrt(ssq);
- }
-
- ret_val = norm;
- return ret_val;
-
-/* End of SCNRM2. */
-
-} /* scnrm2_ */
-
-/* Subroutine */ int scopy_(integer *n, real *sx, integer *incx, real *sy,
- integer *incy)
-{
- /* System generated locals */
- integer i__1;
-
- /* Local variables */
- static integer i__, m, ix, iy, mp1;
-
-
-/* copies a vector, x, to a vector, y. */
-/* uses unrolled loops for increments equal to 1. */
-/* jack dongarra, linpack, 3/11/78. */
-/* modified 12/3/93, array(1) declarations changed to array(*) */
-
-
- /* Parameter adjustments */
- --sy;
- --sx;
-
- /* Function Body */
- if (*n <= 0) {
- return 0;
- }
- if (*incx == 1 && *incy == 1) {
- goto L20;
- }
-
-/* code for unequal increments or equal increments */
-/* not equal to 1 */
-
- ix = 1;
- iy = 1;
- if (*incx < 0) {
- ix = (-(*n) + 1) * *incx + 1;
- }
- if (*incy < 0) {
- iy = (-(*n) + 1) * *incy + 1;
- }
- i__1 = *n;
- for (i__ = 1; i__ <= i__1; ++i__) {
- sy[iy] = sx[ix];
- ix += *incx;
- iy += *incy;
-/* L10: */
- }
- return 0;
-
-/* code for both increments equal to 1 */
-
-
-/* clean-up loop */
-
-L20:
- m = *n % 7;
- if (m == 0) {
- goto L40;
- }
- i__1 = m;
- for (i__ = 1; i__ <= i__1; ++i__) {
- sy[i__] = sx[i__];
-/* L30: */
- }
- if (*n < 7) {
- return 0;
- }
-L40:
- mp1 = m + 1;
- i__1 = *n;
- for (i__ = mp1; i__ <= i__1; i__ += 7) {
- sy[i__] = sx[i__];
- sy[i__ + 1] = sx[i__ + 1];
- sy[i__ + 2] = sx[i__ + 2];
- sy[i__ + 3] = sx[i__ + 3];
- sy[i__ + 4] = sx[i__ + 4];
- sy[i__ + 5] = sx[i__ + 5];
- sy[i__ + 6] = sx[i__ + 6];
-/* L50: */
- }
- return 0;
-} /* scopy_ */
-
-doublereal sdot_(integer *n, real *sx, integer *incx, real *sy, integer *incy)
-{
- /* System generated locals */
- integer i__1;
- real ret_val;
-
- /* Local variables */
- static integer i__, m, ix, iy, mp1;
- static real stemp;
-
-
-/* forms the dot product of two vectors. */
-/* uses unrolled loops for increments equal to one. */
-/* jack dongarra, linpack, 3/11/78. */
-/* modified 12/3/93, array(1) declarations changed to array(*) */
-
-
- /* Parameter adjustments */
- --sy;
- --sx;
-
- /* Function Body */
- stemp = 0.f;
- ret_val = 0.f;
- if (*n <= 0) {
- return ret_val;
- }
- if (*incx == 1 && *incy == 1) {
- goto L20;
- }
-
-/* code for unequal increments or equal increments */
-/* not equal to 1 */
-
- ix = 1;
- iy = 1;
- if (*incx < 0) {
- ix = (-(*n) + 1) * *incx + 1;
- }
- if (*incy < 0) {
- iy = (-(*n) + 1) * *incy + 1;
- }
- i__1 = *n;
- for (i__ = 1; i__ <= i__1; ++i__) {
- stemp += sx[ix] * sy[iy];
- ix += *incx;
- iy += *incy;
-/* L10: */
- }
- ret_val = stemp;
- return ret_val;
-
-/* code for both increments equal to 1 */
-
-
-/* clean-up loop */
-
-L20:
- m = *n % 5;
- if (m == 0) {
- goto L40;
- }
- i__1 = m;
- for (i__ = 1; i__ <= i__1; ++i__) {
- stemp += sx[i__] * sy[i__];
-/* L30: */
- }
- if (*n < 5) {
- goto L60;
- }
-L40:
- mp1 = m + 1;
- i__1 = *n;
- for (i__ = mp1; i__ <= i__1; i__ += 5) {
- stemp = stemp + sx[i__] * sy[i__] + sx[i__ + 1] * sy[i__ + 1] + sx[
- i__ + 2] * sy[i__ + 2] + sx[i__ + 3] * sy[i__ + 3] + sx[i__ +
- 4] * sy[i__ + 4];
-/* L50: */
- }
-L60:
- ret_val = stemp;
- return ret_val;
-} /* sdot_ */
-
-/* DECK SDSDOT */
-doublereal sdsdot_(integer *n, real *sb, real *sx, integer *incx, real *sy,
- integer *incy)
-{
- /* System generated locals */
- integer i__1, i__2;
- real ret_val;
-
- /* Local variables */
- static integer i__, ns, kx, ky;
- static doublereal dsdot;
-
-/* ***BEGIN PROLOGUE SDSDOT */
-/* ***PURPOSE Compute the inner product of two vectors with extended */
-/* precision accumulation. */
-/* ***LIBRARY SLATEC (BLAS) */
-/* ***CATEGORY D1A4 */
-/* ***TYPE SINGLE PRECISION (SDSDOT-S, CDCDOT-C) */
-/* ***KEYWORDS BLAS, DOT PRODUCT, INNER PRODUCT, LINEAR ALGEBRA, VECTOR */
-/* ***AUTHOR Lawson, C. L., (JPL) */
-/* Hanson, R. J., (SNLA) */
-/* Kincaid, D. R., (U. of Texas) */
-/* Krogh, F. T., (JPL) */
-/* ***DESCRIPTION */
-
-/* B L A S Subprogram */
-/* Description of Parameters */
-
-/* --Input-- */
-/* N number of elements in input vector(s) */
-/* SB single precision scalar to be added to inner product */
-/* SX single precision vector with N elements */
-/* INCX storage spacing between elements of SX */
-/* SY single precision vector with N elements */
-/* INCY storage spacing between elements of SY */
-
-/* --Output-- */
-/* SDSDOT single precision dot product (SB if N .LE. 0) */
-
-/* Returns S.P. result with dot product accumulated in D.P. */
-/* SDSDOT = SB + sum for I = 0 to N-1 of SX(LX+I*INCX)*SY(LY+I*INCY), */
-/* where LX = 1 if INCX .GE. 0, else LX = 1+(1-N)*INCX, and LY is */
-/* defined in a similar way using INCY. */
-
-/* ***REFERENCES C. L. Lawson, R. J. Hanson, D. R. Kincaid and F. T. */
-/* Krogh, Basic linear algebra subprograms for Fortran */
-/* usage, Algorithm No. 539, Transactions on Mathematical */
-/* Software 5, 3 (September 1979), pp. 308-323. */
-/* ***ROUTINES CALLED (NONE) */
-/* ***REVISION HISTORY (YYMMDD) */
-/* 791001 DATE WRITTEN */
-/* 890531 Changed all specific intrinsics to generic. (WRB) */
-/* 890831 Modified array declarations. (WRB) */
-/* 890831 REVISION DATE from Version 3.2 */
-/* 891214 Prologue converted to Version 4.0 format. (BAB) */
-/* 920310 Corrected definition of LX in DESCRIPTION. (WRB) */
-/* 920501 Reformatted the REFERENCES section. (WRB) */
-/* ***END PROLOGUE SDSDOT */
-/* ***FIRST EXECUTABLE STATEMENT SDSDOT */
- /* Parameter adjustments */
- --sy;
- --sx;
-
- /* Function Body */
- dsdot = *sb;
- if (*n <= 0) {
- goto L30;
- }
- if (*incx == *incy && *incx > 0) {
- goto L40;
- }
-
-/* Code for unequal or nonpositive increments. */
-
- kx = 1;
- ky = 1;
- if (*incx < 0) {
- kx = (1 - *n) * *incx + 1;
- }
- if (*incy < 0) {
- ky = (1 - *n) * *incy + 1;
- }
- i__1 = *n;
- for (i__ = 1; i__ <= i__1; ++i__) {
- dsdot += (doublereal) sx[kx] * (doublereal) sy[ky];
- kx += *incx;
- ky += *incy;
-/* L10: */
- }
-L30:
- ret_val = dsdot;
- return ret_val;
-
-/* Code for equal and positive increments. */
-
-L40:
- ns = *n * *incx;
- i__1 = ns;
- i__2 = *incx;
- for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
- dsdot += (doublereal) sx[i__] * (doublereal) sy[i__];
-/* L50: */
- }
- ret_val = dsdot;
- return ret_val;
-} /* sdsdot_ */
-
-/* Subroutine */ int sgbmv_(char *trans, integer *m, integer *n, integer *kl,
- integer *ku, real *alpha, real *a, integer *lda, real *x, integer *
- incx, real *beta, real *y, integer *incy, ftnlen trans_len)
-{
- /* System generated locals */
- integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5, i__6;
-
- /* Local variables */
- static integer i__, j, k, ix, iy, jx, jy, kx, ky, kup1, info;
- static real temp;
- static integer lenx, leny;
- extern logical lsame_(char *, char *, ftnlen, ftnlen);
- extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen);
-
-/* .. Scalar Arguments .. */
-/* .. Array Arguments .. */
-/* .. */
-
-/* Purpose */
-/* ======= */
-
-/* SGBMV performs one of the matrix-vector operations */
-
-/* y := alpha*A*x + beta*y, or y := alpha*A'*x + beta*y, */
-
-/* where alpha and beta are scalars, x and y are vectors and A is an */
-/* m by n band matrix, with kl sub-diagonals and ku super-diagonals. */
-
-/* Parameters */
-/* ========== */
-
-/* TRANS - CHARACTER*1. */
-/* On entry, TRANS specifies the operation to be performed as */
-/* follows: */
-
-/* TRANS = 'N' or 'n' y := alpha*A*x + beta*y. */
-
-/* TRANS = 'T' or 't' y := alpha*A'*x + beta*y. */
-
-/* TRANS = 'C' or 'c' y := alpha*A'*x + beta*y. */
-
-/* Unchanged on exit. */
-
-/* M - INTEGER. */
-/* On entry, M specifies the number of rows of the matrix A. */
-/* M must be at least zero. */
-/* Unchanged on exit. */
-
-/* N - INTEGER. */
-/* On entry, N specifies the number of columns of the matrix A. */
-/* N must be at least zero. */
-/* Unchanged on exit. */
-
-/* KL - INTEGER. */
-/* On entry, KL specifies the number of sub-diagonals of the */
-/* matrix A. KL must satisfy 0 .le. KL. */
-/* Unchanged on exit. */
-
-/* KU - INTEGER. */
-/* On entry, KU specifies the number of super-diagonals of the */
-/* matrix A. KU must satisfy 0 .le. KU. */
-/* Unchanged on exit. */
-
-/* ALPHA - REAL . */
-/* On entry, ALPHA specifies the scalar alpha. */
-/* Unchanged on exit. */
-
-/* A - REAL array of DIMENSION ( LDA, n ). */
-/* Before entry, the leading ( kl + ku + 1 ) by n part of the */
-/* array A must contain the matrix of coefficients, supplied */
-/* column by column, with the leading diagonal of the matrix in */
-/* row ( ku + 1 ) of the array, the first super-diagonal */
-/* starting at position 2 in row ku, the first sub-diagonal */
-/* starting at position 1 in row ( ku + 2 ), and so on. */
-/* Elements in the array A that do not correspond to elements */
-/* in the band matrix (such as the top left ku by ku triangle) */
-/* are not referenced. */
-/* The following program segment will transfer a band matrix */
-/* from conventional full matrix storage to band storage: */
-
-/* DO 20, J = 1, N */
-/* K = KU + 1 - J */
-/* DO 10, I = MAX( 1, J - KU ), MIN( M, J + KL ) */
-/* A( K + I, J ) = matrix( I, J ) */
-/* 10 CONTINUE */
-/* 20 CONTINUE */
-
-/* Unchanged on exit. */
-
-/* LDA - INTEGER. */
-/* On entry, LDA specifies the first dimension of A as declared */
-/* in the calling (sub) program. LDA must be at least */
-/* ( kl + ku + 1 ). */
-/* Unchanged on exit. */
-
-/* X - REAL array of DIMENSION at least */
-/* ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n' */
-/* and at least */
-/* ( 1 + ( m - 1 )*abs( INCX ) ) otherwise. */
-/* Before entry, the incremented array X must contain the */
-/* vector x. */
-/* Unchanged on exit. */
-
-/* INCX - INTEGER. */
-/* On entry, INCX specifies the increment for the elements of */
-/* X. INCX must not be zero. */
-/* Unchanged on exit. */
-
-/* BETA - REAL . */
-/* On entry, BETA specifies the scalar beta. When BETA is */
-/* supplied as zero then Y need not be set on input. */
-/* Unchanged on exit. */
-
-/* Y - REAL array of DIMENSION at least */
-/* ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n' */
-/* and at least */
-/* ( 1 + ( n - 1 )*abs( INCY ) ) otherwise. */
-/* Before entry, the incremented array Y must contain the */
-/* vector y. On exit, Y is overwritten by the updated vector y. */
-
-/* INCY - INTEGER. */
-/* On entry, INCY specifies the increment for the elements of */
-/* Y. INCY must not be zero. */
-/* Unchanged on exit. */
-
-
-/* Level 2 Blas routine. */
-
-/* -- Written on 22-October-1986. */
-/* Jack Dongarra, Argonne National Lab. */
-/* Jeremy Du Croz, Nag Central Office. */
-/* Sven Hammarling, Nag Central Office. */
-/* Richard Hanson, Sandia National Labs. */
-
-/* .. Parameters .. */
-/* .. Local Scalars .. */
-/* .. External Functions .. */
-/* .. External Subroutines .. */
-/* .. Intrinsic Functions .. */
-/* .. */
-/* .. Executable Statements .. */
-
-/* Test the input parameters. */
-
- /* Parameter adjustments */
- a_dim1 = *lda;
- a_offset = 1 + a_dim1 * 1;
- a -= a_offset;
- --x;
- --y;
-
- /* Function Body */
- info = 0;
- if (! lsame_(trans, "N", (ftnlen)1, (ftnlen)1) && ! lsame_(trans, "T", (
- ftnlen)1, (ftnlen)1) && ! lsame_(trans, "C", (ftnlen)1, (ftnlen)1)
- ) {
- info = 1;
- } else if (*m < 0) {
- info = 2;
- } else if (*n < 0) {
- info = 3;
- } else if (*kl < 0) {
- info = 4;
- } else if (*ku < 0) {
- info = 5;
- } else if (*lda < *kl + *ku + 1) {
- info = 8;
- } else if (*incx == 0) {
- info = 10;
- } else if (*incy == 0) {
- info = 13;
- }
- if (info != 0) {
- xerbla_("SGBMV ", &info, (ftnlen)6);
- return 0;
- }
-
-/* Quick return if possible. */
-
- if (*m == 0 || *n == 0 || *alpha == 0.f && *beta == 1.f) {
- return 0;
- }
-
-/* Set LENX and LENY, the lengths of the vectors x and y, and set */
-/* up the start points in X and Y. */
-
- if (lsame_(trans, "N", (ftnlen)1, (ftnlen)1)) {
- lenx = *n;
- leny = *m;
- } else {
- lenx = *m;
- leny = *n;
- }
- if (*incx > 0) {
- kx = 1;
- } else {
- kx = 1 - (lenx - 1) * *incx;
- }
- if (*incy > 0) {
- ky = 1;
- } else {
- ky = 1 - (leny - 1) * *incy;
- }
-
-/* Start the operations. In this version the elements of A are */
-/* accessed sequentially with one pass through the band part of A. */
-
-/* First form y := beta*y. */
-
- if (*beta != 1.f) {
- if (*incy == 1) {
- if (*beta == 0.f) {
- i__1 = leny;
- for (i__ = 1; i__ <= i__1; ++i__) {
- y[i__] = 0.f;
-/* L10: */
- }
- } else {
- i__1 = leny;
- for (i__ = 1; i__ <= i__1; ++i__) {
- y[i__] = *beta * y[i__];
-/* L20: */
- }
- }
- } else {
- iy = ky;
- if (*beta == 0.f) {
- i__1 = leny;
- for (i__ = 1; i__ <= i__1; ++i__) {
- y[iy] = 0.f;
- iy += *incy;
-/* L30: */
- }
- } else {
- i__1 = leny;
- for (i__ = 1; i__ <= i__1; ++i__) {
- y[iy] = *beta * y[iy];
- iy += *incy;
-/* L40: */
- }
- }
- }
- }
- if (*alpha == 0.f) {
- return 0;
- }
- kup1 = *ku + 1;
- if (lsame_(trans, "N", (ftnlen)1, (ftnlen)1)) {
-
-/* Form y := alpha*A*x + y. */
-
- jx = kx;
- if (*incy == 1) {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- if (x[jx] != 0.f) {
- temp = *alpha * x[jx];
- k = kup1 - j;
-/* Computing MAX */
- i__2 = 1, i__3 = j - *ku;
-/* Computing MIN */
- i__5 = *m, i__6 = j + *kl;
- i__4 = min(i__5,i__6);
- for (i__ = max(i__2,i__3); i__ <= i__4; ++i__) {
- y[i__] += temp * a[k + i__ + j * a_dim1];
-/* L50: */
- }
- }
- jx += *incx;
-/* L60: */
- }
- } else {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- if (x[jx] != 0.f) {
- temp = *alpha * x[jx];
- iy = ky;
- k = kup1 - j;
-/* Computing MAX */
- i__4 = 1, i__2 = j - *ku;
-/* Computing MIN */
- i__5 = *m, i__6 = j + *kl;
- i__3 = min(i__5,i__6);
- for (i__ = max(i__4,i__2); i__ <= i__3; ++i__) {
- y[iy] += temp * a[k + i__ + j * a_dim1];
- iy += *incy;
-/* L70: */
- }
- }
- jx += *incx;
- if (j > *ku) {
- ky += *incy;
- }
-/* L80: */
- }
- }
- } else {
-
-/* Form y := alpha*A'*x + y. */
-
- jy = ky;
- if (*incx == 1) {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- temp = 0.f;
- k = kup1 - j;
-/* Computing MAX */
- i__3 = 1, i__4 = j - *ku;
-/* Computing MIN */
- i__5 = *m, i__6 = j + *kl;
- i__2 = min(i__5,i__6);
- for (i__ = max(i__3,i__4); i__ <= i__2; ++i__) {
- temp += a[k + i__ + j * a_dim1] * x[i__];
-/* L90: */
- }
- y[jy] += *alpha * temp;
- jy += *incy;
-/* L100: */
- }
- } else {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- temp = 0.f;
- ix = kx;
- k = kup1 - j;
-/* Computing MAX */
- i__2 = 1, i__3 = j - *ku;
-/* Computing MIN */
- i__5 = *m, i__6 = j + *kl;
- i__4 = min(i__5,i__6);
- for (i__ = max(i__2,i__3); i__ <= i__4; ++i__) {
- temp += a[k + i__ + j * a_dim1] * x[ix];
- ix += *incx;
-/* L110: */
- }
- y[jy] += *alpha * temp;
- jy += *incy;
- if (j > *ku) {
- kx += *incx;
- }
-/* L120: */
- }
- }
- }
-
- return 0;
-
-/* End of SGBMV . */
-
-} /* sgbmv_ */
-
-/* Subroutine */ int sgemm_(char *transa, char *transb, integer *m, integer *
- n, integer *k, real *alpha, real *a, integer *lda, real *b, integer *
- ldb, real *beta, real *c__, integer *ldc, ftnlen transa_len, ftnlen
- transb_len)
-{
- /* System generated locals */
- integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2,
- i__3;
-
- /* Local variables */
- static integer i__, j, l, info;
- static logical nota, notb;
- static real temp;
- static integer ncola;
- extern logical lsame_(char *, char *, ftnlen, ftnlen);
- static integer nrowa, nrowb;
- extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen);
-
-/* .. Scalar Arguments .. */
-/* .. Array Arguments .. */
-/* .. */
-
-/* Purpose */
-/* ======= */
-
-/* SGEMM performs one of the matrix-matrix operations */
-
-/* C := alpha*op( A )*op( B ) + beta*C, */
-
-/* where op( X ) is one of */
-
-/* op( X ) = X or op( X ) = X', */
-
-/* alpha and beta are scalars, and A, B and C are matrices, with op( A ) */
-/* an m by k matrix, op( B ) a k by n matrix and C an m by n matrix. */
-
-/* Parameters */
-/* ========== */
-
-/* TRANSA - CHARACTER*1. */
-/* On entry, TRANSA specifies the form of op( A ) to be used in */
-/* the matrix multiplication as follows: */
-
-/* TRANSA = 'N' or 'n', op( A ) = A. */
-
-/* TRANSA = 'T' or 't', op( A ) = A'. */
-
-/* TRANSA = 'C' or 'c', op( A ) = A'. */
-
-/* Unchanged on exit. */
-
-/* TRANSB - CHARACTER*1. */
-/* On entry, TRANSB specifies the form of op( B ) to be used in */
-/* the matrix multiplication as follows: */
-
-/* TRANSB = 'N' or 'n', op( B ) = B. */
-
-/* TRANSB = 'T' or 't', op( B ) = B'. */
-
-/* TRANSB = 'C' or 'c', op( B ) = B'. */
-
-/* Unchanged on exit. */
-
-/* M - INTEGER. */
-/* On entry, M specifies the number of rows of the matrix */
-/* op( A ) and of the matrix C. M must be at least zero. */
-/* Unchanged on exit. */
-
-/* N - INTEGER. */
-/* On entry, N specifies the number of columns of the matrix */
-/* op( B ) and the number of columns of the matrix C. N must be */
-/* at least zero. */
-/* Unchanged on exit. */
-
-/* K - INTEGER. */
-/* On entry, K specifies the number of columns of the matrix */
-/* op( A ) and the number of rows of the matrix op( B ). K must */
-/* be at least zero. */
-/* Unchanged on exit. */
-
-/* ALPHA - REAL . */
-/* On entry, ALPHA specifies the scalar alpha. */
-/* Unchanged on exit. */
-
-/* A - REAL array of DIMENSION ( LDA, ka ), where ka is */
-/* k when TRANSA = 'N' or 'n', and is m otherwise. */
-/* Before entry with TRANSA = 'N' or 'n', the leading m by k */
-/* part of the array A must contain the matrix A, otherwise */
-/* the leading k by m part of the array A must contain the */
-/* matrix A. */
-/* Unchanged on exit. */
-
-/* LDA - INTEGER. */
-/* On entry, LDA specifies the first dimension of A as declared */
-/* in the calling (sub) program. When TRANSA = 'N' or 'n' then */
-/* LDA must be at least max( 1, m ), otherwise LDA must be at */
-/* least max( 1, k ). */
-/* Unchanged on exit. */
-
-/* B - REAL array of DIMENSION ( LDB, kb ), where kb is */
-/* n when TRANSB = 'N' or 'n', and is k otherwise. */
-/* Before entry with TRANSB = 'N' or 'n', the leading k by n */
-/* part of the array B must contain the matrix B, otherwise */
-/* the leading n by k part of the array B must contain the */
-/* matrix B. */
-/* Unchanged on exit. */
-
-/* LDB - INTEGER. */
-/* On entry, LDB specifies the first dimension of B as declared */
-/* in the calling (sub) program. When TRANSB = 'N' or 'n' then */
-/* LDB must be at least max( 1, k ), otherwise LDB must be at */
-/* least max( 1, n ). */
-/* Unchanged on exit. */
-
-/* BETA - REAL . */
-/* On entry, BETA specifies the scalar beta. When BETA is */
-/* supplied as zero then C need not be set on input. */
-/* Unchanged on exit. */
-
-/* C - REAL array of DIMENSION ( LDC, n ). */
-/* Before entry, the leading m by n part of the array C must */
-/* contain the matrix C, except when beta is zero, in which */
-/* case C need not be set on entry. */
-/* On exit, the array C is overwritten by the m by n matrix */
-/* ( alpha*op( A )*op( B ) + beta*C ). */
-
-/* LDC - INTEGER. */
-/* On entry, LDC specifies the first dimension of C as declared */
-/* in the calling (sub) program. LDC must be at least */
-/* max( 1, m ). */
-/* Unchanged on exit. */
-
-
-/* Level 3 Blas routine. */
-
-/* -- Written on 8-February-1989. */
-/* Jack Dongarra, Argonne National Laboratory. */
-/* Iain Duff, AERE Harwell. */
-/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */
-/* Sven Hammarling, Numerical Algorithms Group Ltd. */
-
-
-/* .. External Functions .. */
-/* .. External Subroutines .. */
-/* .. Intrinsic Functions .. */
-/* .. Local Scalars .. */
-/* .. Parameters .. */
-/* .. */
-/* .. Executable Statements .. */
-
-/* Set NOTA and NOTB as true if A and B respectively are not */
-/* transposed and set NROWA, NCOLA and NROWB as the number of rows */
-/* and columns of A and the number of rows of B respectively. */
-
- /* Parameter adjustments */
- a_dim1 = *lda;
- a_offset = 1 + a_dim1 * 1;
- a -= a_offset;
- b_dim1 = *ldb;
- b_offset = 1 + b_dim1 * 1;
- b -= b_offset;
- c_dim1 = *ldc;
- c_offset = 1 + c_dim1 * 1;
- c__ -= c_offset;
-
- /* Function Body */
- nota = lsame_(transa, "N", (ftnlen)1, (ftnlen)1);
- notb = lsame_(transb, "N", (ftnlen)1, (ftnlen)1);
- if (nota) {
- nrowa = *m;
- ncola = *k;
- } else {
- nrowa = *k;
- ncola = *m;
- }
- if (notb) {
- nrowb = *k;
- } else {
- nrowb = *n;
- }
-
-/* Test the input parameters. */
-
- info = 0;
- if (! nota && ! lsame_(transa, "C", (ftnlen)1, (ftnlen)1) && ! lsame_(
- transa, "T", (ftnlen)1, (ftnlen)1)) {
- info = 1;
- } else if (! notb && ! lsame_(transb, "C", (ftnlen)1, (ftnlen)1) && !
- lsame_(transb, "T", (ftnlen)1, (ftnlen)1)) {
- info = 2;
- } else if (*m < 0) {
- info = 3;
- } else if (*n < 0) {
- info = 4;
- } else if (*k < 0) {
- info = 5;
- } else if (*lda < max(1,nrowa)) {
- info = 8;
- } else if (*ldb < max(1,nrowb)) {
- info = 10;
- } else if (*ldc < max(1,*m)) {
- info = 13;
- }
- if (info != 0) {
- xerbla_("SGEMM ", &info, (ftnlen)6);
- return 0;
- }
-
-/* Quick return if possible. */
-
- if (*m == 0 || *n == 0 || (*alpha == 0.f || *k == 0) && *beta == 1.f) {
- return 0;
- }
-
-/* And if alpha.eq.zero. */
-
- if (*alpha == 0.f) {
- if (*beta == 0.f) {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- i__2 = *m;
- for (i__ = 1; i__ <= i__2; ++i__) {
- c__[i__ + j * c_dim1] = 0.f;
-/* L10: */
- }
-/* L20: */
- }
- } else {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- i__2 = *m;
- for (i__ = 1; i__ <= i__2; ++i__) {
- c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1];
-/* L30: */
- }
-/* L40: */
- }
- }
- return 0;
- }
-
-/* Start the operations. */
-
- if (notb) {
- if (nota) {
-
-/* Form C := alpha*A*B + beta*C. */
-
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- if (*beta == 0.f) {
- i__2 = *m;
- for (i__ = 1; i__ <= i__2; ++i__) {
- c__[i__ + j * c_dim1] = 0.f;
-/* L50: */
- }
- } else if (*beta != 1.f) {
- i__2 = *m;
- for (i__ = 1; i__ <= i__2; ++i__) {
- c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1];
-/* L60: */
- }
- }
- i__2 = *k;
- for (l = 1; l <= i__2; ++l) {
- if (b[l + j * b_dim1] != 0.f) {
- temp = *alpha * b[l + j * b_dim1];
- i__3 = *m;
- for (i__ = 1; i__ <= i__3; ++i__) {
- c__[i__ + j * c_dim1] += temp * a[i__ + l *
- a_dim1];
-/* L70: */
- }
- }
-/* L80: */
- }
-/* L90: */
- }
- } else {
-
-/* Form C := alpha*A'*B + beta*C */
-
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- i__2 = *m;
- for (i__ = 1; i__ <= i__2; ++i__) {
- temp = 0.f;
- i__3 = *k;
- for (l = 1; l <= i__3; ++l) {
- temp += a[l + i__ * a_dim1] * b[l + j * b_dim1];
-/* L100: */
- }
- if (*beta == 0.f) {
- c__[i__ + j * c_dim1] = *alpha * temp;
- } else {
- c__[i__ + j * c_dim1] = *alpha * temp + *beta * c__[
- i__ + j * c_dim1];
- }
-/* L110: */
- }
-/* L120: */
- }
- }
- } else {
- if (nota) {
-
-/* Form C := alpha*A*B' + beta*C */
-
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- if (*beta == 0.f) {
- i__2 = *m;
- for (i__ = 1; i__ <= i__2; ++i__) {
- c__[i__ + j * c_dim1] = 0.f;
-/* L130: */
- }
- } else if (*beta != 1.f) {
- i__2 = *m;
- for (i__ = 1; i__ <= i__2; ++i__) {
- c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1];
-/* L140: */
- }
- }
- i__2 = *k;
- for (l = 1; l <= i__2; ++l) {
- if (b[j + l * b_dim1] != 0.f) {
- temp = *alpha * b[j + l * b_dim1];
- i__3 = *m;
- for (i__ = 1; i__ <= i__3; ++i__) {
- c__[i__ + j * c_dim1] += temp * a[i__ + l *
- a_dim1];
-/* L150: */
- }
- }
-/* L160: */
- }
-/* L170: */
- }
- } else {
-
-/* Form C := alpha*A'*B' + beta*C */
-
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- i__2 = *m;
- for (i__ = 1; i__ <= i__2; ++i__) {
- temp = 0.f;
- i__3 = *k;
- for (l = 1; l <= i__3; ++l) {
- temp += a[l + i__ * a_dim1] * b[j + l * b_dim1];
-/* L180: */
- }
- if (*beta == 0.f) {
- c__[i__ + j * c_dim1] = *alpha * temp;
- } else {
- c__[i__ + j * c_dim1] = *alpha * temp + *beta * c__[
- i__ + j * c_dim1];
- }
-/* L190: */
- }
-/* L200: */
- }
- }
- }
-
- return 0;
-
-/* End of SGEMM . */
-
-} /* sgemm_ */
-
-/* Subroutine */ int sgemv_(char *trans, integer *m, integer *n, real *alpha,
- real *a, integer *lda, real *x, integer *incx, real *beta, real *y,
- integer *incy, ftnlen trans_len)
-{
- /* System generated locals */
- integer a_dim1, a_offset, i__1, i__2;
-
- /* Local variables */
- static integer i__, j, ix, iy, jx, jy, kx, ky, info;
- static real temp;
- static integer lenx, leny;
- extern logical lsame_(char *, char *, ftnlen, ftnlen);
- extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen);
-
-/* .. Scalar Arguments .. */
-/* .. Array Arguments .. */
-/* .. */
-
-/* Purpose */
-/* ======= */
-
-/* SGEMV performs one of the matrix-vector operations */
-
-/* y := alpha*A*x + beta*y, or y := alpha*A'*x + beta*y, */
-
-/* where alpha and beta are scalars, x and y are vectors and A is an */
-/* m by n matrix. */
-
-/* Parameters */
-/* ========== */
-
-/* TRANS - CHARACTER*1. */
-/* On entry, TRANS specifies the operation to be performed as */
-/* follows: */
-
-/* TRANS = 'N' or 'n' y := alpha*A*x + beta*y. */
-
-/* TRANS = 'T' or 't' y := alpha*A'*x + beta*y. */
-
-/* TRANS = 'C' or 'c' y := alpha*A'*x + beta*y. */
-
-/* Unchanged on exit. */
-
-/* M - INTEGER. */
-/* On entry, M specifies the number of rows of the matrix A. */
-/* M must be at least zero. */
-/* Unchanged on exit. */
-
-/* N - INTEGER. */
-/* On entry, N specifies the number of columns of the matrix A. */
-/* N must be at least zero. */
-/* Unchanged on exit. */
-
-/* ALPHA - REAL . */
-/* On entry, ALPHA specifies the scalar alpha. */
-/* Unchanged on exit. */
-
-/* A - REAL array of DIMENSION ( LDA, n ). */
-/* Before entry, the leading m by n part of the array A must */
-/* contain the matrix of coefficients. */
-/* Unchanged on exit. */
-
-/* LDA - INTEGER. */
-/* On entry, LDA specifies the first dimension of A as declared */
-/* in the calling (sub) program. LDA must be at least */
-/* max( 1, m ). */
-/* Unchanged on exit. */
-
-/* X - REAL array of DIMENSION at least */
-/* ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n' */
-/* and at least */
-/* ( 1 + ( m - 1 )*abs( INCX ) ) otherwise. */
-/* Before entry, the incremented array X must contain the */
-/* vector x. */
-/* Unchanged on exit. */
-
-/* INCX - INTEGER. */
-/* On entry, INCX specifies the increment for the elements of */
-/* X. INCX must not be zero. */
-/* Unchanged on exit. */
-
-/* BETA - REAL . */
-/* On entry, BETA specifies the scalar beta. When BETA is */
-/* supplied as zero then Y need not be set on input. */
-/* Unchanged on exit. */
-
-/* Y - REAL array of DIMENSION at least */
-/* ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n' */
-/* and at least */
-/* ( 1 + ( n - 1 )*abs( INCY ) ) otherwise. */
-/* Before entry with BETA non-zero, the incremented array Y */
-/* must contain the vector y. On exit, Y is overwritten by the */
-/* updated vector y. */
-
-/* INCY - INTEGER. */
-/* On entry, INCY specifies the increment for the elements of */
-/* Y. INCY must not be zero. */
-/* Unchanged on exit. */
-
-
-/* Level 2 Blas routine. */
-
-/* -- Written on 22-October-1986. */
-/* Jack Dongarra, Argonne National Lab. */
-/* Jeremy Du Croz, Nag Central Office. */
-/* Sven Hammarling, Nag Central Office. */
-/* Richard Hanson, Sandia National Labs. */
-
-
-/* .. Parameters .. */
-/* .. Local Scalars .. */
-/* .. External Functions .. */
-/* .. External Subroutines .. */
-/* .. Intrinsic Functions .. */
-/* .. */
-/* .. Executable Statements .. */
-
-/* Test the input parameters. */
-
- /* Parameter adjustments */
- a_dim1 = *lda;
- a_offset = 1 + a_dim1 * 1;
- a -= a_offset;
- --x;
- --y;
-
- /* Function Body */
- info = 0;
- if (! lsame_(trans, "N", (ftnlen)1, (ftnlen)1) && ! lsame_(trans, "T", (
- ftnlen)1, (ftnlen)1) && ! lsame_(trans, "C", (ftnlen)1, (ftnlen)1)
- ) {
- info = 1;
- } else if (*m < 0) {
- info = 2;
- } else if (*n < 0) {
- info = 3;
- } else if (*lda < max(1,*m)) {
- info = 6;
- } else if (*incx == 0) {
- info = 8;
- } else if (*incy == 0) {
- info = 11;
- }
- if (info != 0) {
- xerbla_("SGEMV ", &info, (ftnlen)6);
- return 0;
- }
-
-/* Quick return if possible. */
-
- if (*m == 0 || *n == 0 || *alpha == 0.f && *beta == 1.f) {
- return 0;
- }
-
-/* Set LENX and LENY, the lengths of the vectors x and y, and set */
-/* up the start points in X and Y. */
-
- if (lsame_(trans, "N", (ftnlen)1, (ftnlen)1)) {
- lenx = *n;
- leny = *m;
- } else {
- lenx = *m;
- leny = *n;
- }
- if (*incx > 0) {
- kx = 1;
- } else {
- kx = 1 - (lenx - 1) * *incx;
- }
- if (*incy > 0) {
- ky = 1;
- } else {
- ky = 1 - (leny - 1) * *incy;
- }
-
-/* Start the operations. In this version the elements of A are */
-/* accessed sequentially with one pass through A. */
-
-/* First form y := beta*y. */
-
- if (*beta != 1.f) {
- if (*incy == 1) {
- if (*beta == 0.f) {
- i__1 = leny;
- for (i__ = 1; i__ <= i__1; ++i__) {
- y[i__] = 0.f;
-/* L10: */
- }
- } else {
- i__1 = leny;
- for (i__ = 1; i__ <= i__1; ++i__) {
- y[i__] = *beta * y[i__];
-/* L20: */
- }
- }
- } else {
- iy = ky;
- if (*beta == 0.f) {
- i__1 = leny;
- for (i__ = 1; i__ <= i__1; ++i__) {
- y[iy] = 0.f;
- iy += *incy;
-/* L30: */
- }
- } else {
- i__1 = leny;
- for (i__ = 1; i__ <= i__1; ++i__) {
- y[iy] = *beta * y[iy];
- iy += *incy;
-/* L40: */
- }
- }
- }
- }
- if (*alpha == 0.f) {
- return 0;
- }
- if (lsame_(trans, "N", (ftnlen)1, (ftnlen)1)) {
-
-/* Form y := alpha*A*x + y. */
-
- jx = kx;
- if (*incy == 1) {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- if (x[jx] != 0.f) {
- temp = *alpha * x[jx];
- i__2 = *m;
- for (i__ = 1; i__ <= i__2; ++i__) {
- y[i__] += temp * a[i__ + j * a_dim1];
-/* L50: */
- }
- }
- jx += *incx;
-/* L60: */
- }
- } else {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- if (x[jx] != 0.f) {
- temp = *alpha * x[jx];
- iy = ky;
- i__2 = *m;
- for (i__ = 1; i__ <= i__2; ++i__) {
- y[iy] += temp * a[i__ + j * a_dim1];
- iy += *incy;
-/* L70: */
- }
- }
- jx += *incx;
-/* L80: */
- }
- }
- } else {
-
-/* Form y := alpha*A'*x + y. */
-
- jy = ky;
- if (*incx == 1) {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- temp = 0.f;
- i__2 = *m;
- for (i__ = 1; i__ <= i__2; ++i__) {
- temp += a[i__ + j * a_dim1] * x[i__];
-/* L90: */
- }
- y[jy] += *alpha * temp;
- jy += *incy;
-/* L100: */
- }
- } else {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- temp = 0.f;
- ix = kx;
- i__2 = *m;
- for (i__ = 1; i__ <= i__2; ++i__) {
- temp += a[i__ + j * a_dim1] * x[ix];
- ix += *incx;
-/* L110: */
- }
- y[jy] += *alpha * temp;
- jy += *incy;
-/* L120: */
- }
- }
- }
-
- return 0;
-
-/* End of SGEMV . */
-
-} /* sgemv_ */
-
-/* Subroutine */ int sger_(integer *m, integer *n, real *alpha, real *x,
- integer *incx, real *y, integer *incy, real *a, integer *lda)
-{
- /* System generated locals */
- integer a_dim1, a_offset, i__1, i__2;
-
- /* Local variables */
- static integer i__, j, ix, jy, kx, info;
- static real temp;
- extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen);
-
-/* .. Scalar Arguments .. */
-/* .. Array Arguments .. */
-/* .. */
-
-/* Purpose */
-/* ======= */
-
-/* SGER performs the rank 1 operation */
-
-/* A := alpha*x*y' + A, */
-
-/* where alpha is a scalar, x is an m element vector, y is an n element */
-/* vector and A is an m by n matrix. */
-
-/* Parameters */
-/* ========== */
-
-/* M - INTEGER. */
-/* On entry, M specifies the number of rows of the matrix A. */
-/* M must be at least zero. */
-/* Unchanged on exit. */
-
-/* N - INTEGER. */
-/* On entry, N specifies the number of columns of the matrix A. */
-/* N must be at least zero. */
-/* Unchanged on exit. */
-
-/* ALPHA - REAL . */
-/* On entry, ALPHA specifies the scalar alpha. */
-/* Unchanged on exit. */
-
-/* X - REAL array of dimension at least */
-/* ( 1 + ( m - 1 )*abs( INCX ) ). */
-/* Before entry, the incremented array X must contain the m */
-/* element vector x. */
-/* Unchanged on exit. */
-
-/* INCX - INTEGER. */
-/* On entry, INCX specifies the increment for the elements of */
-/* X. INCX must not be zero. */
-/* Unchanged on exit. */
-
-/* Y - REAL array of dimension at least */
-/* ( 1 + ( n - 1 )*abs( INCY ) ). */
-/* Before entry, the incremented array Y must contain the n */
-/* element vector y. */
-/* Unchanged on exit. */
-
-/* INCY - INTEGER. */
-/* On entry, INCY specifies the increment for the elements of */
-/* Y. INCY must not be zero. */
-/* Unchanged on exit. */
-
-/* A - REAL array of DIMENSION ( LDA, n ). */
-/* Before entry, the leading m by n part of the array A must */
-/* contain the matrix of coefficients. On exit, A is */
-/* overwritten by the updated matrix. */
-
-/* LDA - INTEGER. */
-/* On entry, LDA specifies the first dimension of A as declared */
-/* in the calling (sub) program. LDA must be at least */
-/* max( 1, m ). */
-/* Unchanged on exit. */
-
-
-/* Level 2 Blas routine. */
-
-/* -- Written on 22-October-1986. */
-/* Jack Dongarra, Argonne National Lab. */
-/* Jeremy Du Croz, Nag Central Office. */
-/* Sven Hammarling, Nag Central Office. */
-/* Richard Hanson, Sandia National Labs. */
-
-
-/* .. Parameters .. */
-/* .. Local Scalars .. */
-/* .. External Subroutines .. */
-/* .. Intrinsic Functions .. */
-/* .. */
-/* .. Executable Statements .. */
-
-/* Test the input parameters. */
-
- /* Parameter adjustments */
- --x;
- --y;
- a_dim1 = *lda;
- a_offset = 1 + a_dim1 * 1;
- a -= a_offset;
-
- /* Function Body */
- info = 0;
- if (*m < 0) {
- info = 1;
- } else if (*n < 0) {
- info = 2;
- } else if (*incx == 0) {
- info = 5;
- } else if (*incy == 0) {
- info = 7;
- } else if (*lda < max(1,*m)) {
- info = 9;
- }
- if (info != 0) {
- xerbla_("SGER ", &info, (ftnlen)6);
- return 0;
- }
-
-/* Quick return if possible. */
-
- if (*m == 0 || *n == 0 || *alpha == 0.f) {
- return 0;
- }
-
-/* Start the operations. In this version the elements of A are */
-/* accessed sequentially with one pass through A. */
-
- if (*incy > 0) {
- jy = 1;
- } else {
- jy = 1 - (*n - 1) * *incy;
- }
- if (*incx == 1) {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- if (y[jy] != 0.f) {
- temp = *alpha * y[jy];
- i__2 = *m;
- for (i__ = 1; i__ <= i__2; ++i__) {
- a[i__ + j * a_dim1] += x[i__] * temp;
-/* L10: */
- }
- }
- jy += *incy;
-/* L20: */
- }
- } else {
- if (*incx > 0) {
- kx = 1;
- } else {
- kx = 1 - (*m - 1) * *incx;
- }
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- if (y[jy] != 0.f) {
- temp = *alpha * y[jy];
- ix = kx;
- i__2 = *m;
- for (i__ = 1; i__ <= i__2; ++i__) {
- a[i__ + j * a_dim1] += x[ix] * temp;
- ix += *incx;
-/* L30: */
- }
- }
- jy += *incy;
-/* L40: */
- }
- }
-
- return 0;
-
-/* End of SGER . */
-
-} /* sger_ */
-
-doublereal snrm2_(integer *n, real *x, integer *incx)
-{
- /* System generated locals */
- integer i__1, i__2;
- real ret_val, r__1;
-
- /* Builtin functions */
- double sqrt(doublereal);
-
- /* Local variables */
- static integer ix;
- static real ssq, norm, scale, absxi;
-
-/* .. Scalar Arguments .. */
-/* .. Array Arguments .. */
-/* .. */
-
-/* SNRM2 returns the euclidean norm of a vector via the function */
-/* name, so that */
-
-/* SNRM2 := sqrt( x'*x ) */
-
-
-
-/* -- This version written on 25-October-1982. */
-/* Modified on 14-October-1993 to inline the call to SLASSQ. */
-/* Sven Hammarling, Nag Ltd. */
-
-
-/* .. Parameters .. */
-/* .. Local Scalars .. */
-/* .. Intrinsic Functions .. */
-/* .. */
-/* .. Executable Statements .. */
- /* Parameter adjustments */
- --x;
-
- /* Function Body */
- if (*n < 1 || *incx < 1) {
- norm = 0.f;
- } else if (*n == 1) {
- norm = dabs(x[1]);
- } else {
- scale = 0.f;
- ssq = 1.f;
-/* The following loop is equivalent to this call to the LAPACK */
-/* auxiliary routine: */
-/* CALL SLASSQ( N, X, INCX, SCALE, SSQ ) */
-
- i__1 = (*n - 1) * *incx + 1;
- i__2 = *incx;
- for (ix = 1; i__2 < 0 ? ix >= i__1 : ix <= i__1; ix += i__2) {
- if (x[ix] != 0.f) {
- absxi = (r__1 = x[ix], dabs(r__1));
- if (scale < absxi) {
-/* Computing 2nd power */
- r__1 = scale / absxi;
- ssq = ssq * (r__1 * r__1) + 1.f;
- scale = absxi;
- } else {
-/* Computing 2nd power */
- r__1 = absxi / scale;
- ssq += r__1 * r__1;
- }
- }
-/* L10: */
- }
- norm = scale * sqrt(ssq);
- }
-
- ret_val = norm;
- return ret_val;
-
-/* End of SNRM2. */
-
-} /* snrm2_ */
-
-/* Subroutine */ int srot_(integer *n, real *sx, integer *incx, real *sy,
- integer *incy, real *c__, real *s)
-{
- /* System generated locals */
- integer i__1;
-
- /* Local variables */
- static integer i__, ix, iy;
- static real stemp;
-
-
-/* applies a plane rotation. */
-/* jack dongarra, linpack, 3/11/78. */
-/* modified 12/3/93, array(1) declarations changed to array(*) */
-
-
- /* Parameter adjustments */
- --sy;
- --sx;
-
- /* Function Body */
- if (*n <= 0) {
- return 0;
- }
- if (*incx == 1 && *incy == 1) {
- goto L20;
- }
-
-/* code for unequal increments or equal increments not equal */
-/* to 1 */
-
- ix = 1;
- iy = 1;
- if (*incx < 0) {
- ix = (-(*n) + 1) * *incx + 1;
- }
- if (*incy < 0) {
- iy = (-(*n) + 1) * *incy + 1;
- }
- i__1 = *n;
- for (i__ = 1; i__ <= i__1; ++i__) {
- stemp = *c__ * sx[ix] + *s * sy[iy];
- sy[iy] = *c__ * sy[iy] - *s * sx[ix];
- sx[ix] = stemp;
- ix += *incx;
- iy += *incy;
-/* L10: */
- }
- return 0;
-
-/* code for both increments equal to 1 */
-
-L20:
- i__1 = *n;
- for (i__ = 1; i__ <= i__1; ++i__) {
- stemp = *c__ * sx[i__] + *s * sy[i__];
- sy[i__] = *c__ * sy[i__] - *s * sx[i__];
- sx[i__] = stemp;
-/* L30: */
- }
- return 0;
-} /* srot_ */
-
-double r_sign(real *a, real *b)
- {
- double x;
- x = (*a >= 0 ? *a : - *a);
- return( *b >= 0 ? x : -x);
- }
-
-/* Subroutine */ int srotg_(real *sa, real *sb, real *c__, real *s)
-{
- /* System generated locals */
- real r__1, r__2;
-
- /* Builtin functions */
- double sqrt(doublereal), r_sign(real *, real *);
-
- /* Local variables */
- static real r__, z__, roe, scale;
-
-
-/* construct givens plane rotation. */
-/* jack dongarra, linpack, 3/11/78. */
-
-
- roe = *sb;
- if (dabs(*sa) > dabs(*sb)) {
- roe = *sa;
- }
- scale = dabs(*sa) + dabs(*sb);
- if (scale != 0.f) {
- goto L10;
- }
- *c__ = 1.f;
- *s = 0.f;
- r__ = 0.f;
- z__ = 0.f;
- goto L20;
-L10:
-/* Computing 2nd power */
- r__1 = *sa / scale;
-/* Computing 2nd power */
- r__2 = *sb / scale;
- r__ = scale * sqrt(r__1 * r__1 + r__2 * r__2);
- r__ = r_sign(&c_b1543, &roe) * r__;
- *c__ = *sa / r__;
- *s = *sb / r__;
- z__ = 1.f;
- if (dabs(*sa) > dabs(*sb)) {
- z__ = *s;
- }
- if (dabs(*sb) >= dabs(*sa) && *c__ != 0.f) {
- z__ = 1.f / *c__;
- }
-L20:
- *sa = r__;
- *sb = z__;
- return 0;
-} /* srotg_ */
-
-/* Subroutine */ int srotm_(integer *n, real *sx, integer *incx, real *sy,
- integer *incy, real *sparam)
-{
- /* Initialized data */
-
- static real zero = 0.f;
- static real two = 2.f;
-
- /* System generated locals */
- integer i__1, i__2;
-
- /* Local variables */
- static integer i__;
- static real w, z__;
- static integer kx, ky;
- static real sh11, sh12, sh21, sh22, sflag;
- static integer nsteps;
-
-
-/* APPLY THE MODIFIED GIVENS TRANSFORMATION, H, TO THE 2 BY N MATRIX */
-
-/* (SX**T) , WHERE **T INDICATES TRANSPOSE. THE ELEMENTS OF SX ARE IN */
-/* (DX**T) */
-
-/* SX(LX+I*INCX), I = 0 TO N-1, WHERE LX = 1 IF INCX .GE. 0, ELSE */
-/* LX = (-INCX)*N, AND SIMILARLY FOR SY USING USING LY AND INCY. */
-/* WITH SPARAM(1)=SFLAG, H HAS ONE OF THE FOLLOWING FORMS.. */
-
-/* SFLAG=-1.E0 SFLAG=0.E0 SFLAG=1.E0 SFLAG=-2.E0 */
-
-/* (SH11 SH12) (1.E0 SH12) (SH11 1.E0) (1.E0 0.E0) */
-/* H=( ) ( ) ( ) ( ) */
-/* (SH21 SH22), (SH21 1.E0), (-1.E0 SH22), (0.E0 1.E0). */
-/* SEE SROTMG FOR A DESCRIPTION OF DATA STORAGE IN SPARAM. */
-
- /* Parameter adjustments */
- --sparam;
- --sy;
- --sx;
-
- /* Function Body */
-
- sflag = sparam[1];
- if (*n <= 0 || sflag + two == zero) {
- goto L140;
- }
- if (! (*incx == *incy && *incx > 0)) {
- goto L70;
- }
-
- nsteps = *n * *incx;
- if (sflag < 0.f) {
- goto L50;
- } else if (sflag == 0) {
- goto L10;
- } else {
- goto L30;
- }
-L10:
- sh12 = sparam[4];
- sh21 = sparam[3];
- i__1 = nsteps;
- i__2 = *incx;
- for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
- w = sx[i__];
- z__ = sy[i__];
- sx[i__] = w + z__ * sh12;
- sy[i__] = w * sh21 + z__;
-/* L20: */
- }
- goto L140;
-L30:
- sh11 = sparam[2];
- sh22 = sparam[5];
- i__2 = nsteps;
- i__1 = *incx;
- for (i__ = 1; i__1 < 0 ? i__ >= i__2 : i__ <= i__2; i__ += i__1) {
- w = sx[i__];
- z__ = sy[i__];
- sx[i__] = w * sh11 + z__;
- sy[i__] = -w + sh22 * z__;
-/* L40: */
- }
- goto L140;
-L50:
- sh11 = sparam[2];
- sh12 = sparam[4];
- sh21 = sparam[3];
- sh22 = sparam[5];
- i__1 = nsteps;
- i__2 = *incx;
- for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
- w = sx[i__];
- z__ = sy[i__];
- sx[i__] = w * sh11 + z__ * sh12;
- sy[i__] = w * sh21 + z__ * sh22;
-/* L60: */
- }
- goto L140;
-L70:
- kx = 1;
- ky = 1;
- if (*incx < 0) {
- kx = (1 - *n) * *incx + 1;
- }
- if (*incy < 0) {
- ky = (1 - *n) * *incy + 1;
- }
-
- if (sflag < 0.f) {
- goto L120;
- } else if (sflag == 0) {
- goto L80;
- } else {
- goto L100;
- }
-L80:
- sh12 = sparam[4];
- sh21 = sparam[3];
- i__2 = *n;
- for (i__ = 1; i__ <= i__2; ++i__) {
- w = sx[kx];
- z__ = sy[ky];
- sx[kx] = w + z__ * sh12;
- sy[ky] = w * sh21 + z__;
- kx += *incx;
- ky += *incy;
-/* L90: */
- }
- goto L140;
-L100:
- sh11 = sparam[2];
- sh22 = sparam[5];
- i__2 = *n;
- for (i__ = 1; i__ <= i__2; ++i__) {
- w = sx[kx];
- z__ = sy[ky];
- sx[kx] = w * sh11 + z__;
- sy[ky] = -w + sh22 * z__;
- kx += *incx;
- ky += *incy;
-/* L110: */
- }
- goto L140;
-L120:
- sh11 = sparam[2];
- sh12 = sparam[4];
- sh21 = sparam[3];
- sh22 = sparam[5];
- i__2 = *n;
- for (i__ = 1; i__ <= i__2; ++i__) {
- w = sx[kx];
- z__ = sy[ky];
- sx[kx] = w * sh11 + z__ * sh12;
- sy[ky] = w * sh21 + z__ * sh22;
- kx += *incx;
- ky += *incy;
-/* L130: */
- }
-L140:
- return 0;
-} /* srotm_ */
-
-/* Subroutine */ int srotmg_(real *sd1, real *sd2, real *sx1, real *sy1, real
- *sparam)
-{
- /* Initialized data */
-
- static real zero = 0.f;
- static real one = 1.f;
- static real two = 2.f;
- static real gam = 4096.f;
- static real gamsq = 16777200.f;
- static real rgamsq = 5.96046e-8f;
-
- /* Format strings */
- static char fmt_120[] = "";
- static char fmt_150[] = "";
- static char fmt_180[] = "";
- static char fmt_210[] = "";
-
- /* System generated locals */
- real r__1;
-
- /* Local variables */
- static real su, sp1, sp2, sq2, sq1, sh11, sh21, sh12, sh22;
- static integer igo;
- static real sflag, stemp;
-
- /* Assigned format variables */
- static char *igo_fmt;
-
-
-/* CONSTRUCT THE MODIFIED GIVENS TRANSFORMATION MATRIX H WHICH ZEROS */
-/* THE SECOND COMPONENT OF THE 2-VECTOR (SQRT(SD1)*SX1,SQRT(SD2)* */
-/* SY2)**T. */
-/* WITH SPARAM(1)=SFLAG, H HAS ONE OF THE FOLLOWING FORMS.. */
-
-/* SFLAG=-1.E0 SFLAG=0.E0 SFLAG=1.E0 SFLAG=-2.E0 */
-
-/* (SH11 SH12) (1.E0 SH12) (SH11 1.E0) (1.E0 0.E0) */
-/* H=( ) ( ) ( ) ( ) */
-/* (SH21 SH22), (SH21 1.E0), (-1.E0 SH22), (0.E0 1.E0). */
-/* LOCATIONS 2-4 OF SPARAM CONTAIN SH11,SH21,SH12, AND SH22 */
-/* RESPECTIVELY. (VALUES OF 1.E0, -1.E0, OR 0.E0 IMPLIED BY THE */
-/* VALUE OF SPARAM(1) ARE NOT STORED IN SPARAM.) */
-
-/* THE VALUES OF GAMSQ AND RGAMSQ SET IN THE DATA STATEMENT MAY BE */
-/* INEXACT. THIS IS OK AS THEY ARE ONLY USED FOR TESTING THE SIZE */
-/* OF SD1 AND SD2. ALL ACTUAL SCALING OF DATA IS DONE USING GAM. */
-
-
- /* Parameter adjustments */
- --sparam;
-
- /* Function Body */
- if (! (*sd1 < zero)) {
- goto L10;
- }
-/* GO ZERO-H-D-AND-SX1.. */
- goto L60;
-L10:
-/* CASE-SD1-NONNEGATIVE */
- sp2 = *sd2 * *sy1;
- if (! (sp2 == zero)) {
- goto L20;
- }
- sflag = -two;
- goto L260;
-/* REGULAR-CASE.. */
-L20:
- sp1 = *sd1 * *sx1;
- sq2 = sp2 * *sy1;
- sq1 = sp1 * *sx1;
-
- if (! (dabs(sq1) > dabs(sq2))) {
- goto L40;
- }
- sh21 = -(*sy1) / *sx1;
- sh12 = sp2 / sp1;
-
- su = one - sh12 * sh21;
-
- if (! (su <= zero)) {
- goto L30;
- }
-/* GO ZERO-H-D-AND-SX1.. */
- goto L60;
-L30:
- sflag = zero;
- *sd1 /= su;
- *sd2 /= su;
- *sx1 *= su;
-/* GO SCALE-CHECK.. */
- goto L100;
-L40:
- if (! (sq2 < zero)) {
- goto L50;
- }
-/* GO ZERO-H-D-AND-SX1.. */
- goto L60;
-L50:
- sflag = one;
- sh11 = sp1 / sp2;
- sh22 = *sx1 / *sy1;
- su = one + sh11 * sh22;
- stemp = *sd2 / su;
- *sd2 = *sd1 / su;
- *sd1 = stemp;
- *sx1 = *sy1 * su;
-/* GO SCALE-CHECK */
- goto L100;
-/* PROCEDURE..ZERO-H-D-AND-SX1.. */
-L60:
- sflag = -one;
- sh11 = zero;
- sh12 = zero;
- sh21 = zero;
- sh22 = zero;
-
- *sd1 = zero;
- *sd2 = zero;
- *sx1 = zero;
-/* RETURN.. */
- goto L220;
-/* PROCEDURE..FIX-H.. */
-L70:
- if (! (sflag >= zero)) {
- goto L90;
- }
-
- if (! (sflag == zero)) {
- goto L80;
- }
- sh11 = one;
- sh22 = one;
- sflag = -one;
- goto L90;
-L80:
- sh21 = -one;
- sh12 = one;
- sflag = -one;
-L90:
- switch (igo) {
- case 0: goto L120;
- case 1: goto L150;
- case 2: goto L180;
- case 3: goto L210;
- }
-/* PROCEDURE..SCALE-CHECK */
-L100:
-L110:
- if (! (*sd1 <= rgamsq)) {
- goto L130;
- }
- if (*sd1 == zero) {
- goto L160;
- }
- igo = 0;
- igo_fmt = fmt_120;
-/* FIX-H.. */
- goto L70;
-L120:
-/* Computing 2nd power */
- r__1 = gam;
- *sd1 *= r__1 * r__1;
- *sx1 /= gam;
- sh11 /= gam;
- sh12 /= gam;
- goto L110;
-L130:
-L140:
- if (! (*sd1 >= gamsq)) {
- goto L160;
- }
- igo = 1;
- igo_fmt = fmt_150;
-/* FIX-H.. */
- goto L70;
-L150:
-/* Computing 2nd power */
- r__1 = gam;
- *sd1 /= r__1 * r__1;
- *sx1 *= gam;
- sh11 *= gam;
- sh12 *= gam;
- goto L140;
-L160:
-L170:
- if (! (dabs(*sd2) <= rgamsq)) {
- goto L190;
- }
- if (*sd2 == zero) {
- goto L220;
- }
- igo = 2;
- igo_fmt = fmt_180;
-/* FIX-H.. */
- goto L70;
-L180:
-/* Computing 2nd power */
- r__1 = gam;
- *sd2 *= r__1 * r__1;
- sh21 /= gam;
- sh22 /= gam;
- goto L170;
-L190:
-L200:
- if (! (dabs(*sd2) >= gamsq)) {
- goto L220;
- }
- igo = 3;
- igo_fmt = fmt_210;
-/* FIX-H.. */
- goto L70;
-L210:
-/* Computing 2nd power */
- r__1 = gam;
- *sd2 /= r__1 * r__1;
- sh21 *= gam;
- sh22 *= gam;
- goto L200;
-L220:
- if (sflag < 0.f) {
- goto L250;
- } else if (sflag == 0) {
- goto L230;
- } else {
- goto L240;
- }
-L230:
- sparam[3] = sh21;
- sparam[4] = sh12;
- goto L260;
-L240:
- sparam[2] = sh11;
- sparam[5] = sh22;
- goto L260;
-L250:
- sparam[2] = sh11;
- sparam[3] = sh21;
- sparam[4] = sh12;
- sparam[5] = sh22;
-L260:
- sparam[1] = sflag;
- return 0;
-} /* srotmg_ */
-
-/* Subroutine */ int ssbmv_(char *uplo, integer *n, integer *k, real *alpha,
- real *a, integer *lda, real *x, integer *incx, real *beta, real *y,
- integer *incy, ftnlen uplo_len)
-{
- /* System generated locals */
- integer a_dim1, a_offset, i__1, i__2, i__3, i__4;
-
- /* Local variables */
- static integer i__, j, l, ix, iy, jx, jy, kx, ky, info;
- static real temp1, temp2;
- extern logical lsame_(char *, char *, ftnlen, ftnlen);
- static integer kplus1;
- extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen);
-
-/* .. Scalar Arguments .. */
-/* .. Array Arguments .. */
-/* .. */
-
-/* Purpose */
-/* ======= */
-
-/* SSBMV performs the matrix-vector operation */
-
-/* y := alpha*A*x + beta*y, */
-
-/* where alpha and beta are scalars, x and y are n element vectors and */
-/* A is an n by n symmetric band matrix, with k super-diagonals. */
-
-/* Parameters */
-/* ========== */
-
-/* UPLO - CHARACTER*1. */
-/* On entry, UPLO specifies whether the upper or lower */
-/* triangular part of the band matrix A is being supplied as */
-/* follows: */
-
-/* UPLO = 'U' or 'u' The upper triangular part of A is */
-/* being supplied. */
-
-/* UPLO = 'L' or 'l' The lower triangular part of A is */
-/* being supplied. */
-
-/* Unchanged on exit. */
-
-/* N - INTEGER. */
-/* On entry, N specifies the order of the matrix A. */
-/* N must be at least zero. */
-/* Unchanged on exit. */
-
-/* K - INTEGER. */
-/* On entry, K specifies the number of super-diagonals of the */
-/* matrix A. K must satisfy 0 .le. K. */
-/* Unchanged on exit. */
-
-/* ALPHA - REAL . */
-/* On entry, ALPHA specifies the scalar alpha. */
-/* Unchanged on exit. */
-
-/* A - REAL array of DIMENSION ( LDA, n ). */
-/* Before entry with UPLO = 'U' or 'u', the leading ( k + 1 ) */
-/* by n part of the array A must contain the upper triangular */
-/* band part of the symmetric matrix, supplied column by */
-/* column, with the leading diagonal of the matrix in row */
-/* ( k + 1 ) of the array, the first super-diagonal starting at */
-/* position 2 in row k, and so on. The top left k by k triangle */
-/* of the array A is not referenced. */
-/* The following program segment will transfer the upper */
-/* triangular part of a symmetric band matrix from conventional */
-/* full matrix storage to band storage: */
-
-/* DO 20, J = 1, N */
-/* M = K + 1 - J */
-/* DO 10, I = MAX( 1, J - K ), J */
-/* A( M + I, J ) = matrix( I, J ) */
-/* 10 CONTINUE */
-/* 20 CONTINUE */
-
-/* Before entry with UPLO = 'L' or 'l', the leading ( k + 1 ) */
-/* by n part of the array A must contain the lower triangular */
-/* band part of the symmetric matrix, supplied column by */
-/* column, with the leading diagonal of the matrix in row 1 of */
-/* the array, the first sub-diagonal starting at position 1 in */
-/* row 2, and so on. The bottom right k by k triangle of the */
-/* array A is not referenced. */
-/* The following program segment will transfer the lower */
-/* triangular part of a symmetric band matrix from conventional */
-/* full matrix storage to band storage: */
-
-/* DO 20, J = 1, N */
-/* M = 1 - J */
-/* DO 10, I = J, MIN( N, J + K ) */
-/* A( M + I, J ) = matrix( I, J ) */
-/* 10 CONTINUE */
-/* 20 CONTINUE */
-
-/* Unchanged on exit. */
-
-/* LDA - INTEGER. */
-/* On entry, LDA specifies the first dimension of A as declared */
-/* in the calling (sub) program. LDA must be at least */
-/* ( k + 1 ). */
-/* Unchanged on exit. */
-
-/* X - REAL array of DIMENSION at least */
-/* ( 1 + ( n - 1 )*abs( INCX ) ). */
-/* Before entry, the incremented array X must contain the */
-/* vector x. */
-/* Unchanged on exit. */
-
-/* INCX - INTEGER. */
-/* On entry, INCX specifies the increment for the elements of */
-/* X. INCX must not be zero. */
-/* Unchanged on exit. */
-
-/* BETA - REAL . */
-/* On entry, BETA specifies the scalar beta. */
-/* Unchanged on exit. */
-
-/* Y - REAL array of DIMENSION at least */
-/* ( 1 + ( n - 1 )*abs( INCY ) ). */
-/* Before entry, the incremented array Y must contain the */
-/* vector y. On exit, Y is overwritten by the updated vector y. */
-
-/* INCY - INTEGER. */
-/* On entry, INCY specifies the increment for the elements of */
-/* Y. INCY must not be zero. */
-/* Unchanged on exit. */
-
-
-/* Level 2 Blas routine. */
-
-/* -- Written on 22-October-1986. */
-/* Jack Dongarra, Argonne National Lab. */
-/* Jeremy Du Croz, Nag Central Office. */
-/* Sven Hammarling, Nag Central Office. */
-/* Richard Hanson, Sandia National Labs. */
-
-
-/* .. Parameters .. */
-/* .. Local Scalars .. */
-/* .. External Functions .. */
-/* .. External Subroutines .. */
-/* .. Intrinsic Functions .. */
-/* .. */
-/* .. Executable Statements .. */
-
-/* Test the input parameters. */
-
- /* Parameter adjustments */
- a_dim1 = *lda;
- a_offset = 1 + a_dim1 * 1;
- a -= a_offset;
- --x;
- --y;
-
- /* Function Body */
- info = 0;
- if (! lsame_(uplo, "U", (ftnlen)1, (ftnlen)1) && ! lsame_(uplo, "L", (
- ftnlen)1, (ftnlen)1)) {
- info = 1;
- } else if (*n < 0) {
- info = 2;
- } else if (*k < 0) {
- info = 3;
- } else if (*lda < *k + 1) {
- info = 6;
- } else if (*incx == 0) {
- info = 8;
- } else if (*incy == 0) {
- info = 11;
- }
- if (info != 0) {
- xerbla_("SSBMV ", &info, (ftnlen)6);
- return 0;
- }
-
-/* Quick return if possible. */
-
- if (*n == 0 || *alpha == 0.f && *beta == 1.f) {
- return 0;
- }
-
-/* Set up the start points in X and Y. */
-
- if (*incx > 0) {
- kx = 1;
- } else {
- kx = 1 - (*n - 1) * *incx;
- }
- if (*incy > 0) {
- ky = 1;
- } else {
- ky = 1 - (*n - 1) * *incy;
- }
-
-/* Start the operations. In this version the elements of the array A */
-/* are accessed sequentially with one pass through A. */
-
-/* First form y := beta*y. */
-
- if (*beta != 1.f) {
- if (*incy == 1) {
- if (*beta == 0.f) {
- i__1 = *n;
- for (i__ = 1; i__ <= i__1; ++i__) {
- y[i__] = 0.f;
-/* L10: */
- }
- } else {
- i__1 = *n;
- for (i__ = 1; i__ <= i__1; ++i__) {
- y[i__] = *beta * y[i__];
-/* L20: */
- }
- }
- } else {
- iy = ky;
- if (*beta == 0.f) {
- i__1 = *n;
- for (i__ = 1; i__ <= i__1; ++i__) {
- y[iy] = 0.f;
- iy += *incy;
-/* L30: */
- }
- } else {
- i__1 = *n;
- for (i__ = 1; i__ <= i__1; ++i__) {
- y[iy] = *beta * y[iy];
- iy += *incy;
-/* L40: */
- }
- }
- }
- }
- if (*alpha == 0.f) {
- return 0;
- }
- if (lsame_(uplo, "U", (ftnlen)1, (ftnlen)1)) {
-
-/* Form y when upper triangle of A is stored. */
-
- kplus1 = *k + 1;
- if (*incx == 1 && *incy == 1) {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- temp1 = *alpha * x[j];
- temp2 = 0.f;
- l = kplus1 - j;
-/* Computing MAX */
- i__2 = 1, i__3 = j - *k;
- i__4 = j - 1;
- for (i__ = max(i__2,i__3); i__ <= i__4; ++i__) {
- y[i__] += temp1 * a[l + i__ + j * a_dim1];
- temp2 += a[l + i__ + j * a_dim1] * x[i__];
-/* L50: */
- }
- y[j] = y[j] + temp1 * a[kplus1 + j * a_dim1] + *alpha * temp2;
-/* L60: */
- }
- } else {
- jx = kx;
- jy = ky;
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- temp1 = *alpha * x[jx];
- temp2 = 0.f;
- ix = kx;
- iy = ky;
- l = kplus1 - j;
-/* Computing MAX */
- i__4 = 1, i__2 = j - *k;
- i__3 = j - 1;
- for (i__ = max(i__4,i__2); i__ <= i__3; ++i__) {
- y[iy] += temp1 * a[l + i__ + j * a_dim1];
- temp2 += a[l + i__ + j * a_dim1] * x[ix];
- ix += *incx;
- iy += *incy;
-/* L70: */
- }
- y[jy] = y[jy] + temp1 * a[kplus1 + j * a_dim1] + *alpha *
- temp2;
- jx += *incx;
- jy += *incy;
- if (j > *k) {
- kx += *incx;
- ky += *incy;
- }
-/* L80: */
- }
- }
- } else {
-
-/* Form y when lower triangle of A is stored. */
-
- if (*incx == 1 && *incy == 1) {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- temp1 = *alpha * x[j];
- temp2 = 0.f;
- y[j] += temp1 * a[j * a_dim1 + 1];
- l = 1 - j;
-/* Computing MIN */
- i__4 = *n, i__2 = j + *k;
- i__3 = min(i__4,i__2);
- for (i__ = j + 1; i__ <= i__3; ++i__) {
- y[i__] += temp1 * a[l + i__ + j * a_dim1];
- temp2 += a[l + i__ + j * a_dim1] * x[i__];
-/* L90: */
- }
- y[j] += *alpha * temp2;
-/* L100: */
- }
- } else {
- jx = kx;
- jy = ky;
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- temp1 = *alpha * x[jx];
- temp2 = 0.f;
- y[jy] += temp1 * a[j * a_dim1 + 1];
- l = 1 - j;
- ix = jx;
- iy = jy;
-/* Computing MIN */
- i__4 = *n, i__2 = j + *k;
- i__3 = min(i__4,i__2);
- for (i__ = j + 1; i__ <= i__3; ++i__) {
- ix += *incx;
- iy += *incy;
- y[iy] += temp1 * a[l + i__ + j * a_dim1];
- temp2 += a[l + i__ + j * a_dim1] * x[ix];
-/* L110: */
- }
- y[jy] += *alpha * temp2;
- jx += *incx;
- jy += *incy;
-/* L120: */
- }
- }
- }
-
- return 0;
-
-/* End of SSBMV . */
-
-} /* ssbmv_ */
-
-/* Subroutine */ int sscal_(integer *n, real *sa, real *sx, integer *incx)
-{
- /* System generated locals */
- integer i__1, i__2;
-
- /* Local variables */
- static integer i__, m, mp1, nincx;
-
-
-/* scales a vector by a constant. */
-/* uses unrolled loops for increment equal to 1. */
-/* jack dongarra, linpack, 3/11/78. */
-/* modified 3/93 to return if incx .le. 0. */
-/* modified 12/3/93, array(1) declarations changed to array(*) */
-
-
- /* Parameter adjustments */
- --sx;
-
- /* Function Body */
- if (*n <= 0 || *incx <= 0) {
- return 0;
- }
- if (*incx == 1) {
- goto L20;
- }
-
-/* code for increment not equal to 1 */
-
- nincx = *n * *incx;
- i__1 = nincx;
- i__2 = *incx;
- for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
- sx[i__] = *sa * sx[i__];
-/* L10: */
- }
- return 0;
-
-/* code for increment equal to 1 */
-
-
-/* clean-up loop */
-
-L20:
- m = *n % 5;
- if (m == 0) {
- goto L40;
- }
- i__2 = m;
- for (i__ = 1; i__ <= i__2; ++i__) {
- sx[i__] = *sa * sx[i__];
-/* L30: */
- }
- if (*n < 5) {
- return 0;
- }
-L40:
- mp1 = m + 1;
- i__2 = *n;
- for (i__ = mp1; i__ <= i__2; i__ += 5) {
- sx[i__] = *sa * sx[i__];
- sx[i__ + 1] = *sa * sx[i__ + 1];
- sx[i__ + 2] = *sa * sx[i__ + 2];
- sx[i__ + 3] = *sa * sx[i__ + 3];
- sx[i__ + 4] = *sa * sx[i__ + 4];
-/* L50: */
- }
- return 0;
-} /* sscal_ */
-
-/* Subroutine */ int sspmv_(char *uplo, integer *n, real *alpha, real *ap,
- real *x, integer *incx, real *beta, real *y, integer *incy, ftnlen
- uplo_len)
-{
- /* System generated locals */
- integer i__1, i__2;
-
- /* Local variables */
- static integer i__, j, k, kk, ix, iy, jx, jy, kx, ky, info;
- static real temp1, temp2;
- extern logical lsame_(char *, char *, ftnlen, ftnlen);
- extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen);
-
-/* .. Scalar Arguments .. */
-/* .. Array Arguments .. */
-/* .. */
-
-/* Purpose */
-/* ======= */
-
-/* SSPMV performs the matrix-vector operation */
-
-/* y := alpha*A*x + beta*y, */
-
-/* where alpha and beta are scalars, x and y are n element vectors and */
-/* A is an n by n symmetric matrix, supplied in packed form. */
-
-/* Parameters */
-/* ========== */
-
-/* UPLO - CHARACTER*1. */
-/* On entry, UPLO specifies whether the upper or lower */
-/* triangular part of the matrix A is supplied in the packed */
-/* array AP as follows: */
-
-/* UPLO = 'U' or 'u' The upper triangular part of A is */
-/* supplied in AP. */
-
-/* UPLO = 'L' or 'l' The lower triangular part of A is */
-/* supplied in AP. */
-
-/* Unchanged on exit. */
-
-/* N - INTEGER. */
-/* On entry, N specifies the order of the matrix A. */
-/* N must be at least zero. */
-/* Unchanged on exit. */
-
-/* ALPHA - REAL . */
-/* On entry, ALPHA specifies the scalar alpha. */
-/* Unchanged on exit. */
-
-/* AP - REAL array of DIMENSION at least */
-/* ( ( n*( n + 1 ) )/2 ). */
-/* Before entry with UPLO = 'U' or 'u', the array AP must */
-/* contain the upper triangular part of the symmetric matrix */
-/* packed sequentially, column by column, so that AP( 1 ) */
-/* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 ) */
-/* and a( 2, 2 ) respectively, and so on. */
-/* Before entry with UPLO = 'L' or 'l', the array AP must */
-/* contain the lower triangular part of the symmetric matrix */
-/* packed sequentially, column by column, so that AP( 1 ) */
-/* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 ) */
-/* and a( 3, 1 ) respectively, and so on. */
-/* Unchanged on exit. */
-
-/* X - REAL array of dimension at least */
-/* ( 1 + ( n - 1 )*abs( INCX ) ). */
-/* Before entry, the incremented array X must contain the n */
-/* element vector x. */
-/* Unchanged on exit. */
-
-/* INCX - INTEGER. */
-/* On entry, INCX specifies the increment for the elements of */
-/* X. INCX must not be zero. */
-/* Unchanged on exit. */
-
-/* BETA - REAL . */
-/* On entry, BETA specifies the scalar beta. When BETA is */
-/* supplied as zero then Y need not be set on input. */
-/* Unchanged on exit. */
-
-/* Y - REAL array of dimension at least */
-/* ( 1 + ( n - 1 )*abs( INCY ) ). */
-/* Before entry, the incremented array Y must contain the n */
-/* element vector y. On exit, Y is overwritten by the updated */
-/* vector y. */
-
-/* INCY - INTEGER. */
-/* On entry, INCY specifies the increment for the elements of */
-/* Y. INCY must not be zero. */
-/* Unchanged on exit. */
-
-
-/* Level 2 Blas routine. */
-
-/* -- Written on 22-October-1986. */
-/* Jack Dongarra, Argonne National Lab. */
-/* Jeremy Du Croz, Nag Central Office. */
-/* Sven Hammarling, Nag Central Office. */
-/* Richard Hanson, Sandia National Labs. */
-
-
-/* .. Parameters .. */
-/* .. Local Scalars .. */
-/* .. External Functions .. */
-/* .. External Subroutines .. */
-/* .. */
-/* .. Executable Statements .. */
-
-/* Test the input parameters. */
-
- /* Parameter adjustments */
- --y;
- --x;
- --ap;
-
- /* Function Body */
- info = 0;
- if (! lsame_(uplo, "U", (ftnlen)1, (ftnlen)1) && ! lsame_(uplo, "L", (
- ftnlen)1, (ftnlen)1)) {
- info = 1;
- } else if (*n < 0) {
- info = 2;
- } else if (*incx == 0) {
- info = 6;
- } else if (*incy == 0) {
- info = 9;
- }
- if (info != 0) {
- xerbla_("SSPMV ", &info, (ftnlen)6);
- return 0;
- }
-
-/* Quick return if possible. */
-
- if (*n == 0 || *alpha == 0.f && *beta == 1.f) {
- return 0;
- }
-
-/* Set up the start points in X and Y. */
-
- if (*incx > 0) {
- kx = 1;
- } else {
- kx = 1 - (*n - 1) * *incx;
- }
- if (*incy > 0) {
- ky = 1;
- } else {
- ky = 1 - (*n - 1) * *incy;
- }
-
-/* Start the operations. In this version the elements of the array AP */
-/* are accessed sequentially with one pass through AP. */
-
-/* First form y := beta*y. */
-
- if (*beta != 1.f) {
- if (*incy == 1) {
- if (*beta == 0.f) {
- i__1 = *n;
- for (i__ = 1; i__ <= i__1; ++i__) {
- y[i__] = 0.f;
-/* L10: */
- }
- } else {
- i__1 = *n;
- for (i__ = 1; i__ <= i__1; ++i__) {
- y[i__] = *beta * y[i__];
-/* L20: */
- }
- }
- } else {
- iy = ky;
- if (*beta == 0.f) {
- i__1 = *n;
- for (i__ = 1; i__ <= i__1; ++i__) {
- y[iy] = 0.f;
- iy += *incy;
-/* L30: */
- }
- } else {
- i__1 = *n;
- for (i__ = 1; i__ <= i__1; ++i__) {
- y[iy] = *beta * y[iy];
- iy += *incy;
-/* L40: */
- }
- }
- }
- }
- if (*alpha == 0.f) {
- return 0;
- }
- kk = 1;
- if (lsame_(uplo, "U", (ftnlen)1, (ftnlen)1)) {
-
-/* Form y when AP contains the upper triangle. */
-
- if (*incx == 1 && *incy == 1) {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- temp1 = *alpha * x[j];
- temp2 = 0.f;
- k = kk;
- i__2 = j - 1;
- for (i__ = 1; i__ <= i__2; ++i__) {
- y[i__] += temp1 * ap[k];
- temp2 += ap[k] * x[i__];
- ++k;
-/* L50: */
- }
- y[j] = y[j] + temp1 * ap[kk + j - 1] + *alpha * temp2;
- kk += j;
-/* L60: */
- }
- } else {
- jx = kx;
- jy = ky;
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- temp1 = *alpha * x[jx];
- temp2 = 0.f;
- ix = kx;
- iy = ky;
- i__2 = kk + j - 2;
- for (k = kk; k <= i__2; ++k) {
- y[iy] += temp1 * ap[k];
- temp2 += ap[k] * x[ix];
- ix += *incx;
- iy += *incy;
-/* L70: */
- }
- y[jy] = y[jy] + temp1 * ap[kk + j - 1] + *alpha * temp2;
- jx += *incx;
- jy += *incy;
- kk += j;
-/* L80: */
- }
- }
- } else {
-
-/* Form y when AP contains the lower triangle. */
-
- if (*incx == 1 && *incy == 1) {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- temp1 = *alpha * x[j];
- temp2 = 0.f;
- y[j] += temp1 * ap[kk];
- k = kk + 1;
- i__2 = *n;
- for (i__ = j + 1; i__ <= i__2; ++i__) {
- y[i__] += temp1 * ap[k];
- temp2 += ap[k] * x[i__];
- ++k;
-/* L90: */
- }
- y[j] += *alpha * temp2;
- kk += *n - j + 1;
-/* L100: */
- }
- } else {
- jx = kx;
- jy = ky;
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- temp1 = *alpha * x[jx];
- temp2 = 0.f;
- y[jy] += temp1 * ap[kk];
- ix = jx;
- iy = jy;
- i__2 = kk + *n - j;
- for (k = kk + 1; k <= i__2; ++k) {
- ix += *incx;
- iy += *incy;
- y[iy] += temp1 * ap[k];
- temp2 += ap[k] * x[ix];
-/* L110: */
- }
- y[jy] += *alpha * temp2;
- jx += *incx;
- jy += *incy;
- kk += *n - j + 1;
-/* L120: */
- }
- }
- }
-
- return 0;
-
-/* End of SSPMV . */
-
-} /* sspmv_ */
-
-/* Subroutine */ int sspr_(char *uplo, integer *n, real *alpha, real *x,
- integer *incx, real *ap, ftnlen uplo_len)
-{
- /* System generated locals */
- integer i__1, i__2;
-
- /* Local variables */
- static integer i__, j, k, kk, ix, jx, kx, info;
- static real temp;
- extern logical lsame_(char *, char *, ftnlen, ftnlen);
- extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen);
-
-/* .. Scalar Arguments .. */
-/* .. Array Arguments .. */
-/* .. */
-
-/* Purpose */
-/* ======= */
-
-/* SSPR performs the symmetric rank 1 operation */
-
-/* A := alpha*x*x' + A, */
-
-/* where alpha is a real scalar, x is an n element vector and A is an */
-/* n by n symmetric matrix, supplied in packed form. */
-
-/* Parameters */
-/* ========== */
-
-/* UPLO - CHARACTER*1. */
-/* On entry, UPLO specifies whether the upper or lower */
-/* triangular part of the matrix A is supplied in the packed */
-/* array AP as follows: */
-
-/* UPLO = 'U' or 'u' The upper triangular part of A is */
-/* supplied in AP. */
-
-/* UPLO = 'L' or 'l' The lower triangular part of A is */
-/* supplied in AP. */
-
-/* Unchanged on exit. */
-
-/* N - INTEGER. */
-/* On entry, N specifies the order of the matrix A. */
-/* N must be at least zero. */
-/* Unchanged on exit. */
-
-/* ALPHA - REAL . */
-/* On entry, ALPHA specifies the scalar alpha. */
-/* Unchanged on exit. */
-
-/* X - REAL array of dimension at least */
-/* ( 1 + ( n - 1 )*abs( INCX ) ). */
-/* Before entry, the incremented array X must contain the n */
-/* element vector x. */
-/* Unchanged on exit. */
-
-/* INCX - INTEGER. */
-/* On entry, INCX specifies the increment for the elements of */
-/* X. INCX must not be zero. */
-/* Unchanged on exit. */
-
-/* AP - REAL array of DIMENSION at least */
-/* ( ( n*( n + 1 ) )/2 ). */
-/* Before entry with UPLO = 'U' or 'u', the array AP must */
-/* contain the upper triangular part of the symmetric matrix */
-/* packed sequentially, column by column, so that AP( 1 ) */
-/* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 ) */
-/* and a( 2, 2 ) respectively, and so on. On exit, the array */
-/* AP is overwritten by the upper triangular part of the */
-/* updated matrix. */
-/* Before entry with UPLO = 'L' or 'l', the array AP must */
-/* contain the lower triangular part of the symmetric matrix */
-/* packed sequentially, column by column, so that AP( 1 ) */
-/* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 ) */
-/* and a( 3, 1 ) respectively, and so on. On exit, the array */
-/* AP is overwritten by the lower triangular part of the */
-/* updated matrix. */
-
-
-/* Level 2 Blas routine. */
-
-/* -- Written on 22-October-1986. */
-/* Jack Dongarra, Argonne National Lab. */
-/* Jeremy Du Croz, Nag Central Office. */
-/* Sven Hammarling, Nag Central Office. */
-/* Richard Hanson, Sandia National Labs. */
-
-
-/* .. Parameters .. */
-/* .. Local Scalars .. */
-/* .. External Functions .. */
-/* .. External Subroutines .. */
-/* .. */
-/* .. Executable Statements .. */
-
-/* Test the input parameters. */
-
- /* Parameter adjustments */
- --ap;
- --x;
-
- /* Function Body */
- info = 0;
- if (! lsame_(uplo, "U", (ftnlen)1, (ftnlen)1) && ! lsame_(uplo, "L", (
- ftnlen)1, (ftnlen)1)) {
- info = 1;
- } else if (*n < 0) {
- info = 2;
- } else if (*incx == 0) {
- info = 5;
- }
- if (info != 0) {
- xerbla_("SSPR ", &info, (ftnlen)6);
- return 0;
- }
-
-/* Quick return if possible. */
-
- if (*n == 0 || *alpha == 0.f) {
- return 0;
- }
-
-/* Set the start point in X if the increment is not unity. */
-
- if (*incx <= 0) {
- kx = 1 - (*n - 1) * *incx;
- } else if (*incx != 1) {
- kx = 1;
- }
-
-/* Start the operations. In this version the elements of the array AP */
-/* are accessed sequentially with one pass through AP. */
-
- kk = 1;
- if (lsame_(uplo, "U", (ftnlen)1, (ftnlen)1)) {
-
-/* Form A when upper triangle is stored in AP. */
-
- if (*incx == 1) {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- if (x[j] != 0.f) {
- temp = *alpha * x[j];
- k = kk;
- i__2 = j;
- for (i__ = 1; i__ <= i__2; ++i__) {
- ap[k] += x[i__] * temp;
- ++k;
-/* L10: */
- }
- }
- kk += j;
-/* L20: */
- }
- } else {
- jx = kx;
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- if (x[jx] != 0.f) {
- temp = *alpha * x[jx];
- ix = kx;
- i__2 = kk + j - 1;
- for (k = kk; k <= i__2; ++k) {
- ap[k] += x[ix] * temp;
- ix += *incx;
-/* L30: */
- }
- }
- jx += *incx;
- kk += j;
-/* L40: */
- }
- }
- } else {
-
-/* Form A when lower triangle is stored in AP. */
-
- if (*incx == 1) {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- if (x[j] != 0.f) {
- temp = *alpha * x[j];
- k = kk;
- i__2 = *n;
- for (i__ = j; i__ <= i__2; ++i__) {
- ap[k] += x[i__] * temp;
- ++k;
-/* L50: */
- }
- }
- kk = kk + *n - j + 1;
-/* L60: */
- }
- } else {
- jx = kx;
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- if (x[jx] != 0.f) {
- temp = *alpha * x[jx];
- ix = jx;
- i__2 = kk + *n - j;
- for (k = kk; k <= i__2; ++k) {
- ap[k] += x[ix] * temp;
- ix += *incx;
-/* L70: */
- }
- }
- jx += *incx;
- kk = kk + *n - j + 1;
-/* L80: */
- }
- }
- }
-
- return 0;
-
-/* End of SSPR . */
-
-} /* sspr_ */
-
-/* Subroutine */ int sspr2_(char *uplo, integer *n, real *alpha, real *x,
- integer *incx, real *y, integer *incy, real *ap, ftnlen uplo_len)
-{
- /* System generated locals */
- integer i__1, i__2;
-
- /* Local variables */
- static integer i__, j, k, kk, ix, iy, jx, jy, kx, ky, info;
- static real temp1, temp2;
- extern logical lsame_(char *, char *, ftnlen, ftnlen);
- extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen);
-
-/* .. Scalar Arguments .. */
-/* .. Array Arguments .. */
-/* .. */
-
-/* Purpose */
-/* ======= */
-
-/* SSPR2 performs the symmetric rank 2 operation */
-
-/* A := alpha*x*y' + alpha*y*x' + A, */
-
-/* where alpha is a scalar, x and y are n element vectors and A is an */
-/* n by n symmetric matrix, supplied in packed form. */
-
-/* Parameters */
-/* ========== */
-
-/* UPLO - CHARACTER*1. */
-/* On entry, UPLO specifies whether the upper or lower */
-/* triangular part of the matrix A is supplied in the packed */
-/* array AP as follows: */
-
-/* UPLO = 'U' or 'u' The upper triangular part of A is */
-/* supplied in AP. */
-
-/* UPLO = 'L' or 'l' The lower triangular part of A is */
-/* supplied in AP. */
-
-/* Unchanged on exit. */
-
-/* N - INTEGER. */
-/* On entry, N specifies the order of the matrix A. */
-/* N must be at least zero. */
-/* Unchanged on exit. */
-
-/* ALPHA - REAL . */
-/* On entry, ALPHA specifies the scalar alpha. */
-/* Unchanged on exit. */
-
-/* X - REAL array of dimension at least */
-/* ( 1 + ( n - 1 )*abs( INCX ) ). */
-/* Before entry, the incremented array X must contain the n */
-/* element vector x. */
-/* Unchanged on exit. */
-
-/* INCX - INTEGER. */
-/* On entry, INCX specifies the increment for the elements of */
-/* X. INCX must not be zero. */
-/* Unchanged on exit. */
-
-/* Y - REAL array of dimension at least */
-/* ( 1 + ( n - 1 )*abs( INCY ) ). */
-/* Before entry, the incremented array Y must contain the n */
-/* element vector y. */
-/* Unchanged on exit. */
-
-/* INCY - INTEGER. */
-/* On entry, INCY specifies the increment for the elements of */
-/* Y. INCY must not be zero. */
-/* Unchanged on exit. */
-
-/* AP - REAL array of DIMENSION at least */
-/* ( ( n*( n + 1 ) )/2 ). */
-/* Before entry with UPLO = 'U' or 'u', the array AP must */
-/* contain the upper triangular part of the symmetric matrix */
-/* packed sequentially, column by column, so that AP( 1 ) */
-/* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 ) */
-/* and a( 2, 2 ) respectively, and so on. On exit, the array */
-/* AP is overwritten by the upper triangular part of the */
-/* updated matrix. */
-/* Before entry with UPLO = 'L' or 'l', the array AP must */
-/* contain the lower triangular part of the symmetric matrix */
-/* packed sequentially, column by column, so that AP( 1 ) */
-/* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 ) */
-/* and a( 3, 1 ) respectively, and so on. On exit, the array */
-/* AP is overwritten by the lower triangular part of the */
-/* updated matrix. */
-
-
-/* Level 2 Blas routine. */
-
-/* -- Written on 22-October-1986. */
-/* Jack Dongarra, Argonne National Lab. */
-/* Jeremy Du Croz, Nag Central Office. */
-/* Sven Hammarling, Nag Central Office. */
-/* Richard Hanson, Sandia National Labs. */
-
-
-/* .. Parameters .. */
-/* .. Local Scalars .. */
-/* .. External Functions .. */
-/* .. External Subroutines .. */
-/* .. */
-/* .. Executable Statements .. */
-
-/* Test the input parameters. */
-
- /* Parameter adjustments */
- --ap;
- --y;
- --x;
-
- /* Function Body */
- info = 0;
- if (! lsame_(uplo, "U", (ftnlen)1, (ftnlen)1) && ! lsame_(uplo, "L", (
- ftnlen)1, (ftnlen)1)) {
- info = 1;
- } else if (*n < 0) {
- info = 2;
- } else if (*incx == 0) {
- info = 5;
- } else if (*incy == 0) {
- info = 7;
- }
- if (info != 0) {
- xerbla_("SSPR2 ", &info, (ftnlen)6);
- return 0;
- }
-
-/* Quick return if possible. */
-
- if (*n == 0 || *alpha == 0.f) {
- return 0;
- }
-
-/* Set up the start points in X and Y if the increments are not both */
-/* unity. */
-
- if (*incx != 1 || *incy != 1) {
- if (*incx > 0) {
- kx = 1;
- } else {
- kx = 1 - (*n - 1) * *incx;
- }
- if (*incy > 0) {
- ky = 1;
- } else {
- ky = 1 - (*n - 1) * *incy;
- }
- jx = kx;
- jy = ky;
- }
-
-/* Start the operations. In this version the elements of the array AP */
-/* are accessed sequentially with one pass through AP. */
-
- kk = 1;
- if (lsame_(uplo, "U", (ftnlen)1, (ftnlen)1)) {
-
-/* Form A when upper triangle is stored in AP. */
-
- if (*incx == 1 && *incy == 1) {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- if (x[j] != 0.f || y[j] != 0.f) {
- temp1 = *alpha * y[j];
- temp2 = *alpha * x[j];
- k = kk;
- i__2 = j;
- for (i__ = 1; i__ <= i__2; ++i__) {
- ap[k] = ap[k] + x[i__] * temp1 + y[i__] * temp2;
- ++k;
-/* L10: */
- }
- }
- kk += j;
-/* L20: */
- }
- } else {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- if (x[jx] != 0.f || y[jy] != 0.f) {
- temp1 = *alpha * y[jy];
- temp2 = *alpha * x[jx];
- ix = kx;
- iy = ky;
- i__2 = kk + j - 1;
- for (k = kk; k <= i__2; ++k) {
- ap[k] = ap[k] + x[ix] * temp1 + y[iy] * temp2;
- ix += *incx;
- iy += *incy;
-/* L30: */
- }
- }
- jx += *incx;
- jy += *incy;
- kk += j;
-/* L40: */
- }
- }
- } else {
-
-/* Form A when lower triangle is stored in AP. */
-
- if (*incx == 1 && *incy == 1) {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- if (x[j] != 0.f || y[j] != 0.f) {
- temp1 = *alpha * y[j];
- temp2 = *alpha * x[j];
- k = kk;
- i__2 = *n;
- for (i__ = j; i__ <= i__2; ++i__) {
- ap[k] = ap[k] + x[i__] * temp1 + y[i__] * temp2;
- ++k;
-/* L50: */
- }
- }
- kk = kk + *n - j + 1;
-/* L60: */
- }
- } else {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- if (x[jx] != 0.f || y[jy] != 0.f) {
- temp1 = *alpha * y[jy];
- temp2 = *alpha * x[jx];
- ix = jx;
- iy = jy;
- i__2 = kk + *n - j;
- for (k = kk; k <= i__2; ++k) {
- ap[k] = ap[k] + x[ix] * temp1 + y[iy] * temp2;
- ix += *incx;
- iy += *incy;
-/* L70: */
- }
- }
- jx += *incx;
- jy += *incy;
- kk = kk + *n - j + 1;
-/* L80: */
- }
- }
- }
-
- return 0;
-
-/* End of SSPR2 . */
-
-} /* sspr2_ */
-
-/* Subroutine */ int sswap_(integer *n, real *sx, integer *incx, real *sy,
- integer *incy)
-{
- /* System generated locals */
- integer i__1;
-
- /* Local variables */
- static integer i__, m, ix, iy, mp1;
- static real stemp;
-
-
-/* interchanges two vectors. */
-/* uses unrolled loops for increments equal to 1. */
-/* jack dongarra, linpack, 3/11/78. */
-/* modified 12/3/93, array(1) declarations changed to array(*) */
-
-
- /* Parameter adjustments */
- --sy;
- --sx;
-
- /* Function Body */
- if (*n <= 0) {
- return 0;
- }
- if (*incx == 1 && *incy == 1) {
- goto L20;
- }
-
-/* code for unequal increments or equal increments not equal */
-/* to 1 */
-
- ix = 1;
- iy = 1;
- if (*incx < 0) {
- ix = (-(*n) + 1) * *incx + 1;
- }
- if (*incy < 0) {
- iy = (-(*n) + 1) * *incy + 1;
- }
- i__1 = *n;
- for (i__ = 1; i__ <= i__1; ++i__) {
- stemp = sx[ix];
- sx[ix] = sy[iy];
- sy[iy] = stemp;
- ix += *incx;
- iy += *incy;
-/* L10: */
- }
- return 0;
-
-/* code for both increments equal to 1 */
-
-
-/* clean-up loop */
-
-L20:
- m = *n % 3;
- if (m == 0) {
- goto L40;
- }
- i__1 = m;
- for (i__ = 1; i__ <= i__1; ++i__) {
- stemp = sx[i__];
- sx[i__] = sy[i__];
- sy[i__] = stemp;
-/* L30: */
- }
- if (*n < 3) {
- return 0;
- }
-L40:
- mp1 = m + 1;
- i__1 = *n;
- for (i__ = mp1; i__ <= i__1; i__ += 3) {
- stemp = sx[i__];
- sx[i__] = sy[i__];
- sy[i__] = stemp;
- stemp = sx[i__ + 1];
- sx[i__ + 1] = sy[i__ + 1];
- sy[i__ + 1] = stemp;
- stemp = sx[i__ + 2];
- sx[i__ + 2] = sy[i__ + 2];
- sy[i__ + 2] = stemp;
-/* L50: */
- }
- return 0;
-} /* sswap_ */
-
-/* Subroutine */ int ssymm_(char *side, char *uplo, integer *m, integer *n,
- real *alpha, real *a, integer *lda, real *b, integer *ldb, real *beta,
- real *c__, integer *ldc, ftnlen side_len, ftnlen uplo_len)
-{
- /* System generated locals */
- integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2,
- i__3;
-
- /* Local variables */
- static integer i__, j, k, info;
- static real temp1, temp2;
- extern logical lsame_(char *, char *, ftnlen, ftnlen);
- static integer nrowa;
- static logical upper;
- extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen);
-
-/* .. Scalar Arguments .. */
-/* .. Array Arguments .. */
-/* .. */
-
-/* Purpose */
-/* ======= */
-
-/* SSYMM performs one of the matrix-matrix operations */
-
-/* C := alpha*A*B + beta*C, */
-
-/* or */
-
-/* C := alpha*B*A + beta*C, */
-
-/* where alpha and beta are scalars, A is a symmetric matrix and B and */
-/* C are m by n matrices. */
-
-/* Parameters */
-/* ========== */
-
-/* SIDE - CHARACTER*1. */
-/* On entry, SIDE specifies whether the symmetric matrix A */
-/* appears on the left or right in the operation as follows: */
-
-/* SIDE = 'L' or 'l' C := alpha*A*B + beta*C, */
-
-/* SIDE = 'R' or 'r' C := alpha*B*A + beta*C, */
-
-/* Unchanged on exit. */
-
-/* UPLO - CHARACTER*1. */
-/* On entry, UPLO specifies whether the upper or lower */
-/* triangular part of the symmetric matrix A is to be */
-/* referenced as follows: */
-
-/* UPLO = 'U' or 'u' Only the upper triangular part of the */
-/* symmetric matrix is to be referenced. */
-
-/* UPLO = 'L' or 'l' Only the lower triangular part of the */
-/* symmetric matrix is to be referenced. */
-
-/* Unchanged on exit. */
-
-/* M - INTEGER. */
-/* On entry, M specifies the number of rows of the matrix C. */
-/* M must be at least zero. */
-/* Unchanged on exit. */
-
-/* N - INTEGER. */
-/* On entry, N specifies the number of columns of the matrix C. */
-/* N must be at least zero. */
-/* Unchanged on exit. */
-
-/* ALPHA - REAL . */
-/* On entry, ALPHA specifies the scalar alpha. */
-/* Unchanged on exit. */
-
-/* A - REAL array of DIMENSION ( LDA, ka ), where ka is */
-/* m when SIDE = 'L' or 'l' and is n otherwise. */
-/* Before entry with SIDE = 'L' or 'l', the m by m part of */
-/* the array A must contain the symmetric matrix, such that */
-/* when UPLO = 'U' or 'u', the leading m by m upper triangular */
-/* part of the array A must contain the upper triangular part */
-/* of the symmetric matrix and the strictly lower triangular */
-/* part of A is not referenced, and when UPLO = 'L' or 'l', */
-/* the leading m by m lower triangular part of the array A */
-/* must contain the lower triangular part of the symmetric */
-/* matrix and the strictly upper triangular part of A is not */
-/* referenced. */
-/* Before entry with SIDE = 'R' or 'r', the n by n part of */
-/* the array A must contain the symmetric matrix, such that */
-/* when UPLO = 'U' or 'u', the leading n by n upper triangular */
-/* part of the array A must contain the upper triangular part */
-/* of the symmetric matrix and the strictly lower triangular */
-/* part of A is not referenced, and when UPLO = 'L' or 'l', */
-/* the leading n by n lower triangular part of the array A */
-/* must contain the lower triangular part of the symmetric */
-/* matrix and the strictly upper triangular part of A is not */
-/* referenced. */
-/* Unchanged on exit. */
-
-/* LDA - INTEGER. */
-/* On entry, LDA specifies the first dimension of A as declared */
-/* in the calling (sub) program. When SIDE = 'L' or 'l' then */
-/* LDA must be at least max( 1, m ), otherwise LDA must be at */
-/* least max( 1, n ). */
-/* Unchanged on exit. */
-
-/* B - REAL array of DIMENSION ( LDB, n ). */
-/* Before entry, the leading m by n part of the array B must */
-/* contain the matrix B. */
-/* Unchanged on exit. */
-
-/* LDB - INTEGER. */
-/* On entry, LDB specifies the first dimension of B as declared */
-/* in the calling (sub) program. LDB must be at least */
-/* max( 1, m ). */
-/* Unchanged on exit. */
-
-/* BETA - REAL . */
-/* On entry, BETA specifies the scalar beta. When BETA is */
-/* supplied as zero then C need not be set on input. */
-/* Unchanged on exit. */
-
-/* C - REAL array of DIMENSION ( LDC, n ). */
-/* Before entry, the leading m by n part of the array C must */
-/* contain the matrix C, except when beta is zero, in which */
-/* case C need not be set on entry. */
-/* On exit, the array C is overwritten by the m by n updated */
-/* matrix. */
-
-/* LDC - INTEGER. */
-/* On entry, LDC specifies the first dimension of C as declared */
-/* in the calling (sub) program. LDC must be at least */
-/* max( 1, m ). */
-/* Unchanged on exit. */
-
-
-/* Level 3 Blas routine. */
-
-/* -- Written on 8-February-1989. */
-/* Jack Dongarra, Argonne National Laboratory. */
-/* Iain Duff, AERE Harwell. */
-/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */
-/* Sven Hammarling, Numerical Algorithms Group Ltd. */
-
-
-/* .. External Functions .. */
-/* .. External Subroutines .. */
-/* .. Intrinsic Functions .. */
-/* .. Local Scalars .. */
-/* .. Parameters .. */
-/* .. */
-/* .. Executable Statements .. */
-
-/* Set NROWA as the number of rows of A. */
-
- /* Parameter adjustments */
- a_dim1 = *lda;
- a_offset = 1 + a_dim1 * 1;
- a -= a_offset;
- b_dim1 = *ldb;
- b_offset = 1 + b_dim1 * 1;
- b -= b_offset;
- c_dim1 = *ldc;
- c_offset = 1 + c_dim1 * 1;
- c__ -= c_offset;
-
- /* Function Body */
- if (lsame_(side, "L", (ftnlen)1, (ftnlen)1)) {
- nrowa = *m;
- } else {
- nrowa = *n;
- }
- upper = lsame_(uplo, "U", (ftnlen)1, (ftnlen)1);
-
-/* Test the input parameters. */
-
- info = 0;
- if (! lsame_(side, "L", (ftnlen)1, (ftnlen)1) && ! lsame_(side, "R", (
- ftnlen)1, (ftnlen)1)) {
- info = 1;
- } else if (! upper && ! lsame_(uplo, "L", (ftnlen)1, (ftnlen)1)) {
- info = 2;
- } else if (*m < 0) {
- info = 3;
- } else if (*n < 0) {
- info = 4;
- } else if (*lda < max(1,nrowa)) {
- info = 7;
- } else if (*ldb < max(1,*m)) {
- info = 9;
- } else if (*ldc < max(1,*m)) {
- info = 12;
- }
- if (info != 0) {
- xerbla_("SSYMM ", &info, (ftnlen)6);
- return 0;
- }
-
-/* Quick return if possible. */
-
- if (*m == 0 || *n == 0 || *alpha == 0.f && *beta == 1.f) {
- return 0;
- }
-
-/* And when alpha.eq.zero. */
-
- if (*alpha == 0.f) {
- if (*beta == 0.f) {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- i__2 = *m;
- for (i__ = 1; i__ <= i__2; ++i__) {
- c__[i__ + j * c_dim1] = 0.f;
-/* L10: */
- }
-/* L20: */
- }
- } else {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- i__2 = *m;
- for (i__ = 1; i__ <= i__2; ++i__) {
- c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1];
-/* L30: */
- }
-/* L40: */
- }
- }
- return 0;
- }
-
-/* Start the operations. */
-
- if (lsame_(side, "L", (ftnlen)1, (ftnlen)1)) {
-
-/* Form C := alpha*A*B + beta*C. */
-
- if (upper) {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- i__2 = *m;
- for (i__ = 1; i__ <= i__2; ++i__) {
- temp1 = *alpha * b[i__ + j * b_dim1];
- temp2 = 0.f;
- i__3 = i__ - 1;
- for (k = 1; k <= i__3; ++k) {
- c__[k + j * c_dim1] += temp1 * a[k + i__ * a_dim1];
- temp2 += b[k + j * b_dim1] * a[k + i__ * a_dim1];
-/* L50: */
- }
- if (*beta == 0.f) {
- c__[i__ + j * c_dim1] = temp1 * a[i__ + i__ * a_dim1]
- + *alpha * temp2;
- } else {
- c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1]
- + temp1 * a[i__ + i__ * a_dim1] + *alpha *
- temp2;
- }
-/* L60: */
- }
-/* L70: */
- }
- } else {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- for (i__ = *m; i__ >= 1; --i__) {
- temp1 = *alpha * b[i__ + j * b_dim1];
- temp2 = 0.f;
- i__2 = *m;
- for (k = i__ + 1; k <= i__2; ++k) {
- c__[k + j * c_dim1] += temp1 * a[k + i__ * a_dim1];
- temp2 += b[k + j * b_dim1] * a[k + i__ * a_dim1];
-/* L80: */
- }
- if (*beta == 0.f) {
- c__[i__ + j * c_dim1] = temp1 * a[i__ + i__ * a_dim1]
- + *alpha * temp2;
- } else {
- c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1]
- + temp1 * a[i__ + i__ * a_dim1] + *alpha *
- temp2;
- }
-/* L90: */
- }
-/* L100: */
- }
- }
- } else {
-
-/* Form C := alpha*B*A + beta*C. */
-
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- temp1 = *alpha * a[j + j * a_dim1];
- if (*beta == 0.f) {
- i__2 = *m;
- for (i__ = 1; i__ <= i__2; ++i__) {
- c__[i__ + j * c_dim1] = temp1 * b[i__ + j * b_dim1];
-/* L110: */
- }
- } else {
- i__2 = *m;
- for (i__ = 1; i__ <= i__2; ++i__) {
- c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1] +
- temp1 * b[i__ + j * b_dim1];
-/* L120: */
- }
- }
- i__2 = j - 1;
- for (k = 1; k <= i__2; ++k) {
- if (upper) {
- temp1 = *alpha * a[k + j * a_dim1];
- } else {
- temp1 = *alpha * a[j + k * a_dim1];
- }
- i__3 = *m;
- for (i__ = 1; i__ <= i__3; ++i__) {
- c__[i__ + j * c_dim1] += temp1 * b[i__ + k * b_dim1];
-/* L130: */
- }
-/* L140: */
- }
- i__2 = *n;
- for (k = j + 1; k <= i__2; ++k) {
- if (upper) {
- temp1 = *alpha * a[j + k * a_dim1];
- } else {
- temp1 = *alpha * a[k + j * a_dim1];
- }
- i__3 = *m;
- for (i__ = 1; i__ <= i__3; ++i__) {
- c__[i__ + j * c_dim1] += temp1 * b[i__ + k * b_dim1];
-/* L150: */
- }
-/* L160: */
- }
-/* L170: */
- }
- }
-
- return 0;
-
-/* End of SSYMM . */
-
-} /* ssymm_ */
-
-/* Subroutine */ int ssymv_(char *uplo, integer *n, real *alpha, real *a,
- integer *lda, real *x, integer *incx, real *beta, real *y, integer *
- incy, ftnlen uplo_len)
-{
- /* System generated locals */
- integer a_dim1, a_offset, i__1, i__2;
-
- /* Local variables */
- static integer i__, j, ix, iy, jx, jy, kx, ky, info;
- static real temp1, temp2;
- extern logical lsame_(char *, char *, ftnlen, ftnlen);
- extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen);
-
-/* .. Scalar Arguments .. */
-/* .. Array Arguments .. */
-/* .. */
-
-/* Purpose */
-/* ======= */
-
-/* SSYMV performs the matrix-vector operation */
-
-/* y := alpha*A*x + beta*y, */
-
-/* where alpha and beta are scalars, x and y are n element vectors and */
-/* A is an n by n symmetric matrix. */
-
-/* Parameters */
-/* ========== */
-
-/* UPLO - CHARACTER*1. */
-/* On entry, UPLO specifies whether the upper or lower */
-/* triangular part of the array A is to be referenced as */
-/* follows: */
-
-/* UPLO = 'U' or 'u' Only the upper triangular part of A */
-/* is to be referenced. */
-
-/* UPLO = 'L' or 'l' Only the lower triangular part of A */
-/* is to be referenced. */
-
-/* Unchanged on exit. */
-
-/* N - INTEGER. */
-/* On entry, N specifies the order of the matrix A. */
-/* N must be at least zero. */
-/* Unchanged on exit. */
-
-/* ALPHA - REAL . */
-/* On entry, ALPHA specifies the scalar alpha. */
-/* Unchanged on exit. */
-
-/* A - REAL array of DIMENSION ( LDA, n ). */
-/* Before entry with UPLO = 'U' or 'u', the leading n by n */
-/* upper triangular part of the array A must contain the upper */
-/* triangular part of the symmetric matrix and the strictly */
-/* lower triangular part of A is not referenced. */
-/* Before entry with UPLO = 'L' or 'l', the leading n by n */
-/* lower triangular part of the array A must contain the lower */
-/* triangular part of the symmetric matrix and the strictly */
-/* upper triangular part of A is not referenced. */
-/* Unchanged on exit. */
-
-/* LDA - INTEGER. */
-/* On entry, LDA specifies the first dimension of A as declared */
-/* in the calling (sub) program. LDA must be at least */
-/* max( 1, n ). */
-/* Unchanged on exit. */
-
-/* X - REAL array of dimension at least */
-/* ( 1 + ( n - 1 )*abs( INCX ) ). */
-/* Before entry, the incremented array X must contain the n */
-/* element vector x. */
-/* Unchanged on exit. */
-
-/* INCX - INTEGER. */
-/* On entry, INCX specifies the increment for the elements of */
-/* X. INCX must not be zero. */
-/* Unchanged on exit. */
-
-/* BETA - REAL . */
-/* On entry, BETA specifies the scalar beta. When BETA is */
-/* supplied as zero then Y need not be set on input. */
-/* Unchanged on exit. */
-
-/* Y - REAL array of dimension at least */
-/* ( 1 + ( n - 1 )*abs( INCY ) ). */
-/* Before entry, the incremented array Y must contain the n */
-/* element vector y. On exit, Y is overwritten by the updated */
-/* vector y. */
-
-/* INCY - INTEGER. */
-/* On entry, INCY specifies the increment for the elements of */
-/* Y. INCY must not be zero. */
-/* Unchanged on exit. */
-
-
-/* Level 2 Blas routine. */
-
-/* -- Written on 22-October-1986. */
-/* Jack Dongarra, Argonne National Lab. */
-/* Jeremy Du Croz, Nag Central Office. */
-/* Sven Hammarling, Nag Central Office. */
-/* Richard Hanson, Sandia National Labs. */
-
-
-/* .. Parameters .. */
-/* .. Local Scalars .. */
-/* .. External Functions .. */
-/* .. External Subroutines .. */
-/* .. Intrinsic Functions .. */
-/* .. */
-/* .. Executable Statements .. */
-
-/* Test the input parameters. */
-
- /* Parameter adjustments */
- a_dim1 = *lda;
- a_offset = 1 + a_dim1 * 1;
- a -= a_offset;
- --x;
- --y;
-
- /* Function Body */
- info = 0;
- if (! lsame_(uplo, "U", (ftnlen)1, (ftnlen)1) && ! lsame_(uplo, "L", (
- ftnlen)1, (ftnlen)1)) {
- info = 1;
- } else if (*n < 0) {
- info = 2;
- } else if (*lda < max(1,*n)) {
- info = 5;
- } else if (*incx == 0) {
- info = 7;
- } else if (*incy == 0) {
- info = 10;
- }
- if (info != 0) {
- xerbla_("SSYMV ", &info, (ftnlen)6);
- return 0;
- }
-
-/* Quick return if possible. */
-
- if (*n == 0 || *alpha == 0.f && *beta == 1.f) {
- return 0;
- }
-
-/* Set up the start points in X and Y. */
-
- if (*incx > 0) {
- kx = 1;
- } else {
- kx = 1 - (*n - 1) * *incx;
- }
- if (*incy > 0) {
- ky = 1;
- } else {
- ky = 1 - (*n - 1) * *incy;
- }
-
-/* Start the operations. In this version the elements of A are */
-/* accessed sequentially with one pass through the triangular part */
-/* of A. */
-
-/* First form y := beta*y. */
-
- if (*beta != 1.f) {
- if (*incy == 1) {
- if (*beta == 0.f) {
- i__1 = *n;
- for (i__ = 1; i__ <= i__1; ++i__) {
- y[i__] = 0.f;
-/* L10: */
- }
- } else {
- i__1 = *n;
- for (i__ = 1; i__ <= i__1; ++i__) {
- y[i__] = *beta * y[i__];
-/* L20: */
- }
- }
- } else {
- iy = ky;
- if (*beta == 0.f) {
- i__1 = *n;
- for (i__ = 1; i__ <= i__1; ++i__) {
- y[iy] = 0.f;
- iy += *incy;
-/* L30: */
- }
- } else {
- i__1 = *n;
- for (i__ = 1; i__ <= i__1; ++i__) {
- y[iy] = *beta * y[iy];
- iy += *incy;
-/* L40: */
- }
- }
- }
- }
- if (*alpha == 0.f) {
- return 0;
- }
- if (lsame_(uplo, "U", (ftnlen)1, (ftnlen)1)) {
-
-/* Form y when A is stored in upper triangle. */
-
- if (*incx == 1 && *incy == 1) {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- temp1 = *alpha * x[j];
- temp2 = 0.f;
- i__2 = j - 1;
- for (i__ = 1; i__ <= i__2; ++i__) {
- y[i__] += temp1 * a[i__ + j * a_dim1];
- temp2 += a[i__ + j * a_dim1] * x[i__];
-/* L50: */
- }
- y[j] = y[j] + temp1 * a[j + j * a_dim1] + *alpha * temp2;
-/* L60: */
- }
- } else {
- jx = kx;
- jy = ky;
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- temp1 = *alpha * x[jx];
- temp2 = 0.f;
- ix = kx;
- iy = ky;
- i__2 = j - 1;
- for (i__ = 1; i__ <= i__2; ++i__) {
- y[iy] += temp1 * a[i__ + j * a_dim1];
- temp2 += a[i__ + j * a_dim1] * x[ix];
- ix += *incx;
- iy += *incy;
-/* L70: */
- }
- y[jy] = y[jy] + temp1 * a[j + j * a_dim1] + *alpha * temp2;
- jx += *incx;
- jy += *incy;
-/* L80: */
- }
- }
- } else {
-
-/* Form y when A is stored in lower triangle. */
-
- if (*incx == 1 && *incy == 1) {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- temp1 = *alpha * x[j];
- temp2 = 0.f;
- y[j] += temp1 * a[j + j * a_dim1];
- i__2 = *n;
- for (i__ = j + 1; i__ <= i__2; ++i__) {
- y[i__] += temp1 * a[i__ + j * a_dim1];
- temp2 += a[i__ + j * a_dim1] * x[i__];
-/* L90: */
- }
- y[j] += *alpha * temp2;
-/* L100: */
- }
- } else {
- jx = kx;
- jy = ky;
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- temp1 = *alpha * x[jx];
- temp2 = 0.f;
- y[jy] += temp1 * a[j + j * a_dim1];
- ix = jx;
- iy = jy;
- i__2 = *n;
- for (i__ = j + 1; i__ <= i__2; ++i__) {
- ix += *incx;
- iy += *incy;
- y[iy] += temp1 * a[i__ + j * a_dim1];
- temp2 += a[i__ + j * a_dim1] * x[ix];
-/* L110: */
- }
- y[jy] += *alpha * temp2;
- jx += *incx;
- jy += *incy;
-/* L120: */
- }
- }
- }
-
- return 0;
-
-/* End of SSYMV . */
-
-} /* ssymv_ */
-
-/* Subroutine */ int ssyr_(char *uplo, integer *n, real *alpha, real *x,
- integer *incx, real *a, integer *lda, ftnlen uplo_len)
-{
- /* System generated locals */
- integer a_dim1, a_offset, i__1, i__2;
-
- /* Local variables */
- static integer i__, j, ix, jx, kx, info;
- static real temp;
- extern logical lsame_(char *, char *, ftnlen, ftnlen);
- extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen);
-
-/* .. Scalar Arguments .. */
-/* .. Array Arguments .. */
-/* .. */
-
-/* Purpose */
-/* ======= */
-
-/* SSYR performs the symmetric rank 1 operation */
-
-/* A := alpha*x*x' + A, */
-
-/* where alpha is a real scalar, x is an n element vector and A is an */
-/* n by n symmetric matrix. */
-
-/* Parameters */
-/* ========== */
-
-/* UPLO - CHARACTER*1. */
-/* On entry, UPLO specifies whether the upper or lower */
-/* triangular part of the array A is to be referenced as */
-/* follows: */
-
-/* UPLO = 'U' or 'u' Only the upper triangular part of A */
-/* is to be referenced. */
-
-/* UPLO = 'L' or 'l' Only the lower triangular part of A */
-/* is to be referenced. */
-
-/* Unchanged on exit. */
-
-/* N - INTEGER. */
-/* On entry, N specifies the order of the matrix A. */
-/* N must be at least zero. */
-/* Unchanged on exit. */
-
-/* ALPHA - REAL . */
-/* On entry, ALPHA specifies the scalar alpha. */
-/* Unchanged on exit. */
-
-/* X - REAL array of dimension at least */
-/* ( 1 + ( n - 1 )*abs( INCX ) ). */
-/* Before entry, the incremented array X must contain the n */
-/* element vector x. */
-/* Unchanged on exit. */
-
-/* INCX - INTEGER. */
-/* On entry, INCX specifies the increment for the elements of */
-/* X. INCX must not be zero. */
-/* Unchanged on exit. */
-
-/* A - REAL array of DIMENSION ( LDA, n ). */
-/* Before entry with UPLO = 'U' or 'u', the leading n by n */
-/* upper triangular part of the array A must contain the upper */
-/* triangular part of the symmetric matrix and the strictly */
-/* lower triangular part of A is not referenced. On exit, the */
-/* upper triangular part of the array A is overwritten by the */
-/* upper triangular part of the updated matrix. */
-/* Before entry with UPLO = 'L' or 'l', the leading n by n */
-/* lower triangular part of the array A must contain the lower */
-/* triangular part of the symmetric matrix and the strictly */
-/* upper triangular part of A is not referenced. On exit, the */
-/* lower triangular part of the array A is overwritten by the */
-/* lower triangular part of the updated matrix. */
-
-/* LDA - INTEGER. */
-/* On entry, LDA specifies the first dimension of A as declared */
-/* in the calling (sub) program. LDA must be at least */
-/* max( 1, n ). */
-/* Unchanged on exit. */
-
-
-/* Level 2 Blas routine. */
-
-/* -- Written on 22-October-1986. */
-/* Jack Dongarra, Argonne National Lab. */
-/* Jeremy Du Croz, Nag Central Office. */
-/* Sven Hammarling, Nag Central Office. */
-/* Richard Hanson, Sandia National Labs. */
-
-
-/* .. Parameters .. */
-/* .. Local Scalars .. */
-/* .. External Functions .. */
-/* .. External Subroutines .. */
-/* .. Intrinsic Functions .. */
-/* .. */
-/* .. Executable Statements .. */
-
-/* Test the input parameters. */
-
- /* Parameter adjustments */
- --x;
- a_dim1 = *lda;
- a_offset = 1 + a_dim1 * 1;
- a -= a_offset;
-
- /* Function Body */
- info = 0;
- if (! lsame_(uplo, "U", (ftnlen)1, (ftnlen)1) && ! lsame_(uplo, "L", (
- ftnlen)1, (ftnlen)1)) {
- info = 1;
- } else if (*n < 0) {
- info = 2;
- } else if (*incx == 0) {
- info = 5;
- } else if (*lda < max(1,*n)) {
- info = 7;
- }
- if (info != 0) {
- xerbla_("SSYR ", &info, (ftnlen)6);
- return 0;
- }
-
-/* Quick return if possible. */
-
- if (*n == 0 || *alpha == 0.f) {
- return 0;
- }
-
-/* Set the start point in X if the increment is not unity. */
-
- if (*incx <= 0) {
- kx = 1 - (*n - 1) * *incx;
- } else if (*incx != 1) {
- kx = 1;
- }
-
-/* Start the operations. In this version the elements of A are */
-/* accessed sequentially with one pass through the triangular part */
-/* of A. */
-
- if (lsame_(uplo, "U", (ftnlen)1, (ftnlen)1)) {
-
-/* Form A when A is stored in upper triangle. */
-
- if (*incx == 1) {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- if (x[j] != 0.f) {
- temp = *alpha * x[j];
- i__2 = j;
- for (i__ = 1; i__ <= i__2; ++i__) {
- a[i__ + j * a_dim1] += x[i__] * temp;
-/* L10: */
- }
- }
-/* L20: */
- }
- } else {
- jx = kx;
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- if (x[jx] != 0.f) {
- temp = *alpha * x[jx];
- ix = kx;
- i__2 = j;
- for (i__ = 1; i__ <= i__2; ++i__) {
- a[i__ + j * a_dim1] += x[ix] * temp;
- ix += *incx;
-/* L30: */
- }
- }
- jx += *incx;
-/* L40: */
- }
- }
- } else {
-
-/* Form A when A is stored in lower triangle. */
-
- if (*incx == 1) {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- if (x[j] != 0.f) {
- temp = *alpha * x[j];
- i__2 = *n;
- for (i__ = j; i__ <= i__2; ++i__) {
- a[i__ + j * a_dim1] += x[i__] * temp;
-/* L50: */
- }
- }
-/* L60: */
- }
- } else {
- jx = kx;
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- if (x[jx] != 0.f) {
- temp = *alpha * x[jx];
- ix = jx;
- i__2 = *n;
- for (i__ = j; i__ <= i__2; ++i__) {
- a[i__ + j * a_dim1] += x[ix] * temp;
- ix += *incx;
-/* L70: */
- }
- }
- jx += *incx;
-/* L80: */
- }
- }
- }
-
- return 0;
-
-/* End of SSYR . */
-
-} /* ssyr_ */
-
-/* Subroutine */ int ssyr2_(char *uplo, integer *n, real *alpha, real *x,
- integer *incx, real *y, integer *incy, real *a, integer *lda, ftnlen
- uplo_len)
-{
- /* System generated locals */
- integer a_dim1, a_offset, i__1, i__2;
-
- /* Local variables */
- static integer i__, j, ix, iy, jx, jy, kx, ky, info;
- static real temp1, temp2;
- extern logical lsame_(char *, char *, ftnlen, ftnlen);
- extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen);
-
-/* .. Scalar Arguments .. */
-/* .. Array Arguments .. */
-/* .. */
-
-/* Purpose */
-/* ======= */
-
-/* SSYR2 performs the symmetric rank 2 operation */
-
-/* A := alpha*x*y' + alpha*y*x' + A, */
-
-/* where alpha is a scalar, x and y are n element vectors and A is an n */
-/* by n symmetric matrix. */
-
-/* Parameters */
-/* ========== */
-
-/* UPLO - CHARACTER*1. */
-/* On entry, UPLO specifies whether the upper or lower */
-/* triangular part of the array A is to be referenced as */
-/* follows: */
-
-/* UPLO = 'U' or 'u' Only the upper triangular part of A */
-/* is to be referenced. */
-
-/* UPLO = 'L' or 'l' Only the lower triangular part of A */
-/* is to be referenced. */
-
-/* Unchanged on exit. */
-
-/* N - INTEGER. */
-/* On entry, N specifies the order of the matrix A. */
-/* N must be at least zero. */
-/* Unchanged on exit. */
-
-/* ALPHA - REAL . */
-/* On entry, ALPHA specifies the scalar alpha. */
-/* Unchanged on exit. */
-
-/* X - REAL array of dimension at least */
-/* ( 1 + ( n - 1 )*abs( INCX ) ). */
-/* Before entry, the incremented array X must contain the n */
-/* element vector x. */
-/* Unchanged on exit. */
-
-/* INCX - INTEGER. */
-/* On entry, INCX specifies the increment for the elements of */
-/* X. INCX must not be zero. */
-/* Unchanged on exit. */
-
-/* Y - REAL array of dimension at least */
-/* ( 1 + ( n - 1 )*abs( INCY ) ). */
-/* Before entry, the incremented array Y must contain the n */
-/* element vector y. */
-/* Unchanged on exit. */
-
-/* INCY - INTEGER. */
-/* On entry, INCY specifies the increment for the elements of */
-/* Y. INCY must not be zero. */
-/* Unchanged on exit. */
-
-/* A - REAL array of DIMENSION ( LDA, n ). */
-/* Before entry with UPLO = 'U' or 'u', the leading n by n */
-/* upper triangular part of the array A must contain the upper */
-/* triangular part of the symmetric matrix and the strictly */
-/* lower triangular part of A is not referenced. On exit, the */
-/* upper triangular part of the array A is overwritten by the */
-/* upper triangular part of the updated matrix. */
-/* Before entry with UPLO = 'L' or 'l', the leading n by n */
-/* lower triangular part of the array A must contain the lower */
-/* triangular part of the symmetric matrix and the strictly */
-/* upper triangular part of A is not referenced. On exit, the */
-/* lower triangular part of the array A is overwritten by the */
-/* lower triangular part of the updated matrix. */
-
-/* LDA - INTEGER. */
-/* On entry, LDA specifies the first dimension of A as declared */
-/* in the calling (sub) program. LDA must be at least */
-/* max( 1, n ). */
-/* Unchanged on exit. */
-
-
-/* Level 2 Blas routine. */
-
-/* -- Written on 22-October-1986. */
-/* Jack Dongarra, Argonne National Lab. */
-/* Jeremy Du Croz, Nag Central Office. */
-/* Sven Hammarling, Nag Central Office. */
-/* Richard Hanson, Sandia National Labs. */
-
-
-/* .. Parameters .. */
-/* .. Local Scalars .. */
-/* .. External Functions .. */
-/* .. External Subroutines .. */
-/* .. Intrinsic Functions .. */
-/* .. */
-/* .. Executable Statements .. */
-
-/* Test the input parameters. */
-
- /* Parameter adjustments */
- --x;
- --y;
- a_dim1 = *lda;
- a_offset = 1 + a_dim1 * 1;
- a -= a_offset;
-
- /* Function Body */
- info = 0;
- if (! lsame_(uplo, "U", (ftnlen)1, (ftnlen)1) && ! lsame_(uplo, "L", (
- ftnlen)1, (ftnlen)1)) {
- info = 1;
- } else if (*n < 0) {
- info = 2;
- } else if (*incx == 0) {
- info = 5;
- } else if (*incy == 0) {
- info = 7;
- } else if (*lda < max(1,*n)) {
- info = 9;
- }
- if (info != 0) {
- xerbla_("SSYR2 ", &info, (ftnlen)6);
- return 0;
- }
-
-/* Quick return if possible. */
-
- if (*n == 0 || *alpha == 0.f) {
- return 0;
- }
-
-/* Set up the start points in X and Y if the increments are not both */
-/* unity. */
-
- if (*incx != 1 || *incy != 1) {
- if (*incx > 0) {
- kx = 1;
- } else {
- kx = 1 - (*n - 1) * *incx;
- }
- if (*incy > 0) {
- ky = 1;
- } else {
- ky = 1 - (*n - 1) * *incy;
- }
- jx = kx;
- jy = ky;
- }
-
-/* Start the operations. In this version the elements of A are */
-/* accessed sequentially with one pass through the triangular part */
-/* of A. */
-
- if (lsame_(uplo, "U", (ftnlen)1, (ftnlen)1)) {
-
-/* Form A when A is stored in the upper triangle. */
-
- if (*incx == 1 && *incy == 1) {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- if (x[j] != 0.f || y[j] != 0.f) {
- temp1 = *alpha * y[j];
- temp2 = *alpha * x[j];
- i__2 = j;
- for (i__ = 1; i__ <= i__2; ++i__) {
- a[i__ + j * a_dim1] = a[i__ + j * a_dim1] + x[i__] *
- temp1 + y[i__] * temp2;
-/* L10: */
- }
- }
-/* L20: */
- }
- } else {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- if (x[jx] != 0.f || y[jy] != 0.f) {
- temp1 = *alpha * y[jy];
- temp2 = *alpha * x[jx];
- ix = kx;
- iy = ky;
- i__2 = j;
- for (i__ = 1; i__ <= i__2; ++i__) {
- a[i__ + j * a_dim1] = a[i__ + j * a_dim1] + x[ix] *
- temp1 + y[iy] * temp2;
- ix += *incx;
- iy += *incy;
-/* L30: */
- }
- }
- jx += *incx;
- jy += *incy;
-/* L40: */
- }
- }
- } else {
-
-/* Form A when A is stored in the lower triangle. */
-
- if (*incx == 1 && *incy == 1) {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- if (x[j] != 0.f || y[j] != 0.f) {
- temp1 = *alpha * y[j];
- temp2 = *alpha * x[j];
- i__2 = *n;
- for (i__ = j; i__ <= i__2; ++i__) {
- a[i__ + j * a_dim1] = a[i__ + j * a_dim1] + x[i__] *
- temp1 + y[i__] * temp2;
-/* L50: */
- }
- }
-/* L60: */
- }
- } else {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- if (x[jx] != 0.f || y[jy] != 0.f) {
- temp1 = *alpha * y[jy];
- temp2 = *alpha * x[jx];
- ix = jx;
- iy = jy;
- i__2 = *n;
- for (i__ = j; i__ <= i__2; ++i__) {
- a[i__ + j * a_dim1] = a[i__ + j * a_dim1] + x[ix] *
- temp1 + y[iy] * temp2;
- ix += *incx;
- iy += *incy;
-/* L70: */
- }
- }
- jx += *incx;
- jy += *incy;
-/* L80: */
- }
- }
- }
-
- return 0;
-
-/* End of SSYR2 . */
-
-} /* ssyr2_ */
-
-/* Subroutine */ int ssyr2k_(char *uplo, char *trans, integer *n, integer *k,
- real *alpha, real *a, integer *lda, real *b, integer *ldb, real *beta,
- real *c__, integer *ldc, ftnlen uplo_len, ftnlen trans_len)
-{
- /* System generated locals */
- integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2,
- i__3;
-
- /* Local variables */
- static integer i__, j, l, info;
- static real temp1, temp2;
- extern logical lsame_(char *, char *, ftnlen, ftnlen);
- static integer nrowa;
- static logical upper;
- extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen);
-
-/* .. Scalar Arguments .. */
-/* .. Array Arguments .. */
-/* .. */
-
-/* Purpose */
-/* ======= */
-
-/* SSYR2K performs one of the symmetric rank 2k operations */
-
-/* C := alpha*A*B' + alpha*B*A' + beta*C, */
-
-/* or */
-
-/* C := alpha*A'*B + alpha*B'*A + beta*C, */
-
-/* where alpha and beta are scalars, C is an n by n symmetric matrix */
-/* and A and B are n by k matrices in the first case and k by n */
-/* matrices in the second case. */
-
-/* Parameters */
-/* ========== */
-
-/* UPLO - CHARACTER*1. */
-/* On entry, UPLO specifies whether the upper or lower */
-/* triangular part of the array C is to be referenced as */
-/* follows: */
-
-/* UPLO = 'U' or 'u' Only the upper triangular part of C */
-/* is to be referenced. */
-
-/* UPLO = 'L' or 'l' Only the lower triangular part of C */
-/* is to be referenced. */
-
-/* Unchanged on exit. */
-
-/* TRANS - CHARACTER*1. */
-/* On entry, TRANS specifies the operation to be performed as */
-/* follows: */
-
-/* TRANS = 'N' or 'n' C := alpha*A*B' + alpha*B*A' + */
-/* beta*C. */
-
-/* TRANS = 'T' or 't' C := alpha*A'*B + alpha*B'*A + */
-/* beta*C. */
-
-/* TRANS = 'C' or 'c' C := alpha*A'*B + alpha*B'*A + */
-/* beta*C. */
-
-/* Unchanged on exit. */
-
-/* N - INTEGER. */
-/* On entry, N specifies the order of the matrix C. N must be */
-/* at least zero. */
-/* Unchanged on exit. */
-
-/* K - INTEGER. */
-/* On entry with TRANS = 'N' or 'n', K specifies the number */
-/* of columns of the matrices A and B, and on entry with */
-/* TRANS = 'T' or 't' or 'C' or 'c', K specifies the number */
-/* of rows of the matrices A and B. K must be at least zero. */
-/* Unchanged on exit. */
-
-/* ALPHA - REAL . */
-/* On entry, ALPHA specifies the scalar alpha. */
-/* Unchanged on exit. */
-
-/* A - REAL array of DIMENSION ( LDA, ka ), where ka is */
-/* k when TRANS = 'N' or 'n', and is n otherwise. */
-/* Before entry with TRANS = 'N' or 'n', the leading n by k */
-/* part of the array A must contain the matrix A, otherwise */
-/* the leading k by n part of the array A must contain the */
-/* matrix A. */
-/* Unchanged on exit. */
-
-/* LDA - INTEGER. */
-/* On entry, LDA specifies the first dimension of A as declared */
-/* in the calling (sub) program. When TRANS = 'N' or 'n' */
-/* then LDA must be at least max( 1, n ), otherwise LDA must */
-/* be at least max( 1, k ). */
-/* Unchanged on exit. */
-
-/* B - REAL array of DIMENSION ( LDB, kb ), where kb is */
-/* k when TRANS = 'N' or 'n', and is n otherwise. */
-/* Before entry with TRANS = 'N' or 'n', the leading n by k */
-/* part of the array B must contain the matrix B, otherwise */
-/* the leading k by n part of the array B must contain the */
-/* matrix B. */
-/* Unchanged on exit. */
-
-/* LDB - INTEGER. */
-/* On entry, LDB specifies the first dimension of B as declared */
-/* in the calling (sub) program. When TRANS = 'N' or 'n' */
-/* then LDB must be at least max( 1, n ), otherwise LDB must */
-/* be at least max( 1, k ). */
-/* Unchanged on exit. */
-
-/* BETA - REAL . */
-/* On entry, BETA specifies the scalar beta. */
-/* Unchanged on exit. */
-
-/* C - REAL array of DIMENSION ( LDC, n ). */
-/* Before entry with UPLO = 'U' or 'u', the leading n by n */
-/* upper triangular part of the array C must contain the upper */
-/* triangular part of the symmetric matrix and the strictly */
-/* lower triangular part of C is not referenced. On exit, the */
-/* upper triangular part of the array C is overwritten by the */
-/* upper triangular part of the updated matrix. */
-/* Before entry with UPLO = 'L' or 'l', the leading n by n */
-/* lower triangular part of the array C must contain the lower */
-/* triangular part of the symmetric matrix and the strictly */
-/* upper triangular part of C is not referenced. On exit, the */
-/* lower triangular part of the array C is overwritten by the */
-/* lower triangular part of the updated matrix. */
-
-/* LDC - INTEGER. */
-/* On entry, LDC specifies the first dimension of C as declared */
-/* in the calling (sub) program. LDC must be at least */
-/* max( 1, n ). */
-/* Unchanged on exit. */
-
-
-/* Level 3 Blas routine. */
-
-
-/* -- Written on 8-February-1989. */
-/* Jack Dongarra, Argonne National Laboratory. */
-/* Iain Duff, AERE Harwell. */
-/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */
-/* Sven Hammarling, Numerical Algorithms Group Ltd. */
-
-
-/* .. External Functions .. */
-/* .. External Subroutines .. */
-/* .. Intrinsic Functions .. */
-/* .. Local Scalars .. */
-/* .. Parameters .. */
-/* .. */
-/* .. Executable Statements .. */
-
-/* Test the input parameters. */
-
- /* Parameter adjustments */
- a_dim1 = *lda;
- a_offset = 1 + a_dim1 * 1;
- a -= a_offset;
- b_dim1 = *ldb;
- b_offset = 1 + b_dim1 * 1;
- b -= b_offset;
- c_dim1 = *ldc;
- c_offset = 1 + c_dim1 * 1;
- c__ -= c_offset;
-
- /* Function Body */
- if (lsame_(trans, "N", (ftnlen)1, (ftnlen)1)) {
- nrowa = *n;
- } else {
- nrowa = *k;
- }
- upper = lsame_(uplo, "U", (ftnlen)1, (ftnlen)1);
-
- info = 0;
- if (! upper && ! lsame_(uplo, "L", (ftnlen)1, (ftnlen)1)) {
- info = 1;
- } else if (! lsame_(trans, "N", (ftnlen)1, (ftnlen)1) && ! lsame_(trans,
- "T", (ftnlen)1, (ftnlen)1) && ! lsame_(trans, "C", (ftnlen)1, (
- ftnlen)1)) {
- info = 2;
- } else if (*n < 0) {
- info = 3;
- } else if (*k < 0) {
- info = 4;
- } else if (*lda < max(1,nrowa)) {
- info = 7;
- } else if (*ldb < max(1,nrowa)) {
- info = 9;
- } else if (*ldc < max(1,*n)) {
- info = 12;
- }
- if (info != 0) {
- xerbla_("SSYR2K", &info, (ftnlen)6);
- return 0;
- }
-
-/* Quick return if possible. */
-
- if (*n == 0 || (*alpha == 0.f || *k == 0) && *beta == 1.f) {
- return 0;
- }
-
-/* And when alpha.eq.zero. */
-
- if (*alpha == 0.f) {
- if (upper) {
- if (*beta == 0.f) {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- i__2 = j;
- for (i__ = 1; i__ <= i__2; ++i__) {
- c__[i__ + j * c_dim1] = 0.f;
-/* L10: */
- }
-/* L20: */
- }
- } else {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- i__2 = j;
- for (i__ = 1; i__ <= i__2; ++i__) {
- c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1];
-/* L30: */
- }
-/* L40: */
- }
- }
- } else {
- if (*beta == 0.f) {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- i__2 = *n;
- for (i__ = j; i__ <= i__2; ++i__) {
- c__[i__ + j * c_dim1] = 0.f;
-/* L50: */
- }
-/* L60: */
- }
- } else {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- i__2 = *n;
- for (i__ = j; i__ <= i__2; ++i__) {
- c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1];
-/* L70: */
- }
-/* L80: */
- }
- }
- }
- return 0;
- }
-
-/* Start the operations. */
-
- if (lsame_(trans, "N", (ftnlen)1, (ftnlen)1)) {
-
-/* Form C := alpha*A*B' + alpha*B*A' + C. */
-
- if (upper) {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- if (*beta == 0.f) {
- i__2 = j;
- for (i__ = 1; i__ <= i__2; ++i__) {
- c__[i__ + j * c_dim1] = 0.f;
-/* L90: */
- }
- } else if (*beta != 1.f) {
- i__2 = j;
- for (i__ = 1; i__ <= i__2; ++i__) {
- c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1];
-/* L100: */
- }
- }
- i__2 = *k;
- for (l = 1; l <= i__2; ++l) {
- if (a[j + l * a_dim1] != 0.f || b[j + l * b_dim1] != 0.f)
- {
- temp1 = *alpha * b[j + l * b_dim1];
- temp2 = *alpha * a[j + l * a_dim1];
- i__3 = j;
- for (i__ = 1; i__ <= i__3; ++i__) {
- c__[i__ + j * c_dim1] = c__[i__ + j * c_dim1] + a[
- i__ + l * a_dim1] * temp1 + b[i__ + l *
- b_dim1] * temp2;
-/* L110: */
- }
- }
-/* L120: */
- }
-/* L130: */
- }
- } else {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- if (*beta == 0.f) {
- i__2 = *n;
- for (i__ = j; i__ <= i__2; ++i__) {
- c__[i__ + j * c_dim1] = 0.f;
-/* L140: */
- }
- } else if (*beta != 1.f) {
- i__2 = *n;
- for (i__ = j; i__ <= i__2; ++i__) {
- c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1];
-/* L150: */
- }
- }
- i__2 = *k;
- for (l = 1; l <= i__2; ++l) {
- if (a[j + l * a_dim1] != 0.f || b[j + l * b_dim1] != 0.f)
- {
- temp1 = *alpha * b[j + l * b_dim1];
- temp2 = *alpha * a[j + l * a_dim1];
- i__3 = *n;
- for (i__ = j; i__ <= i__3; ++i__) {
- c__[i__ + j * c_dim1] = c__[i__ + j * c_dim1] + a[
- i__ + l * a_dim1] * temp1 + b[i__ + l *
- b_dim1] * temp2;
-/* L160: */
- }
- }
-/* L170: */
- }
-/* L180: */
- }
- }
- } else {
-
-/* Form C := alpha*A'*B + alpha*B'*A + C. */
-
- if (upper) {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- i__2 = j;
- for (i__ = 1; i__ <= i__2; ++i__) {
- temp1 = 0.f;
- temp2 = 0.f;
- i__3 = *k;
- for (l = 1; l <= i__3; ++l) {
- temp1 += a[l + i__ * a_dim1] * b[l + j * b_dim1];
- temp2 += b[l + i__ * b_dim1] * a[l + j * a_dim1];
-/* L190: */
- }
- if (*beta == 0.f) {
- c__[i__ + j * c_dim1] = *alpha * temp1 + *alpha *
- temp2;
- } else {
- c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1]
- + *alpha * temp1 + *alpha * temp2;
- }
-/* L200: */
- }
-/* L210: */
- }
- } else {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- i__2 = *n;
- for (i__ = j; i__ <= i__2; ++i__) {
- temp1 = 0.f;
- temp2 = 0.f;
- i__3 = *k;
- for (l = 1; l <= i__3; ++l) {
- temp1 += a[l + i__ * a_dim1] * b[l + j * b_dim1];
- temp2 += b[l + i__ * b_dim1] * a[l + j * a_dim1];
-/* L220: */
- }
- if (*beta == 0.f) {
- c__[i__ + j * c_dim1] = *alpha * temp1 + *alpha *
- temp2;
- } else {
- c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1]
- + *alpha * temp1 + *alpha * temp2;
- }
-/* L230: */
- }
-/* L240: */
- }
- }
- }
-
- return 0;
-
-/* End of SSYR2K. */
-
-} /* ssyr2k_ */
-
-/* Subroutine */ int ssyrk_(char *uplo, char *trans, integer *n, integer *k,
- real *alpha, real *a, integer *lda, real *beta, real *c__, integer *
- ldc, ftnlen uplo_len, ftnlen trans_len)
-{
- /* System generated locals */
- integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2, i__3;
-
- /* Local variables */
- static integer i__, j, l, info;
- static real temp;
- extern logical lsame_(char *, char *, ftnlen, ftnlen);
- static integer nrowa;
- static logical upper;
- extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen);
-
-/* .. Scalar Arguments .. */
-/* .. Array Arguments .. */
-/* .. */
-
-/* Purpose */
-/* ======= */
-
-/* SSYRK performs one of the symmetric rank k operations */
-
-/* C := alpha*A*A' + beta*C, */
-
-/* or */
-
-/* C := alpha*A'*A + beta*C, */
-
-/* where alpha and beta are scalars, C is an n by n symmetric matrix */
-/* and A is an n by k matrix in the first case and a k by n matrix */
-/* in the second case. */
-
-/* Parameters */
-/* ========== */
-
-/* UPLO - CHARACTER*1. */
-/* On entry, UPLO specifies whether the upper or lower */
-/* triangular part of the array C is to be referenced as */
-/* follows: */
-
-/* UPLO = 'U' or 'u' Only the upper triangular part of C */
-/* is to be referenced. */
-
-/* UPLO = 'L' or 'l' Only the lower triangular part of C */
-/* is to be referenced. */
-
-/* Unchanged on exit. */
-
-/* TRANS - CHARACTER*1. */
-/* On entry, TRANS specifies the operation to be performed as */
-/* follows: */
-
-/* TRANS = 'N' or 'n' C := alpha*A*A' + beta*C. */
-
-/* TRANS = 'T' or 't' C := alpha*A'*A + beta*C. */
-
-/* TRANS = 'C' or 'c' C := alpha*A'*A + beta*C. */
-
-/* Unchanged on exit. */
-
-/* N - INTEGER. */
-/* On entry, N specifies the order of the matrix C. N must be */
-/* at least zero. */
-/* Unchanged on exit. */
-
-/* K - INTEGER. */
-/* On entry with TRANS = 'N' or 'n', K specifies the number */
-/* of columns of the matrix A, and on entry with */
-/* TRANS = 'T' or 't' or 'C' or 'c', K specifies the number */
-/* of rows of the matrix A. K must be at least zero. */
-/* Unchanged on exit. */
-
-/* ALPHA - REAL . */
-/* On entry, ALPHA specifies the scalar alpha. */
-/* Unchanged on exit. */
-
-/* A - REAL array of DIMENSION ( LDA, ka ), where ka is */
-/* k when TRANS = 'N' or 'n', and is n otherwise. */
-/* Before entry with TRANS = 'N' or 'n', the leading n by k */
-/* part of the array A must contain the matrix A, otherwise */
-/* the leading k by n part of the array A must contain the */
-/* matrix A. */
-/* Unchanged on exit. */
-
-/* LDA - INTEGER. */
-/* On entry, LDA specifies the first dimension of A as declared */
-/* in the calling (sub) program. When TRANS = 'N' or 'n' */
-/* then LDA must be at least max( 1, n ), otherwise LDA must */
-/* be at least max( 1, k ). */
-/* Unchanged on exit. */
-
-/* BETA - REAL . */
-/* On entry, BETA specifies the scalar beta. */
-/* Unchanged on exit. */
-
-/* C - REAL array of DIMENSION ( LDC, n ). */
-/* Before entry with UPLO = 'U' or 'u', the leading n by n */
-/* upper triangular part of the array C must contain the upper */
-/* triangular part of the symmetric matrix and the strictly */
-/* lower triangular part of C is not referenced. On exit, the */
-/* upper triangular part of the array C is overwritten by the */
-/* upper triangular part of the updated matrix. */
-/* Before entry with UPLO = 'L' or 'l', the leading n by n */
-/* lower triangular part of the array C must contain the lower */
-/* triangular part of the symmetric matrix and the strictly */
-/* upper triangular part of C is not referenced. On exit, the */
-/* lower triangular part of the array C is overwritten by the */
-/* lower triangular part of the updated matrix. */
-
-/* LDC - INTEGER. */
-/* On entry, LDC specifies the first dimension of C as declared */
-/* in the calling (sub) program. LDC must be at least */
-/* max( 1, n ). */
-/* Unchanged on exit. */
-
-
-/* Level 3 Blas routine. */
-
-/* -- Written on 8-February-1989. */
-/* Jack Dongarra, Argonne National Laboratory. */
-/* Iain Duff, AERE Harwell. */
-/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */
-/* Sven Hammarling, Numerical Algorithms Group Ltd. */
-
-
-/* .. External Functions .. */
-/* .. External Subroutines .. */
-/* .. Intrinsic Functions .. */
-/* .. Local Scalars .. */
-/* .. Parameters .. */
-/* .. */
-/* .. Executable Statements .. */
-
-/* Test the input parameters. */
-
- /* Parameter adjustments */
- a_dim1 = *lda;
- a_offset = 1 + a_dim1 * 1;
- a -= a_offset;
- c_dim1 = *ldc;
- c_offset = 1 + c_dim1 * 1;
- c__ -= c_offset;
-
- /* Function Body */
- if (lsame_(trans, "N", (ftnlen)1, (ftnlen)1)) {
- nrowa = *n;
- } else {
- nrowa = *k;
- }
- upper = lsame_(uplo, "U", (ftnlen)1, (ftnlen)1);
-
- info = 0;
- if (! upper && ! lsame_(uplo, "L", (ftnlen)1, (ftnlen)1)) {
- info = 1;
- } else if (! lsame_(trans, "N", (ftnlen)1, (ftnlen)1) && ! lsame_(trans,
- "T", (ftnlen)1, (ftnlen)1) && ! lsame_(trans, "C", (ftnlen)1, (
- ftnlen)1)) {
- info = 2;
- } else if (*n < 0) {
- info = 3;
- } else if (*k < 0) {
- info = 4;
- } else if (*lda < max(1,nrowa)) {
- info = 7;
- } else if (*ldc < max(1,*n)) {
- info = 10;
- }
- if (info != 0) {
- xerbla_("SSYRK ", &info, (ftnlen)6);
- return 0;
- }
-
-/* Quick return if possible. */
-
- if (*n == 0 || (*alpha == 0.f || *k == 0) && *beta == 1.f) {
- return 0;
- }
-
-/* And when alpha.eq.zero. */
-
- if (*alpha == 0.f) {
- if (upper) {
- if (*beta == 0.f) {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- i__2 = j;
- for (i__ = 1; i__ <= i__2; ++i__) {
- c__[i__ + j * c_dim1] = 0.f;
-/* L10: */
- }
-/* L20: */
- }
- } else {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- i__2 = j;
- for (i__ = 1; i__ <= i__2; ++i__) {
- c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1];
-/* L30: */
- }
-/* L40: */
- }
- }
- } else {
- if (*beta == 0.f) {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- i__2 = *n;
- for (i__ = j; i__ <= i__2; ++i__) {
- c__[i__ + j * c_dim1] = 0.f;
-/* L50: */
- }
-/* L60: */
- }
- } else {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- i__2 = *n;
- for (i__ = j; i__ <= i__2; ++i__) {
- c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1];
-/* L70: */
- }
-/* L80: */
- }
- }
- }
- return 0;
- }
-
-/* Start the operations. */
-
- if (lsame_(trans, "N", (ftnlen)1, (ftnlen)1)) {
-
-/* Form C := alpha*A*A' + beta*C. */
-
- if (upper) {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- if (*beta == 0.f) {
- i__2 = j;
- for (i__ = 1; i__ <= i__2; ++i__) {
- c__[i__ + j * c_dim1] = 0.f;
-/* L90: */
- }
- } else if (*beta != 1.f) {
- i__2 = j;
- for (i__ = 1; i__ <= i__2; ++i__) {
- c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1];
-/* L100: */
- }
- }
- i__2 = *k;
- for (l = 1; l <= i__2; ++l) {
- if (a[j + l * a_dim1] != 0.f) {
- temp = *alpha * a[j + l * a_dim1];
- i__3 = j;
- for (i__ = 1; i__ <= i__3; ++i__) {
- c__[i__ + j * c_dim1] += temp * a[i__ + l *
- a_dim1];
-/* L110: */
- }
- }
-/* L120: */
- }
-/* L130: */
- }
- } else {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- if (*beta == 0.f) {
- i__2 = *n;
- for (i__ = j; i__ <= i__2; ++i__) {
- c__[i__ + j * c_dim1] = 0.f;
-/* L140: */
- }
- } else if (*beta != 1.f) {
- i__2 = *n;
- for (i__ = j; i__ <= i__2; ++i__) {
- c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1];
-/* L150: */
- }
- }
- i__2 = *k;
- for (l = 1; l <= i__2; ++l) {
- if (a[j + l * a_dim1] != 0.f) {
- temp = *alpha * a[j + l * a_dim1];
- i__3 = *n;
- for (i__ = j; i__ <= i__3; ++i__) {
- c__[i__ + j * c_dim1] += temp * a[i__ + l *
- a_dim1];
-/* L160: */
- }
- }
-/* L170: */
- }
-/* L180: */
- }
- }
- } else {
-
-/* Form C := alpha*A'*A + beta*C. */
-
- if (upper) {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- i__2 = j;
- for (i__ = 1; i__ <= i__2; ++i__) {
- temp = 0.f;
- i__3 = *k;
- for (l = 1; l <= i__3; ++l) {
- temp += a[l + i__ * a_dim1] * a[l + j * a_dim1];
-/* L190: */
- }
- if (*beta == 0.f) {
- c__[i__ + j * c_dim1] = *alpha * temp;
- } else {
- c__[i__ + j * c_dim1] = *alpha * temp + *beta * c__[
- i__ + j * c_dim1];
- }
-/* L200: */
- }
-/* L210: */
- }
- } else {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- i__2 = *n;
- for (i__ = j; i__ <= i__2; ++i__) {
- temp = 0.f;
- i__3 = *k;
- for (l = 1; l <= i__3; ++l) {
- temp += a[l + i__ * a_dim1] * a[l + j * a_dim1];
-/* L220: */
- }
- if (*beta == 0.f) {
- c__[i__ + j * c_dim1] = *alpha * temp;
- } else {
- c__[i__ + j * c_dim1] = *alpha * temp + *beta * c__[
- i__ + j * c_dim1];
- }
-/* L230: */
- }
-/* L240: */
- }
- }
- }
-
- return 0;
-
-/* End of SSYRK . */
-
-} /* ssyrk_ */
-
-/* Subroutine */ int stbmv_(char *uplo, char *trans, char *diag, integer *n,
- integer *k, real *a, integer *lda, real *x, integer *incx, ftnlen
- uplo_len, ftnlen trans_len, ftnlen diag_len)
-{
- /* System generated locals */
- integer a_dim1, a_offset, i__1, i__2, i__3, i__4;
-
- /* Local variables */
- static integer i__, j, l, ix, jx, kx, info;
- static real temp;
- extern logical lsame_(char *, char *, ftnlen, ftnlen);
- static integer kplus1;
- extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen);
- static logical nounit;
-
-/* .. Scalar Arguments .. */
-/* .. Array Arguments .. */
-/* .. */
-
-/* Purpose */
-/* ======= */
-
-/* STBMV performs one of the matrix-vector operations */
-
-/* x := A*x, or x := A'*x, */
-
-/* where x is an n element vector and A is an n by n unit, or non-unit, */
-/* upper or lower triangular band matrix, with ( k + 1 ) diagonals. */
-
-/* Parameters */
-/* ========== */
-
-/* UPLO - CHARACTER*1. */
-/* On entry, UPLO specifies whether the matrix is an upper or */
-/* lower triangular matrix as follows: */
-
-/* UPLO = 'U' or 'u' A is an upper triangular matrix. */
-
-/* UPLO = 'L' or 'l' A is a lower triangular matrix. */
-
-/* Unchanged on exit. */
-
-/* TRANS - CHARACTER*1. */
-/* On entry, TRANS specifies the operation to be performed as */
-/* follows: */
-
-/* TRANS = 'N' or 'n' x := A*x. */
-
-/* TRANS = 'T' or 't' x := A'*x. */
-
-/* TRANS = 'C' or 'c' x := A'*x. */
-
-/* Unchanged on exit. */
-
-/* DIAG - CHARACTER*1. */
-/* On entry, DIAG specifies whether or not A is unit */
-/* triangular as follows: */
-
-/* DIAG = 'U' or 'u' A is assumed to be unit triangular. */
-
-/* DIAG = 'N' or 'n' A is not assumed to be unit */
-/* triangular. */
-
-/* Unchanged on exit. */
-
-/* N - INTEGER. */
-/* On entry, N specifies the order of the matrix A. */
-/* N must be at least zero. */
-/* Unchanged on exit. */
-
-/* K - INTEGER. */
-/* On entry with UPLO = 'U' or 'u', K specifies the number of */
-/* super-diagonals of the matrix A. */
-/* On entry with UPLO = 'L' or 'l', K specifies the number of */
-/* sub-diagonals of the matrix A. */
-/* K must satisfy 0 .le. K. */
-/* Unchanged on exit. */
-
-/* A - REAL array of DIMENSION ( LDA, n ). */
-/* Before entry with UPLO = 'U' or 'u', the leading ( k + 1 ) */
-/* by n part of the array A must contain the upper triangular */
-/* band part of the matrix of coefficients, supplied column by */
-/* column, with the leading diagonal of the matrix in row */
-/* ( k + 1 ) of the array, the first super-diagonal starting at */
-/* position 2 in row k, and so on. The top left k by k triangle */
-/* of the array A is not referenced. */
-/* The following program segment will transfer an upper */
-/* triangular band matrix from conventional full matrix storage */
-/* to band storage: */
-
-/* DO 20, J = 1, N */
-/* M = K + 1 - J */
-/* DO 10, I = MAX( 1, J - K ), J */
-/* A( M + I, J ) = matrix( I, J ) */
-/* 10 CONTINUE */
-/* 20 CONTINUE */
-
-/* Before entry with UPLO = 'L' or 'l', the leading ( k + 1 ) */
-/* by n part of the array A must contain the lower triangular */
-/* band part of the matrix of coefficients, supplied column by */
-/* column, with the leading diagonal of the matrix in row 1 of */
-/* the array, the first sub-diagonal starting at position 1 in */
-/* row 2, and so on. The bottom right k by k triangle of the */
-/* array A is not referenced. */
-/* The following program segment will transfer a lower */
-/* triangular band matrix from conventional full matrix storage */
-/* to band storage: */
-
-/* DO 20, J = 1, N */
-/* M = 1 - J */
-/* DO 10, I = J, MIN( N, J + K ) */
-/* A( M + I, J ) = matrix( I, J ) */
-/* 10 CONTINUE */
-/* 20 CONTINUE */
-
-/* Note that when DIAG = 'U' or 'u' the elements of the array A */
-/* corresponding to the diagonal elements of the matrix are not */
-/* referenced, but are assumed to be unity. */
-/* Unchanged on exit. */
-
-/* LDA - INTEGER. */
-/* On entry, LDA specifies the first dimension of A as declared */
-/* in the calling (sub) program. LDA must be at least */
-/* ( k + 1 ). */
-/* Unchanged on exit. */
-
-/* X - REAL array of dimension at least */
-/* ( 1 + ( n - 1 )*abs( INCX ) ). */
-/* Before entry, the incremented array X must contain the n */
-/* element vector x. On exit, X is overwritten with the */
-/* tranformed vector x. */
-
-/* INCX - INTEGER. */
-/* On entry, INCX specifies the increment for the elements of */
-/* X. INCX must not be zero. */
-/* Unchanged on exit. */
-
-
-/* Level 2 Blas routine. */
-
-/* -- Written on 22-October-1986. */
-/* Jack Dongarra, Argonne National Lab. */
-/* Jeremy Du Croz, Nag Central Office. */
-/* Sven Hammarling, Nag Central Office. */
-/* Richard Hanson, Sandia National Labs. */
-
-
-/* .. Parameters .. */
-/* .. Local Scalars .. */
-/* .. External Functions .. */
-/* .. External Subroutines .. */
-/* .. Intrinsic Functions .. */
-/* .. */
-/* .. Executable Statements .. */
-
-/* Test the input parameters. */
-
- /* Parameter adjustments */
- a_dim1 = *lda;
- a_offset = 1 + a_dim1 * 1;
- a -= a_offset;
- --x;
-
- /* Function Body */
- info = 0;
- if (! lsame_(uplo, "U", (ftnlen)1, (ftnlen)1) && ! lsame_(uplo, "L", (
- ftnlen)1, (ftnlen)1)) {
- info = 1;
- } else if (! lsame_(trans, "N", (ftnlen)1, (ftnlen)1) && ! lsame_(trans,
- "T", (ftnlen)1, (ftnlen)1) && ! lsame_(trans, "C", (ftnlen)1, (
- ftnlen)1)) {
- info = 2;
- } else if (! lsame_(diag, "U", (ftnlen)1, (ftnlen)1) && ! lsame_(diag,
- "N", (ftnlen)1, (ftnlen)1)) {
- info = 3;
- } else if (*n < 0) {
- info = 4;
- } else if (*k < 0) {
- info = 5;
- } else if (*lda < *k + 1) {
- info = 7;
- } else if (*incx == 0) {
- info = 9;
- }
- if (info != 0) {
- xerbla_("STBMV ", &info, (ftnlen)6);
- return 0;
- }
-
-/* Quick return if possible. */
-
- if (*n == 0) {
- return 0;
- }
-
- nounit = lsame_(diag, "N", (ftnlen)1, (ftnlen)1);
-
-/* Set up the start point in X if the increment is not unity. This */
-/* will be ( N - 1 )*INCX too small for descending loops. */
-
- if (*incx <= 0) {
- kx = 1 - (*n - 1) * *incx;
- } else if (*incx != 1) {
- kx = 1;
- }
-
-/* Start the operations. In this version the elements of A are */
-/* accessed sequentially with one pass through A. */
-
- if (lsame_(trans, "N", (ftnlen)1, (ftnlen)1)) {
-
-/* Form x := A*x. */
-
- if (lsame_(uplo, "U", (ftnlen)1, (ftnlen)1)) {
- kplus1 = *k + 1;
- if (*incx == 1) {
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- if (x[j] != 0.f) {
- temp = x[j];
- l = kplus1 - j;
-/* Computing MAX */
- i__2 = 1, i__3 = j - *k;
- i__4 = j - 1;
- for (i__ = max(i__2,i__3); i__ <= i__4; ++i__) {
- x[i__] += temp * a[l + i__ + j * a_dim1];
-/* L10: */
- }
- if (nounit) {
- x[j] *= a[kplus1 + j * a_dim1];
- }
- }
-/* L20: */
- }
- } else {
- jx = kx;
- i__1 = *n;
- for (j = 1; j <= i__1; ++j) {
- if (x[jx] != 0.f) {
- temp = x[jx];
- ix = kx;
- l = kplus1 - j;
-/* Computing MAX */
- i__4 = 1, i__2 = j - *k;
- i__3 = j - 1;
- for (i__ = max(i__4,i__2); i__ <= i__3; ++i__) {
- x[ix] += temp * a[l + i__ + j * a_dim1];
- ix += *incx;
-/* L30: */
- }
- if (nounit) {
- x[jx] *= a[kplus1 + j * a_dim1];
- }
- }
- jx += *incx;
- if (j > *k) {
- kx += *incx;
- }
-/* L40: */
- }
- }
- } else {
- if (*incx == 1) {
- for (j = *n; j >= 1; --j) {
- if (x[j] != 0.f) {
- temp = x[j];
- l = 1 - j;
-/* Computing MIN */
- i__1 = *n, i__3 = j + *k;
- i__4 = j + 1;
- for (i__ = min(i__1,i__3); i__ >= i__4; --i__) {
- x[i__] += temp * a[l + i__ + j * a_dim1];
-/* L50: */
- }
- if (nounit) {
- x[j] *= a[j * a_dim1 + 1];
- }
- }
-/* L60: */
- }
- } else {
- kx += (*n - 1) * *incx;
- jx = kx;
- for (j = *n; j >= 1; --j) {
- if (x[jx] != 0.f) {
- temp = x[jx];
- ix = kx;
- l = 1 - j;
-/* Computing MIN */
- i__4 = *n, i__1 = j + *k;
- i__3 = j + 1;
- for (i__ = min(i__4,i__1); i__ >= i__3; --i__) {
- x[ix] += temp * a[l + i__ + j * a_dim1];
- ix -= *incx;
-/* L70: */
- }
- if (nounit) {
- x[jx] *= a[j * a_dim1 + 1];
- }
- }
- jx -= *incx;
- if (*n - j >= *k) {
- kx -= *incx;
- }
-/* L80: */
- }
- }
- }
- } else {
-
-/* Form x := A'*x. */
-
- if (lsame_(uplo, "U", (ftnlen)1, (ftnlen)1)) {
- kplus1 = *k + 1;
- if (*incx == 1) {
- for (j = *n; j >= 1; --j) {
- temp = x[j];
- l = kplus1