diff options
Diffstat (limited to 'src/lib')
80 files changed, 0 insertions, 17144 deletions
diff --git a/src/lib/blas/Makefile.am b/src/lib/blas/Makefile.am deleted file mode 100644 index 6b8b83de..00000000 --- a/src/lib/blas/Makefile.am +++ /dev/null @@ -1,86 +0,0 @@ -########## -### Sylvestre Ledru <sylvestre.ledru@inria.fr> -### INRIA - Scilab 2006 -########## - -BLAS_FORTRAN_SOURCES = zrotg.f \ -zhpr2.f \ -zher2k.f \ -dspr.f \ -xerbla.f \ -dcopy.f \ -dsyr2k.f \ -zsymm.f \ -zhemm.f \ -dtbsv.f \ -dtrmm.f \ -dscal.f \ -ddot.f \ -dgbmv.f \ -dtpsv.f \ -dtrsv.f \ -dgemv.f \ -idamax.f \ -dzasum.f \ -zcopy.f \ -zher.f \ -drot.f \ -ztbsv.f \ -dasum.f \ -ztrmm.f \ -dsbmv.f \ -zscal.f \ -dswap.f \ -zdotc.f \ -zgbmv.f \ -ztpsv.f \ -zgemv.f \ -ztrsv.f \ -izamax.f \ -dspmv.f \ -dcabs1.f \ -dsymv.f \ -zswap.f \ -zdotu.f \ -zgerc.f \ -dznrm2.f \ -dtbmv.f \ -zdscal.f \ -dger.f \ -dnrm2.f \ -zhpr.f \ -daxpy.f \ -zhbmv.f \ -zhemv.f \ -dtrsm.f \ -dgemm.f \ -dspr2.f \ -dtpmv.f \ -zgeru.f \ -dtrmv.f \ -dsyrk.f \ -lsame.f \ -ztbmv.f \ -dsyr2.f \ -zhpmv.f \ -zsyr2k.f \ -zaxpy.f \ -zgemm.f \ -drotg.f \ -ztrsm.f \ -ztpmv.f \ -dsyr.f \ -zsyrk.f \ -ztrmv.f \ -zherk.f \ -dsymm.f \ -zher2.f - -instdir = $(top_builddir)/lib - -pkglib_LTLIBRARIES = libsciblas.la - -HEAD = $(top_builddir)/includes/blas.h - -libsciblas_la_SOURCES = $(HEAD) $(BLAS_FORTRAN_SOURCES) - diff --git a/src/lib/blas/Makefile.in b/src/lib/blas/Makefile.in deleted file mode 100644 index 05f78eab..00000000 --- a/src/lib/blas/Makefile.in +++ /dev/null @@ -1,545 +0,0 @@ -# Makefile.in generated by automake 1.10.1 from Makefile.am. -# @configure_input@ - -# Copyright (C) 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, -# 2003, 2004, 2005, 2006, 2007, 2008 Free Software Foundation, Inc. -# This Makefile.in is free software; the Free Software Foundation -# gives unlimited permission to copy and/or distribute it, -# with or without modifications, as long as this notice is preserved. - -# This program is distributed in the hope that it will be useful, -# but WITHOUT ANY WARRANTY, to the extent permitted by law; without -# even the implied warranty of MERCHANTABILITY or FITNESS FOR A -# PARTICULAR PURPOSE. - -@SET_MAKE@ - -########## -### Sylvestre Ledru <sylvestre.ledru@inria.fr> -### INRIA - Scilab 2006 -########## - -VPATH = @srcdir@ -pkgdatadir = $(datadir)/@PACKAGE@ -pkglibdir = $(libdir)/@PACKAGE@ -pkgincludedir = $(includedir)/@PACKAGE@ -am__cd = CDPATH="$${ZSH_VERSION+.}$(PATH_SEPARATOR)" && cd -install_sh_DATA = $(install_sh) -c -m 644 -install_sh_PROGRAM = $(install_sh) -c -install_sh_SCRIPT = $(install_sh) -c -INSTALL_HEADER = $(INSTALL_DATA) -transform = $(program_transform_name) -NORMAL_INSTALL = : -PRE_INSTALL = : -POST_INSTALL = : -NORMAL_UNINSTALL = : -PRE_UNINSTALL = : -POST_UNINSTALL = : -build_triplet = @build@ -host_triplet = @host@ -subdir = lib/blas -DIST_COMMON = README $(srcdir)/Makefile.am $(srcdir)/Makefile.in -ACLOCAL_M4 = $(top_srcdir)/aclocal.m4 -am__aclocal_m4_deps = $(top_srcdir)/configure.ac -am__configure_deps = $(am__aclocal_m4_deps) $(CONFIGURE_DEPENDENCIES) \ - $(ACLOCAL_M4) -mkinstalldirs = $(install_sh) -d -CONFIG_HEADER = $(top_builddir)/includes/machine.h -CONFIG_CLEAN_FILES = -am__vpath_adj_setup = srcdirstrip=`echo "$(srcdir)" | sed 's|.|.|g'`; -am__vpath_adj = case $$p in \ - $(srcdir)/*) f=`echo "$$p" | sed "s|^$$srcdirstrip/||"`;; \ - *) f=$$p;; \ - esac; -am__strip_dir = `echo $$p | sed -e 's|^.*/||'`; -am__installdirs = "$(DESTDIR)$(pkglibdir)" -pkglibLTLIBRARIES_INSTALL = $(INSTALL) -LTLIBRARIES = $(pkglib_LTLIBRARIES) -libsciblas_la_LIBADD = -am__objects_1 = -am__objects_2 = zrotg.lo zhpr2.lo zher2k.lo dspr.lo xerbla.lo dcopy.lo \ - dsyr2k.lo zsymm.lo zhemm.lo dtbsv.lo dtrmm.lo dscal.lo ddot.lo \ - dgbmv.lo dtpsv.lo dtrsv.lo dgemv.lo idamax.lo dzasum.lo \ - zcopy.lo zher.lo drot.lo ztbsv.lo dasum.lo ztrmm.lo dsbmv.lo \ - zscal.lo dswap.lo zdotc.lo zgbmv.lo ztpsv.lo zgemv.lo ztrsv.lo \ - izamax.lo dspmv.lo dcabs1.lo dsymv.lo zswap.lo zdotu.lo \ - zgerc.lo dznrm2.lo dtbmv.lo zdscal.lo dger.lo dnrm2.lo zhpr.lo \ - daxpy.lo zhbmv.lo zhemv.lo dtrsm.lo dgemm.lo dspr2.lo dtpmv.lo \ - zgeru.lo dtrmv.lo dsyrk.lo lsame.lo ztbmv.lo dsyr2.lo zhpmv.lo \ - zsyr2k.lo zaxpy.lo zgemm.lo drotg.lo ztrsm.lo ztpmv.lo dsyr.lo \ - zsyrk.lo ztrmv.lo zherk.lo dsymm.lo zher2.lo -am_libsciblas_la_OBJECTS = $(am__objects_1) $(am__objects_2) -libsciblas_la_OBJECTS = $(am_libsciblas_la_OBJECTS) -DEFAULT_INCLUDES = -I.@am__isrc@ -I$(top_builddir)/includes -F77COMPILE = $(F77) $(AM_FFLAGS) $(FFLAGS) -LTF77COMPILE = $(LIBTOOL) --tag=F77 $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) \ - --mode=compile $(F77) $(AM_FFLAGS) $(FFLAGS) -F77LD = $(F77) -F77LINK = $(LIBTOOL) --tag=F77 $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) \ - --mode=link $(F77LD) $(AM_FFLAGS) $(FFLAGS) $(AM_LDFLAGS) \ - $(LDFLAGS) -o $@ -COMPILE = $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) \ - $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -LTCOMPILE = $(LIBTOOL) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) \ - --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) \ - $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -CCLD = $(CC) -LINK = $(LIBTOOL) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) \ - --mode=link $(CCLD) $(AM_CFLAGS) $(CFLAGS) $(AM_LDFLAGS) \ - $(LDFLAGS) -o $@ -SOURCES = $(libsciblas_la_SOURCES) -DIST_SOURCES = $(libsciblas_la_SOURCES) -ETAGS = etags -CTAGS = ctags -DISTFILES = $(DIST_COMMON) $(DIST_SOURCES) $(TEXINFOS) $(EXTRA_DIST) -ACLOCAL = @ACLOCAL@ -AMTAR = @AMTAR@ -AR = @AR@ -AUTOCONF = @AUTOCONF@ -AUTOHEADER = @AUTOHEADER@ -AUTOMAKE = @AUTOMAKE@ -AWK = @AWK@ -CC = @CC@ -CCDEPMODE = @CCDEPMODE@ -CFLAGS = @CFLAGS@ -CPP = @CPP@ -CPPFLAGS = @CPPFLAGS@ -CXX = @CXX@ -CXXCPP = @CXXCPP@ -CXXDEPMODE = @CXXDEPMODE@ -CXXFLAGS = @CXXFLAGS@ -CYGPATH_W = @CYGPATH_W@ -DEFS = @DEFS@ -DEPDIR = @DEPDIR@ -DSYMUTIL = @DSYMUTIL@ -ECHO = @ECHO@ -ECHO_C = @ECHO_C@ -ECHO_N = @ECHO_N@ -ECHO_T = @ECHO_T@ -EGREP = @EGREP@ -EXEEXT = @EXEEXT@ -F77 = @F77@ -FFLAGS = @FFLAGS@ -GREP = @GREP@ -INSTALL = @INSTALL@ -INSTALL_DATA = @INSTALL_DATA@ -INSTALL_PROGRAM = @INSTALL_PROGRAM@ -INSTALL_SCRIPT = @INSTALL_SCRIPT@ -INSTALL_STRIP_PROGRAM = @INSTALL_STRIP_PROGRAM@ -LDFLAGS = @LDFLAGS@ -LIBMATH = @LIBMATH@ -LIBOBJS = @LIBOBJS@ -LIBS = @LIBS@ -LIBTOOL = @LIBTOOL@ -LN_S = @LN_S@ -LTLIBOBJS = @LTLIBOBJS@ -MAINT = @MAINT@ -MAKEINFO = @MAKEINFO@ -MKDIR_P = @MKDIR_P@ -NMEDIT = @NMEDIT@ -OBJEXT = @OBJEXT@ -PACKAGE = @PACKAGE@ -PACKAGE_BUGREPORT = @PACKAGE_BUGREPORT@ -PACKAGE_NAME = @PACKAGE_NAME@ -PACKAGE_STRING = @PACKAGE_STRING@ -PACKAGE_TARNAME = @PACKAGE_TARNAME@ -PACKAGE_VERSION = @PACKAGE_VERSION@ -PATH_SEPARATOR = @PATH_SEPARATOR@ -RANLIB = @RANLIB@ -SED = @SED@ -SET_MAKE = @SET_MAKE@ -SHELL = @SHELL@ -STRIP = @STRIP@ -VERSION = @VERSION@ -abs_builddir = @abs_builddir@ -abs_srcdir = @abs_srcdir@ -abs_top_builddir = @abs_top_builddir@ -abs_top_srcdir = @abs_top_srcdir@ -ac_ct_CC = @ac_ct_CC@ -ac_ct_CXX = @ac_ct_CXX@ -ac_ct_F77 = @ac_ct_F77@ -am__include = @am__include@ -am__leading_dot = @am__leading_dot@ -am__quote = @am__quote@ -am__tar = @am__tar@ -am__untar = @am__untar@ -bindir = @bindir@ -build = @build@ -build_alias = @build_alias@ -build_cpu = @build_cpu@ -build_os = @build_os@ -build_vendor = @build_vendor@ -builddir = @builddir@ -datadir = @datadir@ -datarootdir = @datarootdir@ -docdir = @docdir@ -dvidir = @dvidir@ -exec_prefix = @exec_prefix@ -host = @host@ -host_alias = @host_alias@ -host_cpu = @host_cpu@ -host_os = @host_os@ -host_vendor = @host_vendor@ -htmldir = @htmldir@ -includedir = @includedir@ -infodir = @infodir@ -install_sh = @install_sh@ -libdir = @libdir@ -libexecdir = @libexecdir@ -localedir = @localedir@ -localstatedir = @localstatedir@ -mandir = @mandir@ -mkdir_p = @mkdir_p@ -oldincludedir = @oldincludedir@ -pdfdir = @pdfdir@ -prefix = @prefix@ -program_transform_name = @program_transform_name@ -psdir = @psdir@ -sbindir = @sbindir@ -sharedstatedir = @sharedstatedir@ -srcdir = @srcdir@ -sysconfdir = @sysconfdir@ -target_alias = @target_alias@ -top_builddir = @top_builddir@ -top_srcdir = @top_srcdir@ -BLAS_FORTRAN_SOURCES = zrotg.f \ -zhpr2.f \ -zher2k.f \ -dspr.f \ -xerbla.f \ -dcopy.f \ -dsyr2k.f \ -zsymm.f \ -zhemm.f \ -dtbsv.f \ -dtrmm.f \ -dscal.f \ -ddot.f \ -dgbmv.f \ -dtpsv.f \ -dtrsv.f \ -dgemv.f \ -idamax.f \ -dzasum.f \ -zcopy.f \ -zher.f \ -drot.f \ -ztbsv.f \ -dasum.f \ -ztrmm.f \ -dsbmv.f \ -zscal.f \ -dswap.f \ -zdotc.f \ -zgbmv.f \ -ztpsv.f \ -zgemv.f \ -ztrsv.f \ -izamax.f \ -dspmv.f \ -dcabs1.f \ -dsymv.f \ -zswap.f \ -zdotu.f \ -zgerc.f \ -dznrm2.f \ -dtbmv.f \ -zdscal.f \ -dger.f \ -dnrm2.f \ -zhpr.f \ -daxpy.f \ -zhbmv.f \ -zhemv.f \ -dtrsm.f \ -dgemm.f \ -dspr2.f \ -dtpmv.f \ -zgeru.f \ -dtrmv.f \ -dsyrk.f \ -lsame.f \ -ztbmv.f \ -dsyr2.f \ -zhpmv.f \ -zsyr2k.f \ -zaxpy.f \ -zgemm.f \ -drotg.f \ -ztrsm.f \ -ztpmv.f \ -dsyr.f \ -zsyrk.f \ -ztrmv.f \ -zherk.f \ -dsymm.f \ -zher2.f - -instdir = $(top_builddir)/lib -pkglib_LTLIBRARIES = libsciblas.la -HEAD = $(top_builddir)/includes/blas.h -libsciblas_la_SOURCES = $(HEAD) $(BLAS_FORTRAN_SOURCES) -all: all-am - -.SUFFIXES: -.SUFFIXES: .f .lo .o .obj -$(srcdir)/Makefile.in: @MAINTAINER_MODE_TRUE@ $(srcdir)/Makefile.am $(am__configure_deps) - @for dep in $?; do \ - case '$(am__configure_deps)' in \ - *$$dep*) \ - cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh \ - && exit 0; \ - exit 1;; \ - esac; \ - done; \ - echo ' cd $(top_srcdir) && $(AUTOMAKE) --foreign lib/blas/Makefile'; \ - cd $(top_srcdir) && \ - $(AUTOMAKE) --foreign lib/blas/Makefile -.PRECIOUS: Makefile -Makefile: $(srcdir)/Makefile.in $(top_builddir)/config.status - @case '$?' in \ - *config.status*) \ - cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh;; \ - *) \ - echo ' cd $(top_builddir) && $(SHELL) ./config.status $(subdir)/$@ $(am__depfiles_maybe)'; \ - cd $(top_builddir) && $(SHELL) ./config.status $(subdir)/$@ $(am__depfiles_maybe);; \ - esac; - -$(top_builddir)/config.status: $(top_srcdir)/configure $(CONFIG_STATUS_DEPENDENCIES) - cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh - -$(top_srcdir)/configure: @MAINTAINER_MODE_TRUE@ $(am__configure_deps) - cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh -$(ACLOCAL_M4): @MAINTAINER_MODE_TRUE@ $(am__aclocal_m4_deps) - cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh -install-pkglibLTLIBRARIES: $(pkglib_LTLIBRARIES) - @$(NORMAL_INSTALL) - test -z "$(pkglibdir)" || $(MKDIR_P) "$(DESTDIR)$(pkglibdir)" - @list='$(pkglib_LTLIBRARIES)'; for p in $$list; do \ - if test -f $$p; then \ - f=$(am__strip_dir) \ - echo " $(LIBTOOL) $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=install $(pkglibLTLIBRARIES_INSTALL) $(INSTALL_STRIP_FLAG) '$$p' '$(DESTDIR)$(pkglibdir)/$$f'"; \ - $(LIBTOOL) $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=install $(pkglibLTLIBRARIES_INSTALL) $(INSTALL_STRIP_FLAG) "$$p" "$(DESTDIR)$(pkglibdir)/$$f"; \ - else :; fi; \ - done - -uninstall-pkglibLTLIBRARIES: - @$(NORMAL_UNINSTALL) - @list='$(pkglib_LTLIBRARIES)'; for p in $$list; do \ - p=$(am__strip_dir) \ - echo " $(LIBTOOL) $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=uninstall rm -f '$(DESTDIR)$(pkglibdir)/$$p'"; \ - $(LIBTOOL) $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=uninstall rm -f "$(DESTDIR)$(pkglibdir)/$$p"; \ - done - -clean-pkglibLTLIBRARIES: - -test -z "$(pkglib_LTLIBRARIES)" || rm -f $(pkglib_LTLIBRARIES) - @list='$(pkglib_LTLIBRARIES)'; for p in $$list; do \ - dir="`echo $$p | sed -e 's|/[^/]*$$||'`"; \ - test "$$dir" != "$$p" || dir=.; \ - echo "rm -f \"$${dir}/so_locations\""; \ - rm -f "$${dir}/so_locations"; \ - done -libsciblas.la: $(libsciblas_la_OBJECTS) $(libsciblas_la_DEPENDENCIES) - $(F77LINK) -rpath $(pkglibdir) $(libsciblas_la_OBJECTS) $(libsciblas_la_LIBADD) $(LIBS) - -mostlyclean-compile: - -rm -f *.$(OBJEXT) - -distclean-compile: - -rm -f *.tab.c - -.f.o: - $(F77COMPILE) -c -o $@ $< - -.f.obj: - $(F77COMPILE) -c -o $@ `$(CYGPATH_W) '$<'` - -.f.lo: - $(LTF77COMPILE) -c -o $@ $< - -mostlyclean-libtool: - -rm -f *.lo - -clean-libtool: - -rm -rf .libs _libs - -ID: $(HEADERS) $(SOURCES) $(LISP) $(TAGS_FILES) - list='$(SOURCES) $(HEADERS) $(LISP) $(TAGS_FILES)'; \ - unique=`for i in $$list; do \ - if test -f "$$i"; then echo $$i; else echo $(srcdir)/$$i; fi; \ - done | \ - $(AWK) '{ files[$$0] = 1; nonemtpy = 1; } \ - END { if (nonempty) { for (i in files) print i; }; }'`; \ - mkid -fID $$unique -tags: TAGS - -TAGS: $(HEADERS) $(SOURCES) $(TAGS_DEPENDENCIES) \ - $(TAGS_FILES) $(LISP) - tags=; \ - here=`pwd`; \ - list='$(SOURCES) $(HEADERS) $(LISP) $(TAGS_FILES)'; \ - unique=`for i in $$list; do \ - if test -f "$$i"; then echo $$i; else echo $(srcdir)/$$i; fi; \ - done | \ - $(AWK) '{ files[$$0] = 1; nonempty = 1; } \ - END { if (nonempty) { for (i in files) print i; }; }'`; \ - if test -z "$(ETAGS_ARGS)$$tags$$unique"; then :; else \ - test -n "$$unique" || unique=$$empty_fix; \ - $(ETAGS) $(ETAGSFLAGS) $(AM_ETAGSFLAGS) $(ETAGS_ARGS) \ - $$tags $$unique; \ - fi -ctags: CTAGS -CTAGS: $(HEADERS) $(SOURCES) $(TAGS_DEPENDENCIES) \ - $(TAGS_FILES) $(LISP) - tags=; \ - list='$(SOURCES) $(HEADERS) $(LISP) $(TAGS_FILES)'; \ - unique=`for i in $$list; do \ - if test -f "$$i"; then echo $$i; else echo $(srcdir)/$$i; fi; \ - done | \ - $(AWK) '{ files[$$0] = 1; nonempty = 1; } \ - END { if (nonempty) { for (i in files) print i; }; }'`; \ - test -z "$(CTAGS_ARGS)$$tags$$unique" \ - || $(CTAGS) $(CTAGSFLAGS) $(AM_CTAGSFLAGS) $(CTAGS_ARGS) \ - $$tags $$unique - -GTAGS: - here=`$(am__cd) $(top_builddir) && pwd` \ - && cd $(top_srcdir) \ - && gtags -i $(GTAGS_ARGS) $$here - -distclean-tags: - -rm -f TAGS ID GTAGS GRTAGS GSYMS GPATH tags - -distdir: $(DISTFILES) - @srcdirstrip=`echo "$(srcdir)" | sed 's/[].[^$$\\*]/\\\\&/g'`; \ - topsrcdirstrip=`echo "$(top_srcdir)" | sed 's/[].[^$$\\*]/\\\\&/g'`; \ - list='$(DISTFILES)'; \ - dist_files=`for file in $$list; do echo $$file; done | \ - sed -e "s|^$$srcdirstrip/||;t" \ - -e "s|^$$topsrcdirstrip/|$(top_builddir)/|;t"`; \ - case $$dist_files in \ - */*) $(MKDIR_P) `echo "$$dist_files" | \ - sed '/\//!d;s|^|$(distdir)/|;s,/[^/]*$$,,' | \ - sort -u` ;; \ - esac; \ - for file in $$dist_files; do \ - if test -f $$file || test -d $$file; then d=.; else d=$(srcdir); fi; \ - if test -d $$d/$$file; then \ - dir=`echo "/$$file" | sed -e 's,/[^/]*$$,,'`; \ - if test -d $(srcdir)/$$file && test $$d != $(srcdir); then \ - cp -pR $(srcdir)/$$file $(distdir)$$dir || exit 1; \ - fi; \ - cp -pR $$d/$$file $(distdir)$$dir || exit 1; \ - else \ - test -f $(distdir)/$$file \ - || cp -p $$d/$$file $(distdir)/$$file \ - || exit 1; \ - fi; \ - done -check-am: all-am -check: check-am -all-am: Makefile $(LTLIBRARIES) -installdirs: - for dir in "$(DESTDIR)$(pkglibdir)"; do \ - test -z "$$dir" || $(MKDIR_P) "$$dir"; \ - done -install: install-am -install-exec: install-exec-am -install-data: install-data-am -uninstall: uninstall-am - -install-am: all-am - @$(MAKE) $(AM_MAKEFLAGS) install-exec-am install-data-am - -installcheck: installcheck-am -install-strip: - $(MAKE) $(AM_MAKEFLAGS) INSTALL_PROGRAM="$(INSTALL_STRIP_PROGRAM)" \ - install_sh_PROGRAM="$(INSTALL_STRIP_PROGRAM)" INSTALL_STRIP_FLAG=-s \ - `test -z '$(STRIP)' || \ - echo "INSTALL_PROGRAM_ENV=STRIPPROG='$(STRIP)'"` install -mostlyclean-generic: - -clean-generic: - -distclean-generic: - -test -z "$(CONFIG_CLEAN_FILES)" || rm -f $(CONFIG_CLEAN_FILES) - -maintainer-clean-generic: - @echo "This command is intended for maintainers to use" - @echo "it deletes files that may require special tools to rebuild." -clean: clean-am - -clean-am: clean-generic clean-libtool clean-pkglibLTLIBRARIES \ - mostlyclean-am - -distclean: distclean-am - -rm -f Makefile -distclean-am: clean-am distclean-compile distclean-generic \ - distclean-tags - -dvi: dvi-am - -dvi-am: - -html: html-am - -info: info-am - -info-am: - -install-data-am: - -install-dvi: install-dvi-am - -install-exec-am: install-pkglibLTLIBRARIES - -install-html: install-html-am - -install-info: install-info-am - -install-man: - -install-pdf: install-pdf-am - -install-ps: install-ps-am - -installcheck-am: - -maintainer-clean: maintainer-clean-am - -rm -f Makefile -maintainer-clean-am: distclean-am maintainer-clean-generic - -mostlyclean: mostlyclean-am - -mostlyclean-am: mostlyclean-compile mostlyclean-generic \ - mostlyclean-libtool - -pdf: pdf-am - -pdf-am: - -ps: ps-am - -ps-am: - -uninstall-am: uninstall-pkglibLTLIBRARIES - -.MAKE: install-am install-strip - -.PHONY: CTAGS GTAGS all all-am check check-am clean clean-generic \ - clean-libtool clean-pkglibLTLIBRARIES ctags distclean \ - distclean-compile distclean-generic distclean-libtool \ - distclean-tags distdir dvi dvi-am html html-am info info-am \ - install install-am install-data install-data-am install-dvi \ - install-dvi-am install-exec install-exec-am install-html \ - install-html-am install-info install-info-am install-man \ - install-pdf install-pdf-am install-pkglibLTLIBRARIES \ - install-ps install-ps-am install-strip installcheck \ - installcheck-am installdirs maintainer-clean \ - maintainer-clean-generic mostlyclean mostlyclean-compile \ - mostlyclean-generic mostlyclean-libtool pdf pdf-am ps ps-am \ - tags uninstall uninstall-am uninstall-pkglibLTLIBRARIES - -# Tell versions [3.59,3.63) of GNU make to not export all variables. -# Otherwise a system limit (for SysV at least) may be exceeded. -.NOEXPORT: diff --git a/src/lib/blas/README b/src/lib/blas/README deleted file mode 100644 index 8c281661..00000000 --- a/src/lib/blas/README +++ /dev/null @@ -1,6 +0,0 @@ -This directory contains double precision version of the standard blas routines. - The makefile produces <SCIDIR>/libs/blas.a - -However this code is intended for use only if there is no other implementation -of the BLAS already available on your machine; - diff --git a/src/lib/blas/blas_f/blasplus.def b/src/lib/blas/blas_f/blasplus.def deleted file mode 100644 index 336d98ac..00000000 --- a/src/lib/blas/blas_f/blasplus.def +++ /dev/null @@ -1,74 +0,0 @@ -LIBRARY blasplus.dll
-
-EXPORTS
- dasum
- daxpy
- dcopy
- ddot
- dgbmv
- dgemm
- dgemv
- dger
- dnrm2
- drot
- drotg
- dsbmv
- dscal
- dspmv
- dspr
- dspr2
- dswap
- dsymm
- dsymv
- dsyr
- dsyr2
- dsyr2k
- dsyrk
- dtbmv
- dtbsv
- dtpmv
- dtpsv
- dtrmm
- dtrmv
- dtrsm
- dtrsv
- dzasum
- dznrm2
- idamax
- izamax
- xerbla
- zaxpy
- zcopy
- zdotc
- zdotu
- zdscal
- zgbmv
- zgemm
- zgemv
- zgerc
- zgeru
- zhbmv
- zhemm
- zhemv
- zher
- zher2
- zher2k
- zherk
- zhpmv
- zhpr
- zhpr2
- zrotg
- zscal
- zswap
- zsymm
- zsyr2k
- zsyrk
- ztbmv
- ztbsv
- ztpmv
- ztpsv
- ztrmm
- ztrmv
- ztrsm
- ztrsv
-
\ No newline at end of file diff --git a/src/lib/blas/blas_f/blasplusAtlas.def b/src/lib/blas/blas_f/blasplusAtlas.def deleted file mode 100644 index d13dde93..00000000 --- a/src/lib/blas/blas_f/blasplusAtlas.def +++ /dev/null @@ -1,144 +0,0 @@ -LIBRARY blasplus.dll
-
-EXPORTS
- dasum_ @1
- dasum = dasum_
- daxpy_ @2
- daxpy = daxpy_
- dcopy_ @3
- dcopy = dcopy_
- ddot_ @4
- ddot = ddot_
- dgbmv_ @5
- dgbmv = dgbmv_
- dgemm_ @6
- dgemm = dgemm_
- dgemv_ @7
- dgemv = dgemv_
- dger_ @8
- dger = dger_
- dnrm2_ @9
- dnrm2 = dnrm2_
- drot_ @10
- drot = drot_
- drotg_ @11
- drotg = drotg_
- dsbmv_ @12
- dsbmv = dsbmv_
- dscal_ @13
- dscal = dscal_
- dspmv_ @14
- dspmv = dspmv_
- dspr_ @15
- dspr = dspr_
- dspr2_ @16
- dspr2 = dspr2_
- dswap_ @17
- dswap = dswap_
- dsymm_ @18
- dsymm = dsymm_
- dsymv_ @19
- dsymv = dsymv_
- dsyr_ @20
- dsyr = dsyr_
- dsyr2_ @21
- dsyr2 = dsyr2_
- dsyr2k_ @22
- dsyr2k = dsyr2k_
- dsyrk_ @23
- dsyrk = dsyrk_
- dtbmv_ @24
- dtbmv = dtbmv_
- dtbsv_ @25
- dtbsv = dtbsv_
- dtpmv_ @26
- dtpmv = dtpmv_
- dtpsv_ @27
- dtpsv = dtpsv_
- dtrmm_ @28
- dtrmm = dtrmm_
- dtrmv_ @29
- dtrmv = dtrmv_
- dtrsm_ @30
- dtrsm = dtrsm_
- dtrsv_ @31
- dtrsv = dtrsv_
- dzasum_ @32
- dzasum = dzasum_
- dznrm2_ @33
- dznrm2 = dznrm2_
- idamax_ @34
- idamax = idamax_
- izamax_ @35
- izamax = izamax_
- xerbla_ @36
- xerbla = xerbla_
- zaxpy_ @37
- zaxpy = zaxpy_
- zcopy_ @38
- zcopy = zcopy_
- zdotc_ @39
- zdotc = zdotc_
- zdotu_ @40
- zdotu = zdotu_
- zdscal_ @41
- zdscal = zdscal_
- zgbmv_ @42
- zgbmv = zgbmv_
- zgemm_ @43
- zgemm = zgemm_
- zgemv_ @44
- zgemv = zgemv_
- zgerc_ @45
- zgerc = zgerc_
- zgeru_ @46
- zgeru = zgeru_
- zhbmv_ @47
- zhbmv = zhbmv_
- zhemm_ @48
- zhemm = zhemm_
- zhemv_ @49
- zhemv = zhemv_
- zher_ @50
- zher = zher_
- zher2_ @51
- zher2 = zher2_
- zher2k_ @52
- zher2k = zher2k_
- zherk_ @53
- zherk = zherk_
- zhpmv_ @54
- zhpmv = zhpmv_
- zhpr_ @55
- zhpr = zhpr_
- zhpr2_ @56
- zhpr2 = zhpr2_
- zrotg_ @57
- zrotg = zrotg_
- zscal_ @58
- zscal = zscal_
- zswap_ @59
- zswap = zswap_
- zsymm_ @60
- zsymm = zsymm_
- zsyr2k_ @61
- zsyr2k = zsyr2k_
- zsyrk_ @62
- zsyrk = zsyrk_
- ztbmv_ @63
- ztbmv = ztbmv_
- ztbsv_ @64
- ztbsv = ztbsv_
- ztpmv_ @65
- ztpmv = ztpmv_
- ztpsv_ @66
- ztpsv = ztpsv_
- ztrmm_ @67
- ztrmm =ztrmm_
- ztrmv_ @68
- ztrmv = ztrmv_
- ztrsm_ @69
- ztrsm = ztrsm_
- ztrsv_ @70
- ztrsv = ztrsv_
-
\ No newline at end of file diff --git a/src/lib/blas/blas_f/blasplus_DLL.vfproj b/src/lib/blas/blas_f/blasplus_DLL.vfproj deleted file mode 100644 index 9362bc1e..00000000 --- a/src/lib/blas/blas_f/blasplus_DLL.vfproj +++ /dev/null @@ -1,120 +0,0 @@ -<?xml version="1.0" encoding="UTF-8"?>
-<VisualStudioProject ProjectType="typeDynamicLibrary" ProjectCreator="Intel Fortran" Keyword="Dll" Version="9.10" ProjectIdGuid="{78BD64CE-181D-4D3F-9254-5C4F55C1EDC9}">
- <Platforms>
- <Platform Name="Win32"/>
- <Platform Name="x64"/></Platforms>
- <Configurations>
- <Configuration Name="Debug|Win32" OutputDirectory="$(InputDir)$(ConfigurationName)" DeleteExtensionsOnClean="*.obj;*.mod;*.pdb;*.asm;*.map;*.dyn;*.dpi;*.tmp;*.log;*.ilk;*.dll;$(TargetPath)" ConfigurationType="typeDynamicLibrary">
- <Tool Name="VFFortranCompilerTool" AdditionalOptions="/dll " SuppressStartupBanner="true" DebugInformationFormat="debugEnabled" Optimization="optimizeDisabled" OptimizeForProcessor="procOptimizeBlended" F77RuntimeCompatibility="true" CallingConvention="callConventionCRef" ModulePath="$(INTDIR)/" ObjectFile="$(INTDIR)/" Traceback="true" BoundsCheck="true" RuntimeLibrary="rtMultiThreadedDebug"/>
- <Tool Name="VFLinkerTool" OutputFile="$(SolutionDir)bin/blasplus.dll" LinkIncremental="linkIncrementalNo" SuppressStartupBanner="true" IgnoreDefaultLibraryNames="msvcrtd.lib" ModuleDefinitionFile="blasplus.def" GenerateDebugInformation="true" SubSystem="subSystemWindows" ImportLibrary="$(SolutionDir)bin/blasplus.lib" LinkDLL="true" AdditionalDependencies="libcmtd.lib"/>
- <Tool Name="VFResourceCompilerTool"/>
- <Tool Name="VFMidlTool" SuppressStartupBanner="true" HeaderFileName="$(InputName).h" TypeLibraryName="$(IntDir)/$(InputName).tlb"/>
- <Tool Name="VFCustomBuildTool"/>
- <Tool Name="VFPreLinkEventTool"/>
- <Tool Name="VFPreBuildEventTool"/>
- <Tool Name="VFPostBuildEventTool" CommandLine="lib /def:blasplusAtlas.def /Machine:X86 /OUT:$(SolutionDir)bin/blasplus.lib" Description="Create blasplus.lib for Scilab"/></Configuration>
- <Configuration Name="Release|Win32" OutputDirectory="$(InputDir)$(ConfigurationName)" DeleteExtensionsOnClean="*.obj;*.mod;*.pdb;*.asm;*.map;*.dyn;*.dpi;*.tmp;*.log;*.ilk;*.dll;$(TargetPath)" ConfigurationType="typeDynamicLibrary">
- <Tool Name="VFFortranCompilerTool" AdditionalOptions="/dll" SuppressStartupBanner="true" OptimizeForProcessor="procOptimizePentiumProThruIII" AlternateParameterSyntax="false" F77RuntimeCompatibility="true" BackslashAsNormalCharacter="false" FPS4Libs="false" CallingConvention="callConventionCRef" ModulePath="$(INTDIR)/" ObjectFile="$(INTDIR)/" RuntimeLibrary="rtMultiThreaded"/>
- <Tool Name="VFLinkerTool" OutputFile="$(SolutionDir)bin/blasplus.dll" LinkIncremental="linkIncrementalNo" SuppressStartupBanner="true" IgnoreDefaultLibraryNames="msvcrt.lib" ModuleDefinitionFile="blasplus.def" SubSystem="subSystemWindows" SupportUnloadOfDelayLoadedDLL="true" ImportLibrary="$(SolutionDir)bin/blasplus.lib" LinkDLL="true" AdditionalDependencies="libcmt.lib"/>
- <Tool Name="VFResourceCompilerTool"/>
- <Tool Name="VFMidlTool" SuppressStartupBanner="true" HeaderFileName="$(InputName).h" TypeLibraryName="$(IntDir)/$(InputName).tlb"/>
- <Tool Name="VFCustomBuildTool"/>
- <Tool Name="VFPreLinkEventTool"/>
- <Tool Name="VFPreBuildEventTool"/>
- <Tool Name="VFPostBuildEventTool" CommandLine="lib /def:blasplusAtlas.def /Machine:X86 /OUT:$(SolutionDir)bin/blasplus.lib" Description="Create blasplus.lib (Atlas compatibility)"/></Configuration>
- <Configuration Name="Debug|x64" OutputDirectory="$(InputDir)$(ConfigurationName)" IntermediateDirectory="$(ConfigurationName)" DeleteExtensionsOnClean="*.obj;*.mod;*.pdb;*.asm;*.map;*.dyn;*.dpi;*.tmp;*.log;*.ilk;*.dll;$(TargetPath)" ConfigurationType="typeDynamicLibrary">
- <Tool Name="VFFortranCompilerTool" AdditionalOptions="/dll " SuppressStartupBanner="true" DebugInformationFormat="debugEnabled" Optimization="optimizeDisabled" F77RuntimeCompatibility="true" CallingConvention="callConventionCRef" ModulePath="$(INTDIR)/" ObjectFile="$(INTDIR)/" Traceback="true" BoundsCheck="true" RuntimeLibrary="rtMultiThreadedDebugDLL"/>
- <Tool Name="VFLinkerTool" OutputFile="$(SolutionDir)bin/blasplus.dll" LinkIncremental="linkIncrementalNo" SuppressStartupBanner="true" IgnoreDefaultLibraryNames="msvcrtd.lib" ModuleDefinitionFile="blasplus.def" GenerateDebugInformation="true" SubSystem="subSystemWindows" ImportLibrary="$(SolutionDir)bin/blasplus.lib" LinkDLL="true" AdditionalDependencies="libcmtd.lib"/>
- <Tool Name="VFResourceCompilerTool"/>
- <Tool Name="VFMidlTool" SuppressStartupBanner="true" HeaderFileName="$(InputName).h" TypeLibraryName="$(IntDir)/$(InputName).tlb"/>
- <Tool Name="VFCustomBuildTool"/>
- <Tool Name="VFPreLinkEventTool"/>
- <Tool Name="VFPreBuildEventTool"/>
- <Tool Name="VFPostBuildEventTool" CommandLine="lib /def:blasplusAtlas.def /Machine:X64 /OUT:$(SolutionDir)bin/blasplus.lib" Description="Create blasplus.lib for Scilab"/></Configuration>
- <Configuration Name="Release|x64" OutputDirectory="$(InputDir)$(ConfigurationName)" IntermediateDirectory="$(ConfigurationName)" DeleteExtensionsOnClean="*.obj;*.mod;*.pdb;*.asm;*.map;*.dyn;*.dpi;*.tmp;*.log;*.ilk;*.dll;$(TargetPath)" ConfigurationType="typeDynamicLibrary">
- <Tool Name="VFFortranCompilerTool" AdditionalOptions="/dll" SuppressStartupBanner="true" AlternateParameterSyntax="false" F77RuntimeCompatibility="true" BackslashAsNormalCharacter="false" FPS4Libs="false" CallingConvention="callConventionCRef" ModulePath="$(INTDIR)/" ObjectFile="$(INTDIR)/"/>
- <Tool Name="VFLinkerTool" OutputFile="$(SolutionDir)bin/blasplus.dll" LinkIncremental="linkIncrementalNo" SuppressStartupBanner="true" IgnoreDefaultLibraryNames="msvcrt.lib" ModuleDefinitionFile="blasplus.def" SubSystem="subSystemWindows" SupportUnloadOfDelayLoadedDLL="true" ImportLibrary="$(SolutionDir)bin/blasplus.lib" LinkDLL="true" AdditionalDependencies="libcmt.lib"/>
- <Tool Name="VFResourceCompilerTool"/>
- <Tool Name="VFMidlTool" SuppressStartupBanner="true" HeaderFileName="$(InputName).h" TypeLibraryName="$(IntDir)/$(InputName).tlb"/>
- <Tool Name="VFCustomBuildTool"/>
- <Tool Name="VFPreLinkEventTool"/>
- <Tool Name="VFPreBuildEventTool"/>
- <Tool Name="VFPostBuildEventTool" CommandLine="lib /def:blasplusAtlas.def /Machine:X64 /OUT:$(SolutionDir)bin/blasplus.lib" Description="Create blasplus.lib (Atlas compatibility)"/></Configuration></Configurations>
- <Files>
- <Filter Name="Header Files" Filter="fi;fd"/>
- <Filter Name="Resource Files" Filter="rc;ico;cur;bmp;dlg;rc2;rct;bin;rgs;gif;jpg;jpeg;jpe"/>
- <Filter Name="Source Files" Filter="f90;for;f;fpp;ftn;def;odl;idl">
- <File RelativePath="..\dasum.f"/>
- <File RelativePath="..\daxpy.f"/>
- <File RelativePath="..\dcabs1.f"/>
- <File RelativePath="..\dcopy.f"/>
- <File RelativePath="..\ddot.f"/>
- <File RelativePath="..\dgbmv.f"/>
- <File RelativePath="..\dgemm.f"/>
- <File RelativePath="..\dgemv.f"/>
- <File RelativePath="..\dger.f"/>
- <File RelativePath="..\dnrm2.f"/>
- <File RelativePath="..\drot.f"/>
- <File RelativePath="..\drotg.f"/>
- <File RelativePath="..\dsbmv.f"/>
- <File RelativePath="..\dscal.f"/>
- <File RelativePath="..\dspmv.f"/>
- <File RelativePath="..\dspr.f"/>
- <File RelativePath="..\dspr2.f"/>
- <File RelativePath="..\dswap.f"/>
- <File RelativePath="..\dsymm.f"/>
- <File RelativePath="..\dsymv.f"/>
- <File RelativePath="..\dsyr.f"/>
- <File RelativePath="..\dsyr2.f"/>
- <File RelativePath="..\dsyr2k.f"/>
- <File RelativePath="..\dsyrk.f"/>
- <File RelativePath="..\dtbmv.f"/>
- <File RelativePath="..\dtbsv.f"/>
- <File RelativePath="..\dtpmv.f"/>
- <File RelativePath="..\dtpsv.f"/>
- <File RelativePath="..\dtrmm.f"/>
- <File RelativePath="..\dtrmv.f"/>
- <File RelativePath="..\dtrsm.f"/>
- <File RelativePath="..\dtrsv.f"/>
- <File RelativePath="..\dzasum.f"/>
- <File RelativePath="..\dznrm2.f"/>
- <File RelativePath="..\idamax.f"/>
- <File RelativePath="..\izamax.f"/>
- <File RelativePath="..\lsame.f"/>
- <File RelativePath="..\xerbla.f"/>
- <File RelativePath="..\zaxpy.f"/>
- <File RelativePath="..\zcopy.f"/>
- <File RelativePath="..\zdotc.f"/>
- <File RelativePath="..\zdotu.f"/>
- <File RelativePath="..\zdscal.f"/>
- <File RelativePath="..\zgbmv.f"/>
- <File RelativePath="..\zgemm.f"/>
- <File RelativePath="..\zgemv.f"/>
- <File RelativePath="..\zgerc.f"/>
- <File RelativePath="..\zgeru.f"/>
- <File RelativePath="..\zhbmv.f"/>
- <File RelativePath="..\zhemm.f"/>
- <File RelativePath="..\zhemv.f"/>
- <File RelativePath="..\zher.f"/>
- <File RelativePath="..\zher2.f"/>
- <File RelativePath="..\zher2k.f"/>
- <File RelativePath="..\zherk.f"/>
- <File RelativePath="..\zhpmv.f"/>
- <File RelativePath="..\zhpr.f"/>
- <File RelativePath="..\zhpr2.f"/>
- <File RelativePath="..\zrotg.f"/>
- <File RelativePath="..\zscal.f"/>
- <File RelativePath="..\zswap.f"/>
- <File RelativePath="..\zsymm.f"/>
- <File RelativePath="..\zsyr2k.f"/>
- <File RelativePath="..\zsyrk.f"/>
- <File RelativePath="..\ztbmv.f"/>
- <File RelativePath="..\ztbsv.f"/>
- <File RelativePath="..\ztpmv.f"/>
- <File RelativePath="..\ztpsv.f"/>
- <File RelativePath="..\ztrmm.f"/>
- <File RelativePath="..\ztrmv.f"/>
- <File RelativePath="..\ztrsm.f"/>
- <File RelativePath="..\ztrsv.f"/></Filter>
- <File RelativePath=".\blasplusAtlas.def"/></Files>
- <Globals/></VisualStudioProject>
diff --git a/src/lib/blas/blas_f/blasplus_DLL_f2c.vcproj b/src/lib/blas/blas_f/blasplus_DLL_f2c.vcproj deleted file mode 100644 index a365be13..00000000 --- a/src/lib/blas/blas_f/blasplus_DLL_f2c.vcproj +++ /dev/null @@ -1,1034 +0,0 @@ -<?xml version="1.0" encoding="Windows-1252"?>
-<VisualStudioProject
- ProjectType="Visual C++"
- Version="9,00"
- Name="blasplus_f2c_DLL"
- ProjectGUID="{78BD64CE-181D-4D3F-9254-5C4F55C1EDC9}"
- RootNamespace="blas_f2c"
- Keyword="Win32Proj"
- TargetFrameworkVersion="0"
- >
- <Platforms>
- <Platform
- Name="Win32"
- />
- <Platform
- Name="x64"
- />
- </Platforms>
- <ToolFiles>
- <ToolFile
- RelativePath="..\..\..\..\Visual-Studio-settings\f2c.rules"
- />
- </ToolFiles>
- <Configurations>
- <Configuration
- Name="Debug|Win32"
- OutputDirectory="$(ConfigurationName)"
- IntermediateDirectory="$(ConfigurationName)"
- ConfigurationType="2"
- CharacterSet="2"
- >
- <Tool
- Name="f2c rule"
- ExecutionBucket="1"
- CommandLine="cd "$(InputDir)"
"$(SolutionDir)bin\f2c.exe" -E -I..\..\..\core\includes -I..\..\..\..\core\includes "$(InputFileName)" 2>NUL

"
- />
- <Tool
- Name="VCPreBuildEventTool"
- CommandLine=""
- ExecutionBucket="2"
- />
- <Tool
- Name="VCCustomBuildTool"
- />
- <Tool
- Name="VCWebServiceProxyGeneratorTool"
- ExecutionBucket="4"
- />
- <Tool
- Name="VCXMLDataGeneratorTool"
- />
- <Tool
- Name="VCMIDLTool"
- ExecutionBucket="5"
- />
- <Tool
- Name="VCCLCompilerTool"
- ExecutionBucket="6"
- Optimization="0"
- AdditionalIncludeDirectories="../../f2c"
- PreprocessorDefinitions="STRICT;__STDC__;_CRT_SECURE_NO_DEPRECATE"
- MinimalRebuild="true"
- BasicRuntimeChecks="0"
- RuntimeLibrary="1"
- UsePrecompiledHeader="0"
- ObjectFile="$(ConfigurationName)/"
- ProgramDataBaseFileName="$(ConfigurationName)/vc80.pdb"
- WarningLevel="3"
- Detect64BitPortabilityProblems="false"
- DebugInformationFormat="3"
- />
- <Tool
- Name="VCManagedResourceCompilerTool"
- ExecutionBucket="7"
- />
- <Tool
- Name="VCResourceCompilerTool"
- ExecutionBucket="8"
- />
- <Tool
- Name="VCPreLinkEventTool"
- ExecutionBucket="9"
- />
- <Tool
- Name="VCLinkerTool"
- ExecutionBucket="10"
- AdditionalOptions="/fixed:no"
- OutputFile="$(SolutionDir)bin\blasplus.dll"
- ModuleDefinitionFile="blasplusAtlas.def"
- RandomizedBaseAddress="1"
- DataExecutionPrevention="0"
- ImportLibrary="$(SolutionDir)bin\blasplus.lib"
- CLRUnmanagedCodeCheck="true"
- />
- <Tool
- Name="VCALinkTool"
- ExecutionBucket="11"
- />
- <Tool
- Name="VCManifestTool"
- ExecutionBucket="12"
- />
- <Tool
- Name="VCXDCMakeTool"
- ExecutionBucket="13"
- />
- <Tool
- Name="VCBscMakeTool"
- ExecutionBucket="14"
- />
- <Tool
- Name="VCFxCopTool"
- ExecutionBucket="15"
- />
- <Tool
- Name="VCPostBuildEventTool"
- CommandLine=""
- ExecutionBucket="17"
- />
- <Tool
- Name="VCAppVerifierTool"
- />
- </Configuration>
- <Configuration
- Name="Debug|x64"
- OutputDirectory="$(ConfigurationName)"
- IntermediateDirectory="$(ConfigurationName)"
- ConfigurationType="2"
- CharacterSet="2"
- >
- <Tool
- Name="VCPreBuildEventTool"
- CommandLine=""
- />
- <Tool
- Name="VCCustomBuildTool"
- />
- <Tool
- Name="f2c rule"
- CommandLine="cd "$(InputDir)"
"$(SolutionDir)bin\f2c.exe" -E -I..\..\..\core\includes -I..\..\..\..\core\includes "$(InputFileName)" 2>NUL

"
- />
- <Tool
- Name="VCXMLDataGeneratorTool"
- />
- <Tool
- Name="VCWebServiceProxyGeneratorTool"
- />
- <Tool
- Name="VCMIDLTool"
- TargetEnvironment="3"
- />
- <Tool
- Name="VCCLCompilerTool"
- Optimization="0"
- AdditionalIncludeDirectories="../../f2c"
- PreprocessorDefinitions="STRICT;__STDC__;_CRT_SECURE_NO_DEPRECATE"
- MinimalRebuild="true"
- BasicRuntimeChecks="0"
- RuntimeLibrary="1"
- UsePrecompiledHeader="0"
- ObjectFile="$(ConfigurationName)/"
- ProgramDataBaseFileName="$(ConfigurationName)/vc80.pdb"
- WarningLevel="3"
- Detect64BitPortabilityProblems="false"
- DebugInformationFormat="3"
- />
- <Tool
- Name="VCManagedResourceCompilerTool"
- />
- <Tool
- Name="VCResourceCompilerTool"
- />
- <Tool
- Name="VCPreLinkEventTool"
- />
- <Tool
- Name="VCLinkerTool"
- AdditionalOptions="/fixed:no"
- OutputFile="../../../bin/blasplus.dll"
- ModuleDefinitionFile="blasplusAtlas.def"
- RandomizedBaseAddress="1"
- DataExecutionPrevention="0"
- ImportLibrary="../../../bin/blasplus.lib"
- TargetMachine="17"
- CLRUnmanagedCodeCheck="true"
- />
- <Tool
- Name="VCALinkTool"
- />
- <Tool
- Name="VCManifestTool"
- />
- <Tool
- Name="VCXDCMakeTool"
- />
- <Tool
- Name="VCBscMakeTool"
- />
- <Tool
- Name="VCFxCopTool"
- />
- <Tool
- Name="VCAppVerifierTool"
- />
- <Tool
- Name="VCPostBuildEventTool"
- CommandLine=""
- />
- </Configuration>
- <Configuration
- Name="Release|Win32"
- OutputDirectory="$(SolutionDir)$(ConfigurationName)"
- IntermediateDirectory="$(ConfigurationName)"
- ConfigurationType="2"
- CharacterSet="2"
- >
- <Tool
- Name="f2c rule"
- ExecutionBucket="1"
- CommandLine="cd "$(InputDir)"
"$(SolutionDir)bin\f2c.exe" -E -I..\..\..\core\includes -I..\..\..\..\core\includes "$(InputFileName)" 2>NUL

"
- />
- <Tool
- Name="VCPreBuildEventTool"
- CommandLine=""
- ExecutionBucket="2"
- />
- <Tool
- Name="VCCustomBuildTool"
- />
- <Tool
- Name="VCWebServiceProxyGeneratorTool"
- ExecutionBucket="4"
- />
- <Tool
- Name="VCXMLDataGeneratorTool"
- />
- <Tool
- Name="VCMIDLTool"
- ExecutionBucket="5"
- />
- <Tool
- Name="VCCLCompilerTool"
- ExecutionBucket="6"
- FavorSizeOrSpeed="1"
- AdditionalIncludeDirectories="../../f2c"
- PreprocessorDefinitions="STRICT;__STDC__;_CRT_SECURE_NO_DEPRECATE"
- RuntimeLibrary="0"
- EnableEnhancedInstructionSet="0"
- UsePrecompiledHeader="0"
- ObjectFile="$(ConfigurationName)/"
- ProgramDataBaseFileName="$(ConfigurationName)/vc80.pdb"
- WarningLevel="3"
- Detect64BitPortabilityProblems="false"
- DebugInformationFormat="3"
- />
- <Tool
- Name="VCManagedResourceCompilerTool"
- ExecutionBucket="7"
- />
- <Tool
- Name="VCResourceCompilerTool"
- ExecutionBucket="8"
- />
- <Tool
- Name="VCPreLinkEventTool"
- ExecutionBucket="9"
- />
- <Tool
- Name="VCLinkerTool"
- ExecutionBucket="10"
- OutputFile="$(SolutionDir)bin\blasplus.dll"
- ModuleDefinitionFile="blasplusAtlas.def"
- RandomizedBaseAddress="1"
- DataExecutionPrevention="0"
- ImportLibrary="$(SolutionDir)bin\blasplus.lib"
- CLRUnmanagedCodeCheck="true"
- />
- <Tool
- Name="VCALinkTool"
- ExecutionBucket="11"
- />
- <Tool
- Name="VCManifestTool"
- ExecutionBucket="12"
- />
- <Tool
- Name="VCXDCMakeTool"
- ExecutionBucket="13"
- />
- <Tool
- Name="VCBscMakeTool"
- ExecutionBucket="14"
- />
- <Tool
- Name="VCFxCopTool"
- ExecutionBucket="15"
- />
- <Tool
- Name="VCPostBuildEventTool"
- CommandLine=""
- ExecutionBucket="17"
- />
- <Tool
- Name="VCAppVerifierTool"
- />
- </Configuration>
- <Configuration
- Name="Release|x64"
- OutputDirectory="$(SolutionDir)$(ConfigurationName)"
- IntermediateDirectory="$(ConfigurationName)"
- ConfigurationType="2"
- CharacterSet="2"
- >
- <Tool
- Name="VCPreBuildEventTool"
- CommandLine=""
- />
- <Tool
- Name="VCCustomBuildTool"
- />
- <Tool
- Name="f2c rule"
- CommandLine="cd "$(InputDir)"
"$(SolutionDir)bin\f2c.exe" -E -I..\..\..\core\includes -I..\..\..\..\core\includes "$(InputFileName)" 2>NUL

"
- />
- <Tool
- Name="VCXMLDataGeneratorTool"
- />
- <Tool
- Name="VCWebServiceProxyGeneratorTool"
- />
- <Tool
- Name="VCMIDLTool"
- TargetEnvironment="3"
- />
- <Tool
- Name="VCCLCompilerTool"
- FavorSizeOrSpeed="1"
- AdditionalIncludeDirectories="../../f2c"
- PreprocessorDefinitions="STRICT;__STDC__;_CRT_SECURE_NO_DEPRECATE"
- RuntimeLibrary="0"
- EnableEnhancedInstructionSet="1"
- UsePrecompiledHeader="0"
- ObjectFile="$(ConfigurationName)/"
- ProgramDataBaseFileName="$(ConfigurationName)/vc80.pdb"
- WarningLevel="3"
- Detect64BitPortabilityProblems="false"
- DebugInformationFormat="3"
- />
- <Tool
- Name="VCManagedResourceCompilerTool"
- />
- <Tool
- Name="VCResourceCompilerTool"
- />
- <Tool
- Name="VCPreLinkEventTool"
- />
- <Tool
- Name="VCLinkerTool"
- OutputFile="../../../bin/blasplus.dll"
- ModuleDefinitionFile="blasplusAtlas.def"
- RandomizedBaseAddress="1"
- DataExecutionPrevention="0"
- ImportLibrary="../../../bin/blasplus.lib"
- TargetMachine="17"
- CLRUnmanagedCodeCheck="true"
- />
- <Tool
- Name="VCALinkTool"
- />
- <Tool
- Name="VCManifestTool"
- />
- <Tool
- Name="VCXDCMakeTool"
- />
- <Tool
- Name="VCBscMakeTool"
- />
- <Tool
- Name="VCFxCopTool"
- />
- <Tool
- Name="VCAppVerifierTool"
- />
- <Tool
- Name="VCPostBuildEventTool"
- CommandLine=""
- />
- </Configuration>
- </Configurations>
- <References>
- </References>
- <Files>
- <Filter
- Name="Source Files"
- Filter="cpp;c;cxx;def;odl;idl;hpj;bat;asm;asmx"
- >
- <File
- RelativePath="..\dasum.c"
- >
- </File>
- <File
- RelativePath="..\daxpy.c"
- >
- </File>
- <File
- RelativePath="..\dcabs1.c"
- >
- </File>
- <File
- RelativePath="..\dcopy.c"
- >
- </File>
- <File
- RelativePath="..\ddot.c"
- >
- </File>
- <File
- RelativePath="..\dgbmv.c"
- >
- </File>
- <File
- RelativePath="..\dgemm.c"
- >
- </File>
- <File
- RelativePath="..\dgemv.c"
- >
- </File>
- <File
- RelativePath="..\dger.c"
- >
- </File>
- <File
- RelativePath="..\dnrm2.c"
- >
- </File>
- <File
- RelativePath="..\drot.c"
- >
- </File>
- <File
- RelativePath="..\drotg.c"
- >
- </File>
- <File
- RelativePath="..\dsbmv.c"
- >
- </File>
- <File
- RelativePath="..\dscal.c"
- >
- </File>
- <File
- RelativePath="..\dspmv.c"
- >
- </File>
- <File
- RelativePath="..\dspr.c"
- >
- </File>
- <File
- RelativePath="..\dspr2.c"
- >
- </File>
- <File
- RelativePath="..\dswap.c"
- >
- </File>
- <File
- RelativePath="..\dsymm.c"
- >
- </File>
- <File
- RelativePath="..\dsymv.c"
- >
- </File>
- <File
- RelativePath="..\dsyr.c"
- >
- </File>
- <File
- RelativePath="..\dsyr2.c"
- >
- </File>
- <File
- RelativePath="..\dsyr2k.c"
- >
- </File>
- <File
- RelativePath="..\dsyrk.c"
- >
- </File>
- <File
- RelativePath="..\dtbmv.c"
- >
- </File>
- <File
- RelativePath="..\dtbsv.c"
- >
- </File>
- <File
- RelativePath="..\dtpmv.c"
- >
- </File>
- <File
- RelativePath="..\dtpsv.c"
- >
- </File>
- <File
- RelativePath="..\dtrmm.c"
- >
- </File>
- <File
- RelativePath="..\dtrmv.c"
- >
- </File>
- <File
- RelativePath="..\dtrsm.c"
- >
- </File>
- <File
- RelativePath="..\dtrsv.c"
- >
- </File>
- <File
- RelativePath="..\dzasum.c"
- >
- </File>
- <File
- RelativePath="..\dznrm2.c"
- >
- </File>
- <File
- RelativePath="..\idamax.c"
- >
- </File>
- <File
- RelativePath="..\izamax.c"
- >
- </File>
- <File
- RelativePath="..\lsame.c"
- >
- </File>
- <File
- RelativePath="..\xerbla.c"
- >
- </File>
- <File
- RelativePath="..\zaxpy.c"
- >
- </File>
- <File
- RelativePath="..\zcopy.c"
- >
- </File>
- <File
- RelativePath="..\zdotc.c"
- >
- </File>
- <File
- RelativePath="..\zdotu.c"
- >
- </File>
- <File
- RelativePath="..\zdscal.c"
- >
- </File>
- <File
- RelativePath="..\zgbmv.c"
- >
- </File>
- <File
- RelativePath="..\zgemm.c"
- >
- </File>
- <File
- RelativePath="..\zgemv.c"
- >
- </File>
- <File
- RelativePath="..\zgerc.c"
- >
- </File>
- <File
- RelativePath="..\zgeru.c"
- >
- </File>
- <File
- RelativePath="..\zhbmv.c"
- >
- </File>
- <File
- RelativePath="..\zhemm.c"
- >
- </File>
- <File
- RelativePath="..\zhemv.c"
- >
- </File>
- <File
- RelativePath="..\zher.c"
- >
- </File>
- <File
- RelativePath="..\zher2.c"
- >
- </File>
- <File
- RelativePath="..\zher2k.c"
- >
- </File>
- <File
- RelativePath="..\zherk.c"
- >
- </File>
- <File
- RelativePath="..\zhpmv.c"
- >
- </File>
- <File
- RelativePath="..\zhpr.c"
- >
- </File>
- <File
- RelativePath="..\zhpr2.c"
- >
- </File>
- <File
- RelativePath="..\zrotg.c"
- >
- </File>
- <File
- RelativePath="..\zscal.c"
- >
- </File>
- <File
- RelativePath="..\zswap.c"
- >
- </File>
- <File
- RelativePath="..\zsymm.c"
- >
- </File>
- <File
- RelativePath="..\zsyr2k.c"
- >
- </File>
- <File
- RelativePath="..\zsyrk.c"
- >
- </File>
- <File
- RelativePath="..\ztbmv.c"
- >
- </File>
- <File
- RelativePath="..\ztbsv.c"
- >
- </File>
- <File
- RelativePath="..\ztpmv.c"
- >
- </File>
- <File
- RelativePath="..\ztpsv.c"
- >
- </File>
- <File
- RelativePath="..\ztrmm.c"
- >
- </File>
- <File
- RelativePath="..\ztrmv.c"
- >
- </File>
- <File
- RelativePath="..\ztrsm.c"
- >
- </File>
- <File
- RelativePath="..\ztrsv.c"
- >
- </File>
- </Filter>
- <Filter
- Name="Header Files"
- Filter="h;hpp;hxx;hm;inl;inc;xsd"
- >
- </Filter>
- <Filter
- Name="Resource Files"
- Filter="rc;ico;cur;bmp;dlg;rc2;rct;bin;rgs;gif;jpg;jpeg;jpe;resx"
- >
- </Filter>
- <Filter
- Name="Fortran Files"
- Filter="*.f"
- >
- <File
- RelativePath="..\dasum.f"
- >
- </File>
- <File
- RelativePath="..\daxpy.f"
- >
- </File>
- <File
- RelativePath="..\dcabs1.f"
- >
- </File>
- <File
- RelativePath="..\dcopy.f"
- >
- </File>
- <File
- RelativePath="..\ddot.f"
- >
- </File>
- <File
- RelativePath="..\dgbmv.f"
- >
- </File>
- <File
- RelativePath="..\dgemm.f"
- >
- </File>
- <File
- RelativePath="..\dgemv.f"
- >
- </File>
- <File
- RelativePath="..\dger.f"
- >
- </File>
- <File
- RelativePath="..\dnrm2.f"
- >
- </File>
- <File
- RelativePath="..\drot.f"
- >
- </File>
- <File
- RelativePath="..\drotg.f"
- >
- </File>
- <File
- RelativePath="..\dsbmv.f"
- >
- </File>
- <File
- RelativePath="..\dscal.f"
- >
- </File>
- <File
- RelativePath="..\dspmv.f"
- >
- </File>
- <File
- RelativePath="..\dspr.f"
- >
- </File>
- <File
- RelativePath="..\dspr2.f"
- >
- </File>
- <File
- RelativePath="..\dswap.f"
- >
- </File>
- <File
- RelativePath="..\dsymm.f"
- >
- </File>
- <File
- RelativePath="..\dsymv.f"
- >
- </File>
- <File
- RelativePath="..\dsyr.f"
- >
- </File>
- <File
- RelativePath="..\dsyr2.f"
- >
- </File>
- <File
- RelativePath="..\dsyr2k.f"
- >
- </File>
- <File
- RelativePath="..\dsyrk.f"
- >
- </File>
- <File
- RelativePath="..\dtbmv.f"
- >
- </File>
- <File
- RelativePath="..\dtbsv.f"
- >
- </File>
- <File
- RelativePath="..\dtpmv.f"
- >
- </File>
- <File
- RelativePath="..\dtpsv.f"
- >
- </File>
- <File
- RelativePath="..\dtrmm.f"
- >
- </File>
- <File
- RelativePath="..\dtrmv.f"
- >
- </File>
- <File
- RelativePath="..\dtrsm.f"
- >
- </File>
- <File
- RelativePath="..\dtrsv.f"
- >
- </File>
- <File
- RelativePath="..\dzasum.f"
- >
- </File>
- <File
- RelativePath="..\dznrm2.f"
- >
- </File>
- <File
- RelativePath="..\idamax.f"
- >
- </File>
- <File
- RelativePath="..\izamax.f"
- >
- </File>
- <File
- RelativePath="..\lsame.f"
- >
- </File>
- <File
- RelativePath="..\xerbla.f"
- >
- </File>
- <File
- RelativePath="..\zaxpy.f"
- >
- </File>
- <File
- RelativePath="..\zcopy.f"
- >
- </File>
- <File
- RelativePath="..\zdotc.f"
- >
- </File>
- <File
- RelativePath="..\zdotu.f"
- >
- </File>
- <File
- RelativePath="..\zdscal.f"
- >
- </File>
- <File
- RelativePath="..\zgbmv.f"
- >
- </File>
- <File
- RelativePath="..\zgemm.f"
- >
- </File>
- <File
- RelativePath="..\zgemv.f"
- >
- </File>
- <File
- RelativePath="..\zgerc.f"
- >
- </File>
- <File
- RelativePath="..\zgeru.f"
- >
- </File>
- <File
- RelativePath="..\zhbmv.f"
- >
- </File>
- <File
- RelativePath="..\zhemm.f"
- >
- </File>
- <File
- RelativePath="..\zhemv.f"
- >
- </File>
- <File
- RelativePath="..\zher.f"
- >
- </File>
- <File
- RelativePath="..\zher2.f"
- >
- </File>
- <File
- RelativePath="..\zher2k.f"
- >
- </File>
- <File
- RelativePath="..\zherk.f"
- >
- </File>
- <File
- RelativePath="..\zhpmv.f"
- >
- </File>
- <File
- RelativePath="..\zhpr.f"
- >
- </File>
- <File
- RelativePath="..\zhpr2.f"
- >
- </File>
- <File
- RelativePath="..\zrotg.f"
- >
- </File>
- <File
- RelativePath="..\zscal.f"
- >
- </File>
- <File
- RelativePath="..\zswap.f"
- >
- </File>
- <File
- RelativePath="..\zsymm.f"
- >
- </File>
- <File
- RelativePath="..\zsyr2k.f"
- >
- </File>
- <File
- RelativePath="..\zsyrk.f"
- >
- </File>
- <File
- RelativePath="..\ztbmv.f"
- >
- </File>
- <File
- RelativePath="..\ztbsv.f"
- >
- </File>
- <File
- RelativePath="..\ztpmv.f"
- >
- </File>
- <File
- RelativePath="..\ztpsv.f"
- >
- </File>
- <File
- RelativePath="..\ztrmm.f"
- >
- </File>
- <File
- RelativePath="..\ztrmv.f"
- >
- </File>
- <File
- RelativePath="..\ztrsm.f"
- >
- </File>
- <File
- RelativePath="..\ztrsv.f"
- >
- <FileConfiguration
- Name="Debug|Win32"
- >
- <Tool
- Name="f2c rule"
- CommandLine="cd "$(InputDir)"
"$(SolutionDir)bin\f2c.exe" -E -I..\..\..\core\includes -I..\..\..\..\core\includes "$(InputFileName)" 2>NUL

"
- />
- </FileConfiguration>
- <FileConfiguration
- Name="Debug|x64"
- >
- <Tool
- Name="f2c rule"
- CommandLine="cd "$(InputDir)"
"$(SolutionDir)bin\f2c.exe" -E -I..\..\..\core\includes -I..\..\..\..\core\includes "$(InputFileName)" 2>NUL

"
- />
- </FileConfiguration>
- <FileConfiguration
- Name="Release|Win32"
- >
- <Tool
- Name="f2c rule"
- CommandLine="cd "$(InputDir)"
"$(SolutionDir)bin\f2c.exe" -E -I..\..\..\core\includes -I..\..\..\..\core\includes "$(InputFileName)" 2>NUL

"
- />
- </FileConfiguration>
- <FileConfiguration
- Name="Release|x64"
- >
- <Tool
- Name="f2c rule"
- CommandLine="cd "$(InputDir)"
"$(SolutionDir)bin\f2c.exe" -E -I..\..\..\core\includes -I..\..\..\..\core\includes "$(InputFileName)" 2>NUL

"
- />
- </FileConfiguration>
- </File>
- </Filter>
- <File
- RelativePath="..\..\..\..\bin\libf2c.lib"
- >
- </File>
- <File
- RelativePath="..\Makefile.am"
- >
- </File>
- </Files>
- <Globals>
- </Globals>
-</VisualStudioProject>
diff --git a/src/lib/blas/dasum.f b/src/lib/blas/dasum.f deleted file mode 100644 index 28b128a8..00000000 --- a/src/lib/blas/dasum.f +++ /dev/null @@ -1,43 +0,0 @@ - double precision function dasum(n,dx,incx) -c -c takes the sum of the absolute values. -c jack dongarra, linpack, 3/11/78. -c modified 3/93 to return if incx .le. 0. -c modified 12/3/93, array(1) declarations changed to array(*) -c - double precision dx(*),dtemp - integer i,incx,m,mp1,n,nincx -c - dasum = 0.0d0 - dtemp = 0.0d0 - if( n.le.0 .or. incx.le.0 )return - if(incx.eq.1)go to 20 -c -c code for increment not equal to 1 -c - nincx = n*incx - do 10 i = 1,nincx,incx - dtemp = dtemp + dabs(dx(i)) - 10 continue - dasum = dtemp - return -c -c code for increment equal to 1 -c -c -c clean-up loop -c - 20 m = mod(n,6) - if( m .eq. 0 ) go to 40 - do 30 i = 1,m - dtemp = dtemp + dabs(dx(i)) - 30 continue - if( n .lt. 6 ) go to 60 - 40 mp1 = m + 1 - do 50 i = mp1,n,6 - dtemp = dtemp + dabs(dx(i)) + dabs(dx(i + 1)) + dabs(dx(i + 2)) - * + dabs(dx(i + 3)) + dabs(dx(i + 4)) + dabs(dx(i + 5)) - 50 continue - 60 dasum = dtemp - return - end diff --git a/src/lib/blas/daxpy.f b/src/lib/blas/daxpy.f deleted file mode 100644 index 91daa3c6..00000000 --- a/src/lib/blas/daxpy.f +++ /dev/null @@ -1,48 +0,0 @@ - subroutine daxpy(n,da,dx,incx,dy,incy) -c -c constant times a vector plus a vector. -c uses unrolled loops for increments equal to one. -c jack dongarra, linpack, 3/11/78. -c modified 12/3/93, array(1) declarations changed to array(*) -c - double precision dx(*),dy(*),da - integer i,incx,incy,ix,iy,m,mp1,n -c - if(n.le.0)return - if (da .eq. 0.0d0) return - if(incx.eq.1.and.incy.eq.1)go to 20 -c -c code for unequal increments or equal increments -c not equal to 1 -c - ix = 1 - iy = 1 - if(incx.lt.0)ix = (-n+1)*incx + 1 - if(incy.lt.0)iy = (-n+1)*incy + 1 - do 10 i = 1,n - dy(iy) = dy(iy) + da*dx(ix) - ix = ix + incx - iy = iy + incy - 10 continue - return -c -c code for both increments equal to 1 -c -c -c clean-up loop -c - 20 m = mod(n,4) - if( m .eq. 0 ) go to 40 - do 30 i = 1,m - dy(i) = dy(i) + da*dx(i) - 30 continue - if( n .lt. 4 ) return - 40 mp1 = m + 1 - do 50 i = mp1,n,4 - dy(i) = dy(i) + da*dx(i) - dy(i + 1) = dy(i + 1) + da*dx(i + 1) - dy(i + 2) = dy(i + 2) + da*dx(i + 2) - dy(i + 3) = dy(i + 3) + da*dx(i + 3) - 50 continue - return - end diff --git a/src/lib/blas/dcabs1.f b/src/lib/blas/dcabs1.f deleted file mode 100644 index 385ea5e1..00000000 --- a/src/lib/blas/dcabs1.f +++ /dev/null @@ -1,8 +0,0 @@ - double precision function dcabs1(z) - double complex z,zz - double precision t(2) - equivalence (zz,t(1)) - zz = z - dcabs1 = dabs(t(1)) + dabs(t(2)) - return - end diff --git a/src/lib/blas/dcopy.f b/src/lib/blas/dcopy.f deleted file mode 100644 index e1689271..00000000 --- a/src/lib/blas/dcopy.f +++ /dev/null @@ -1,50 +0,0 @@ - subroutine dcopy(n,dx,incx,dy,incy) -c -c copies a vector, x, to a vector, y. -c uses unrolled loops for increments equal to one. -c jack dongarra, linpack, 3/11/78. -c modified 12/3/93, array(1) declarations changed to array(*) -c - double precision dx(*),dy(*) - integer i,incx,incy,ix,iy,m,mp1,n -c - if(n.le.0)return - if(incx.eq.1.and.incy.eq.1)go to 20 -c -c code for unequal increments or equal increments -c not equal to 1 -c - ix = 1 - iy = 1 - if(incx.lt.0)ix = (-n+1)*incx + 1 - if(incy.lt.0)iy = (-n+1)*incy + 1 - do 10 i = 1,n - dy(iy) = dx(ix) - ix = ix + incx - iy = iy + incy - 10 continue - return -c -c code for both increments equal to 1 -c -c -c clean-up loop -c - 20 m = mod(n,7) - if( m .eq. 0 ) go to 40 - do 30 i = 1,m - dy(i) = dx(i) - 30 continue - if( n .lt. 7 ) return - 40 mp1 = m + 1 - do 50 i = mp1,n,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) - 50 continue - return - end diff --git a/src/lib/blas/ddot.f b/src/lib/blas/ddot.f deleted file mode 100644 index e04c7c25..00000000 --- a/src/lib/blas/ddot.f +++ /dev/null @@ -1,49 +0,0 @@ - double precision function ddot(n,dx,incx,dy,incy) -c -c forms the dot product of two vectors. -c uses unrolled loops for increments equal to one. -c jack dongarra, linpack, 3/11/78. -c modified 12/3/93, array(1) declarations changed to array(*) -c - double precision dx(*),dy(*),dtemp - integer i,incx,incy,ix,iy,m,mp1,n -c - ddot = 0.0d0 - dtemp = 0.0d0 - if(n.le.0)return - if(incx.eq.1.and.incy.eq.1)go to 20 -c -c code for unequal increments or equal increments -c not equal to 1 -c - ix = 1 - iy = 1 - if(incx.lt.0)ix = (-n+1)*incx + 1 - if(incy.lt.0)iy = (-n+1)*incy + 1 - do 10 i = 1,n - dtemp = dtemp + dx(ix)*dy(iy) - ix = ix + incx - iy = iy + incy - 10 continue - ddot = dtemp - return -c -c code for both increments equal to 1 -c -c -c clean-up loop -c - 20 m = mod(n,5) - if( m .eq. 0 ) go to 40 - do 30 i = 1,m - dtemp = dtemp + dx(i)*dy(i) - 30 continue - if( n .lt. 5 ) go to 60 - 40 mp1 = m + 1 - do 50 i = mp1,n,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) - 50 continue - 60 ddot = dtemp - return - end diff --git a/src/lib/blas/dgbmv.f b/src/lib/blas/dgbmv.f deleted file mode 100644 index e9c8f76f..00000000 --- a/src/lib/blas/dgbmv.f +++ /dev/null @@ -1,300 +0,0 @@ - SUBROUTINE DGBMV ( TRANS, M, N, KL, KU, ALPHA, A, LDA, X, INCX, - $ BETA, Y, INCY ) -* .. Scalar Arguments .. - DOUBLE PRECISION ALPHA, BETA - INTEGER INCX, INCY, KL, KU, LDA, M, N - CHARACTER*1 TRANS -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), X( * ), Y( * ) -* .. -* -* 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 .. - DOUBLE PRECISION ONE , ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. Local Scalars .. - DOUBLE PRECISION TEMP - INTEGER I, INFO, IX, IY, J, JX, JY, K, KUP1, KX, KY, - $ LENX, LENY -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. External Subroutines .. - EXTERNAL XERBLA -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - IF ( .NOT.LSAME( TRANS, 'N' ).AND. - $ .NOT.LSAME( TRANS, 'T' ).AND. - $ .NOT.LSAME( TRANS, 'C' ) )THEN - INFO = 1 - ELSE IF( M.LT.0 )THEN - INFO = 2 - ELSE IF( N.LT.0 )THEN - INFO = 3 - ELSE IF( KL.LT.0 )THEN - INFO = 4 - ELSE IF( KU.LT.0 )THEN - INFO = 5 - ELSE IF( LDA.LT.( KL + KU + 1 ) )THEN - INFO = 8 - ELSE IF( INCX.EQ.0 )THEN - INFO = 10 - ELSE IF( INCY.EQ.0 )THEN - INFO = 13 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'DGBMV ', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR. - $ ( ( ALPHA.EQ.ZERO ).AND.( BETA.EQ.ONE ) ) ) - $ RETURN -* -* Set LENX and LENY, the lengths of the vectors x and y, and set -* up the start points in X and Y. -* - IF( LSAME( TRANS, 'N' ) )THEN - LENX = N - LENY = M - ELSE - LENX = M - LENY = N - END IF - IF( INCX.GT.0 )THEN - KX = 1 - ELSE - KX = 1 - ( LENX - 1 )*INCX - END IF - IF( INCY.GT.0 )THEN - KY = 1 - ELSE - KY = 1 - ( LENY - 1 )*INCY - END IF -* -* 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.NE.ONE )THEN - IF( INCY.EQ.1 )THEN - IF( BETA.EQ.ZERO )THEN - DO 10, I = 1, LENY - Y( I ) = ZERO - 10 CONTINUE - ELSE - DO 20, I = 1, LENY - Y( I ) = BETA*Y( I ) - 20 CONTINUE - END IF - ELSE - IY = KY - IF( BETA.EQ.ZERO )THEN - DO 30, I = 1, LENY - Y( IY ) = ZERO - IY = IY + INCY - 30 CONTINUE - ELSE - DO 40, I = 1, LENY - Y( IY ) = BETA*Y( IY ) - IY = IY + INCY - 40 CONTINUE - END IF - END IF - END IF - IF( ALPHA.EQ.ZERO ) - $ RETURN - KUP1 = KU + 1 - IF( LSAME( TRANS, 'N' ) )THEN -* -* Form y := alpha*A*x + y. -* - JX = KX - IF( INCY.EQ.1 )THEN - DO 60, J = 1, N - IF( X( JX ).NE.ZERO )THEN - TEMP = ALPHA*X( JX ) - K = KUP1 - J - DO 50, I = MAX( 1, J - KU ), MIN( M, J + KL ) - Y( I ) = Y( I ) + TEMP*A( K + I, J ) - 50 CONTINUE - END IF - JX = JX + INCX - 60 CONTINUE - ELSE - DO 80, J = 1, N - IF( X( JX ).NE.ZERO )THEN - TEMP = ALPHA*X( JX ) - IY = KY - K = KUP1 - J - DO 70, I = MAX( 1, J - KU ), MIN( M, J + KL ) - Y( IY ) = Y( IY ) + TEMP*A( K + I, J ) - IY = IY + INCY - 70 CONTINUE - END IF - JX = JX + INCX - IF( J.GT.KU ) - $ KY = KY + INCY - 80 CONTINUE - END IF - ELSE -* -* Form y := alpha*A'*x + y. -* - JY = KY - IF( INCX.EQ.1 )THEN - DO 100, J = 1, N - TEMP = ZERO - K = KUP1 - J - DO 90, I = MAX( 1, J - KU ), MIN( M, J + KL ) - TEMP = TEMP + A( K + I, J )*X( I ) - 90 CONTINUE - Y( JY ) = Y( JY ) + ALPHA*TEMP - JY = JY + INCY - 100 CONTINUE - ELSE - DO 120, J = 1, N - TEMP = ZERO - IX = KX - K = KUP1 - J - DO 110, I = MAX( 1, J - KU ), MIN( M, J + KL ) - TEMP = TEMP + A( K + I, J )*X( IX ) - IX = IX + INCX - 110 CONTINUE - Y( JY ) = Y( JY ) + ALPHA*TEMP - JY = JY + INCY - IF( J.GT.KU ) - $ KX = KX + INCX - 120 CONTINUE - END IF - END IF -* - RETURN -* -* End of DGBMV . -* - END diff --git a/src/lib/blas/dgemm.f b/src/lib/blas/dgemm.f deleted file mode 100644 index 1531fd57..00000000 --- a/src/lib/blas/dgemm.f +++ /dev/null @@ -1,315 +0,0 @@ - SUBROUTINE DGEMM ( TRANSA, TRANSB, M, N, K, ALPHA, A, LDA, B, LDB, - $ BETA, C, LDC ) -* .. Scalar Arguments .. - CHARACTER*1 TRANSA, TRANSB - INTEGER M, N, K, LDA, LDB, LDC - DOUBLE PRECISION ALPHA, BETA -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), B( LDB, * ), C( LDC, * ) -* .. -C WARNING : this routine has been modified for Scilab (see comments -C Cscilab) because algorithm is not ok if A matrix contains NaN -C (NaN*0 should be NaN, not 0) -* 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 .. - LOGICAL LSAME - EXTERNAL LSAME -* .. External Subroutines .. - EXTERNAL XERBLA -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. Local Scalars .. - LOGICAL NOTA, NOTB - INTEGER I, INFO, J, L, NCOLA, NROWA, NROWB - DOUBLE PRECISION TEMP -* .. Parameters .. - DOUBLE PRECISION ONE , ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. -* .. 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. -* - NOTA = LSAME( TRANSA, 'N' ) - NOTB = LSAME( TRANSB, 'N' ) - IF( NOTA )THEN - NROWA = M - NCOLA = K - ELSE - NROWA = K - NCOLA = M - END IF - IF( NOTB )THEN - NROWB = K - ELSE - NROWB = N - END IF -* -* Test the input parameters. -* - INFO = 0 - IF( ( .NOT.NOTA ).AND. - $ ( .NOT.LSAME( TRANSA, 'C' ) ).AND. - $ ( .NOT.LSAME( TRANSA, 'T' ) ) )THEN - INFO = 1 - ELSE IF( ( .NOT.NOTB ).AND. - $ ( .NOT.LSAME( TRANSB, 'C' ) ).AND. - $ ( .NOT.LSAME( TRANSB, 'T' ) ) )THEN - INFO = 2 - ELSE IF( M .LT.0 )THEN - INFO = 3 - ELSE IF( N .LT.0 )THEN - INFO = 4 - ELSE IF( K .LT.0 )THEN - INFO = 5 - ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN - INFO = 8 - ELSE IF( LDB.LT.MAX( 1, NROWB ) )THEN - INFO = 10 - ELSE IF( LDC.LT.MAX( 1, M ) )THEN - INFO = 13 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'DGEMM ', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR. - $ ( ( ( ALPHA.EQ.ZERO ).OR.( K.EQ.0 ) ).AND.( BETA.EQ.ONE ) ) ) - $ RETURN -* -* And if alpha.eq.zero. -* - IF( ALPHA.EQ.ZERO )THEN - IF( BETA.EQ.ZERO )THEN - DO 20, J = 1, N - DO 10, I = 1, M - C( I, J ) = ZERO - 10 CONTINUE - 20 CONTINUE - ELSE - DO 40, J = 1, N - DO 30, I = 1, M - C( I, J ) = BETA*C( I, J ) - 30 CONTINUE - 40 CONTINUE - END IF - RETURN - END IF -* -* Start the operations. -* - IF( NOTB )THEN - IF( NOTA )THEN -* -* Form C := alpha*A*B + beta*C. -* - DO 90, J = 1, N - IF( BETA.EQ.ZERO )THEN - DO 50, I = 1, M - C( I, J ) = ZERO - 50 CONTINUE - ELSE IF( BETA.NE.ONE )THEN - DO 60, I = 1, M - C( I, J ) = BETA*C( I, J ) - 60 CONTINUE - END IF - DO 80, L = 1, K -Cscilab IF( B( L, J ).NE.ZERO )THEN - TEMP = ALPHA*B( L, J ) - DO 70, I = 1, M - C( I, J ) = C( I, J ) + TEMP*A( I, L ) - 70 CONTINUE -Cscilab END IF - 80 CONTINUE - 90 CONTINUE - ELSE -* -* Form C := alpha*A'*B + beta*C -* - DO 120, J = 1, N - DO 110, I = 1, M - TEMP = ZERO - DO 100, L = 1, K - TEMP = TEMP + A( L, I )*B( L, J ) - 100 CONTINUE - IF( BETA.EQ.ZERO )THEN - C( I, J ) = ALPHA*TEMP - ELSE - C( I, J ) = ALPHA*TEMP + BETA*C( I, J ) - END IF - 110 CONTINUE - 120 CONTINUE - END IF - ELSE - IF( NOTA )THEN -* -* Form C := alpha*A*B' + beta*C -* - DO 170, J = 1, N - IF( BETA.EQ.ZERO )THEN - DO 130, I = 1, M - C( I, J ) = ZERO - 130 CONTINUE - ELSE IF( BETA.NE.ONE )THEN - DO 140, I = 1, M - C( I, J ) = BETA*C( I, J ) - 140 CONTINUE - END IF - DO 160, L = 1, K -Cscilab IF( B( J, L ).NE.ZERO )THEN - TEMP = ALPHA*B( J, L ) - DO 150, I = 1, M - C( I, J ) = C( I, J ) + TEMP*A( I, L ) - 150 CONTINUE -Cscilab END IF - 160 CONTINUE - 170 CONTINUE - ELSE -* -* Form C := alpha*A'*B' + beta*C -* - DO 200, J = 1, N - DO 190, I = 1, M - TEMP = ZERO - DO 180, L = 1, K - TEMP = TEMP + A( L, I )*B( J, L ) - 180 CONTINUE - IF( BETA.EQ.ZERO )THEN - C( I, J ) = ALPHA*TEMP - ELSE - C( I, J ) = ALPHA*TEMP + BETA*C( I, J ) - END IF - 190 CONTINUE - 200 CONTINUE - END IF - END IF -* - RETURN -* -* End of DGEMM . -* - END diff --git a/src/lib/blas/dgemv.f b/src/lib/blas/dgemv.f deleted file mode 100644 index 8ef80b3a..00000000 --- a/src/lib/blas/dgemv.f +++ /dev/null @@ -1,261 +0,0 @@ - SUBROUTINE DGEMV ( TRANS, M, N, ALPHA, A, LDA, X, INCX, - $ BETA, Y, INCY ) -* .. Scalar Arguments .. - DOUBLE PRECISION ALPHA, BETA - INTEGER INCX, INCY, LDA, M, N - CHARACTER*1 TRANS -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), X( * ), Y( * ) -* .. -* -* 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 .. - DOUBLE PRECISION ONE , ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. Local Scalars .. - DOUBLE PRECISION TEMP - INTEGER I, INFO, IX, IY, J, JX, JY, KX, KY, LENX, LENY -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. External Subroutines .. - EXTERNAL XERBLA -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - IF ( .NOT.LSAME( TRANS, 'N' ).AND. - $ .NOT.LSAME( TRANS, 'T' ).AND. - $ .NOT.LSAME( TRANS, 'C' ) )THEN - INFO = 1 - ELSE IF( M.LT.0 )THEN - INFO = 2 - ELSE IF( N.LT.0 )THEN - INFO = 3 - ELSE IF( LDA.LT.MAX( 1, M ) )THEN - INFO = 6 - ELSE IF( INCX.EQ.0 )THEN - INFO = 8 - ELSE IF( INCY.EQ.0 )THEN - INFO = 11 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'DGEMV ', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR. - $ ( ( ALPHA.EQ.ZERO ).AND.( BETA.EQ.ONE ) ) ) - $ RETURN -* -* Set LENX and LENY, the lengths of the vectors x and y, and set -* up the start points in X and Y. -* - IF( LSAME( TRANS, 'N' ) )THEN - LENX = N - LENY = M - ELSE - LENX = M - LENY = N - END IF - IF( INCX.GT.0 )THEN - KX = 1 - ELSE - KX = 1 - ( LENX - 1 )*INCX - END IF - IF( INCY.GT.0 )THEN - KY = 1 - ELSE - KY = 1 - ( LENY - 1 )*INCY - END IF -* -* 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.NE.ONE )THEN - IF( INCY.EQ.1 )THEN - IF( BETA.EQ.ZERO )THEN - DO 10, I = 1, LENY - Y( I ) = ZERO - 10 CONTINUE - ELSE - DO 20, I = 1, LENY - Y( I ) = BETA*Y( I ) - 20 CONTINUE - END IF - ELSE - IY = KY - IF( BETA.EQ.ZERO )THEN - DO 30, I = 1, LENY - Y( IY ) = ZERO - IY = IY + INCY - 30 CONTINUE - ELSE - DO 40, I = 1, LENY - Y( IY ) = BETA*Y( IY ) - IY = IY + INCY - 40 CONTINUE - END IF - END IF - END IF - IF( ALPHA.EQ.ZERO ) - $ RETURN - IF( LSAME( TRANS, 'N' ) )THEN -* -* Form y := alpha*A*x + y. -* - JX = KX - IF( INCY.EQ.1 )THEN - DO 60, J = 1, N - IF( X( JX ).NE.ZERO )THEN - TEMP = ALPHA*X( JX ) - DO 50, I = 1, M - Y( I ) = Y( I ) + TEMP*A( I, J ) - 50 CONTINUE - END IF - JX = JX + INCX - 60 CONTINUE - ELSE - DO 80, J = 1, N - IF( X( JX ).NE.ZERO )THEN - TEMP = ALPHA*X( JX ) - IY = KY - DO 70, I = 1, M - Y( IY ) = Y( IY ) + TEMP*A( I, J ) - IY = IY + INCY - 70 CONTINUE - END IF - JX = JX + INCX - 80 CONTINUE - END IF - ELSE -* -* Form y := alpha*A'*x + y. -* - JY = KY - IF( INCX.EQ.1 )THEN - DO 100, J = 1, N - TEMP = ZERO - DO 90, I = 1, M - TEMP = TEMP + A( I, J )*X( I ) - 90 CONTINUE - Y( JY ) = Y( JY ) + ALPHA*TEMP - JY = JY + INCY - 100 CONTINUE - ELSE - DO 120, J = 1, N - TEMP = ZERO - IX = KX - DO 110, I = 1, M - TEMP = TEMP + A( I, J )*X( IX ) - IX = IX + INCX - 110 CONTINUE - Y( JY ) = Y( JY ) + ALPHA*TEMP - JY = JY + INCY - 120 CONTINUE - END IF - END IF -* - RETURN -* -* End of DGEMV . -* - END diff --git a/src/lib/blas/dger.f b/src/lib/blas/dger.f deleted file mode 100644 index d316000a..00000000 --- a/src/lib/blas/dger.f +++ /dev/null @@ -1,157 +0,0 @@ - SUBROUTINE DGER ( M, N, ALPHA, X, INCX, Y, INCY, A, LDA ) -* .. Scalar Arguments .. - DOUBLE PRECISION ALPHA - INTEGER INCX, INCY, LDA, M, N -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), X( * ), Y( * ) -* .. -* -* 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 .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D+0 ) -* .. Local Scalars .. - DOUBLE PRECISION TEMP - INTEGER I, INFO, IX, J, JY, KX -* .. External Subroutines .. - EXTERNAL XERBLA -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - IF ( M.LT.0 )THEN - INFO = 1 - ELSE IF( N.LT.0 )THEN - INFO = 2 - ELSE IF( INCX.EQ.0 )THEN - INFO = 5 - ELSE IF( INCY.EQ.0 )THEN - INFO = 7 - ELSE IF( LDA.LT.MAX( 1, M ) )THEN - INFO = 9 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'DGER ', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR.( ALPHA.EQ.ZERO ) ) - $ RETURN -* -* Start the operations. In this version the elements of A are -* accessed sequentially with one pass through A. -* - IF( INCY.GT.0 )THEN - JY = 1 - ELSE - JY = 1 - ( N - 1 )*INCY - END IF - IF( INCX.EQ.1 )THEN - DO 20, J = 1, N - IF( Y( JY ).NE.ZERO )THEN - TEMP = ALPHA*Y( JY ) - DO 10, I = 1, M - A( I, J ) = A( I, J ) + X( I )*TEMP - 10 CONTINUE - END IF - JY = JY + INCY - 20 CONTINUE - ELSE - IF( INCX.GT.0 )THEN - KX = 1 - ELSE - KX = 1 - ( M - 1 )*INCX - END IF - DO 40, J = 1, N - IF( Y( JY ).NE.ZERO )THEN - TEMP = ALPHA*Y( JY ) - IX = KX - DO 30, I = 1, M - A( I, J ) = A( I, J ) + X( IX )*TEMP - IX = IX + INCX - 30 CONTINUE - END IF - JY = JY + INCY - 40 CONTINUE - END IF -* - RETURN -* -* End of DGER . -* - END diff --git a/src/lib/blas/dnrm2.f b/src/lib/blas/dnrm2.f deleted file mode 100644 index 119d0477..00000000 --- a/src/lib/blas/dnrm2.f +++ /dev/null @@ -1,60 +0,0 @@ - DOUBLE PRECISION FUNCTION DNRM2 ( N, X, INCX ) -* .. Scalar Arguments .. - INTEGER INCX, N -* .. Array Arguments .. - DOUBLE PRECISION X( * ) -* .. -* -* 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 .. - DOUBLE PRECISION ONE , ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. Local Scalars .. - INTEGER IX - DOUBLE PRECISION ABSXI, NORM, SCALE, SSQ -* .. Intrinsic Functions .. - INTRINSIC ABS, SQRT -* .. -* .. Executable Statements .. - IF( N.LT.1 .OR. INCX.LT.1 )THEN - NORM = ZERO - ELSE IF( N.EQ.1 )THEN - NORM = ABS( X( 1 ) ) - ELSE - SCALE = ZERO - SSQ = ONE -* The following loop is equivalent to this call to the LAPACK -* auxiliary routine: -* CALL DLASSQ( N, X, INCX, SCALE, SSQ ) -* - DO 10, IX = 1, 1 + ( N - 1 )*INCX, INCX - IF( X( IX ).NE.ZERO )THEN - ABSXI = ABS( X( IX ) ) - IF( SCALE.LT.ABSXI )THEN - SSQ = ONE + SSQ*( SCALE/ABSXI )**2 - SCALE = ABSXI - ELSE - SSQ = SSQ + ( ABSXI/SCALE )**2 - END IF - END IF - 10 CONTINUE - NORM = SCALE * SQRT( SSQ ) - END IF -* - DNRM2 = NORM - RETURN -* -* End of DNRM2. -* - END diff --git a/src/lib/blas/drot.f b/src/lib/blas/drot.f deleted file mode 100644 index b9ea3bd9..00000000 --- a/src/lib/blas/drot.f +++ /dev/null @@ -1,37 +0,0 @@ - subroutine drot (n,dx,incx,dy,incy,c,s) -c -c applies a plane rotation. -c jack dongarra, linpack, 3/11/78. -c modified 12/3/93, array(1) declarations changed to array(*) -c - double precision dx(*),dy(*),dtemp,c,s - integer i,incx,incy,ix,iy,n -c - if(n.le.0)return - if(incx.eq.1.and.incy.eq.1)go to 20 -c -c code for unequal increments or equal increments not equal -c to 1 -c - ix = 1 - iy = 1 - if(incx.lt.0)ix = (-n+1)*incx + 1 - if(incy.lt.0)iy = (-n+1)*incy + 1 - do 10 i = 1,n - dtemp = c*dx(ix) + s*dy(iy) - dy(iy) = c*dy(iy) - s*dx(ix) - dx(ix) = dtemp - ix = ix + incx - iy = iy + incy - 10 continue - return -c -c code for both increments equal to 1 -c - 20 do 30 i = 1,n - dtemp = c*dx(i) + s*dy(i) - dy(i) = c*dy(i) - s*dx(i) - dx(i) = dtemp - 30 continue - return - end diff --git a/src/lib/blas/drotg.f b/src/lib/blas/drotg.f deleted file mode 100644 index 67838e2c..00000000 --- a/src/lib/blas/drotg.f +++ /dev/null @@ -1,27 +0,0 @@ - subroutine drotg(da,db,c,s) -c -c construct givens plane rotation. -c jack dongarra, linpack, 3/11/78. -c - double precision da,db,c,s,roe,scale,r,z -c - roe = db - if( dabs(da) .gt. dabs(db) ) roe = da - scale = dabs(da) + dabs(db) - if( scale .ne. 0.0d0 ) go to 10 - c = 1.0d0 - s = 0.0d0 - r = 0.0d0 - z = 0.0d0 - go to 20 - 10 r = scale*dsqrt((da/scale)**2 + (db/scale)**2) - r = dsign(1.0d0,roe)*r - c = da/r - s = db/r - z = 1.0d0 - if( dabs(da) .gt. dabs(db) ) z = s - if( dabs(db) .ge. dabs(da) .and. c .ne. 0.0d0 ) z = 1.0d0/c - 20 da = r - db = z - return - end diff --git a/src/lib/blas/dsbmv.f b/src/lib/blas/dsbmv.f deleted file mode 100644 index 272042af..00000000 --- a/src/lib/blas/dsbmv.f +++ /dev/null @@ -1,303 +0,0 @@ - SUBROUTINE DSBMV ( UPLO, N, K, ALPHA, A, LDA, X, INCX, - $ BETA, Y, INCY ) -* .. Scalar Arguments .. - DOUBLE PRECISION ALPHA, BETA - INTEGER INCX, INCY, K, LDA, N - CHARACTER*1 UPLO -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), X( * ), Y( * ) -* .. -* -* 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 .. - DOUBLE PRECISION ONE , ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. Local Scalars .. - DOUBLE PRECISION TEMP1, TEMP2 - INTEGER I, INFO, IX, IY, J, JX, JY, KPLUS1, KX, KY, L -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. External Subroutines .. - EXTERNAL XERBLA -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - IF ( .NOT.LSAME( UPLO, 'U' ).AND. - $ .NOT.LSAME( UPLO, 'L' ) )THEN - INFO = 1 - ELSE IF( N.LT.0 )THEN - INFO = 2 - ELSE IF( K.LT.0 )THEN - INFO = 3 - ELSE IF( LDA.LT.( K + 1 ) )THEN - INFO = 6 - ELSE IF( INCX.EQ.0 )THEN - INFO = 8 - ELSE IF( INCY.EQ.0 )THEN - INFO = 11 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'DSBMV ', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( ( N.EQ.0 ).OR.( ( ALPHA.EQ.ZERO ).AND.( BETA.EQ.ONE ) ) ) - $ RETURN -* -* Set up the start points in X and Y. -* - IF( INCX.GT.0 )THEN - KX = 1 - ELSE - KX = 1 - ( N - 1 )*INCX - END IF - IF( INCY.GT.0 )THEN - KY = 1 - ELSE - KY = 1 - ( N - 1 )*INCY - END IF -* -* 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.NE.ONE )THEN - IF( INCY.EQ.1 )THEN - IF( BETA.EQ.ZERO )THEN - DO 10, I = 1, N - Y( I ) = ZERO - 10 CONTINUE - ELSE - DO 20, I = 1, N - Y( I ) = BETA*Y( I ) - 20 CONTINUE - END IF - ELSE - IY = KY - IF( BETA.EQ.ZERO )THEN - DO 30, I = 1, N - Y( IY ) = ZERO - IY = IY + INCY - 30 CONTINUE - ELSE - DO 40, I = 1, N - Y( IY ) = BETA*Y( IY ) - IY = IY + INCY - 40 CONTINUE - END IF - END IF - END IF - IF( ALPHA.EQ.ZERO ) - $ RETURN - IF( LSAME( UPLO, 'U' ) )THEN -* -* Form y when upper triangle of A is stored. -* - KPLUS1 = K + 1 - IF( ( INCX.EQ.1 ).AND.( INCY.EQ.1 ) )THEN - DO 60, J = 1, N - TEMP1 = ALPHA*X( J ) - TEMP2 = ZERO - L = KPLUS1 - J - DO 50, I = MAX( 1, J - K ), J - 1 - Y( I ) = Y( I ) + TEMP1*A( L + I, J ) - TEMP2 = TEMP2 + A( L + I, J )*X( I ) - 50 CONTINUE - Y( J ) = Y( J ) + TEMP1*A( KPLUS1, J ) + ALPHA*TEMP2 - 60 CONTINUE - ELSE - JX = KX - JY = KY - DO 80, J = 1, N - TEMP1 = ALPHA*X( JX ) - TEMP2 = ZERO - IX = KX - IY = KY - L = KPLUS1 - J - DO 70, I = MAX( 1, J - K ), J - 1 - Y( IY ) = Y( IY ) + TEMP1*A( L + I, J ) - TEMP2 = TEMP2 + A( L + I, J )*X( IX ) - IX = IX + INCX - IY = IY + INCY - 70 CONTINUE - Y( JY ) = Y( JY ) + TEMP1*A( KPLUS1, J ) + ALPHA*TEMP2 - JX = JX + INCX - JY = JY + INCY - IF( J.GT.K )THEN - KX = KX + INCX - KY = KY + INCY - END IF - 80 CONTINUE - END IF - ELSE -* -* Form y when lower triangle of A is stored. -* - IF( ( INCX.EQ.1 ).AND.( INCY.EQ.1 ) )THEN - DO 100, J = 1, N - TEMP1 = ALPHA*X( J ) - TEMP2 = ZERO - Y( J ) = Y( J ) + TEMP1*A( 1, J ) - L = 1 - J - DO 90, I = J + 1, MIN( N, J + K ) - Y( I ) = Y( I ) + TEMP1*A( L + I, J ) - TEMP2 = TEMP2 + A( L + I, J )*X( I ) - 90 CONTINUE - Y( J ) = Y( J ) + ALPHA*TEMP2 - 100 CONTINUE - ELSE - JX = KX - JY = KY - DO 120, J = 1, N - TEMP1 = ALPHA*X( JX ) - TEMP2 = ZERO - Y( JY ) = Y( JY ) + TEMP1*A( 1, J ) - L = 1 - J - IX = JX - IY = JY - DO 110, I = J + 1, MIN( N, J + K ) - IX = IX + INCX - IY = IY + INCY - Y( IY ) = Y( IY ) + TEMP1*A( L + I, J ) - TEMP2 = TEMP2 + A( L + I, J )*X( IX ) - 110 CONTINUE - Y( JY ) = Y( JY ) + ALPHA*TEMP2 - JX = JX + INCX - JY = JY + INCY - 120 CONTINUE - END IF - END IF -* - RETURN -* -* End of DSBMV . -* - END diff --git a/src/lib/blas/dscal.f b/src/lib/blas/dscal.f deleted file mode 100644 index e1467faf..00000000 --- a/src/lib/blas/dscal.f +++ /dev/null @@ -1,43 +0,0 @@ - subroutine dscal(n,da,dx,incx) -c -c scales a vector by a constant. -c uses unrolled loops for increment equal to one. -c jack dongarra, linpack, 3/11/78. -c modified 3/93 to return if incx .le. 0. -c modified 12/3/93, array(1) declarations changed to array(*) -c - double precision da,dx(*) - integer i,incx,m,mp1,n,nincx -c - if( n.le.0 .or. incx.le.0 )return - if(incx.eq.1)go to 20 -c -c code for increment not equal to 1 -c - nincx = n*incx - do 10 i = 1,nincx,incx - dx(i) = da*dx(i) - 10 continue - return -c -c code for increment equal to 1 -c -c -c clean-up loop -c - 20 m = mod(n,5) - if( m .eq. 0 ) go to 40 - do 30 i = 1,m - dx(i) = da*dx(i) - 30 continue - if( n .lt. 5 ) return - 40 mp1 = m + 1 - do 50 i = mp1,n,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) - 50 continue - return - end diff --git a/src/lib/blas/dspmv.f b/src/lib/blas/dspmv.f deleted file mode 100644 index 3ace7bf2..00000000 --- a/src/lib/blas/dspmv.f +++ /dev/null @@ -1,262 +0,0 @@ - SUBROUTINE DSPMV ( UPLO, N, ALPHA, AP, X, INCX, BETA, Y, INCY ) -* .. Scalar Arguments .. - DOUBLE PRECISION ALPHA, BETA - INTEGER INCX, INCY, N - CHARACTER*1 UPLO -* .. Array Arguments .. - DOUBLE PRECISION AP( * ), X( * ), Y( * ) -* .. -* -* 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 .. - DOUBLE PRECISION ONE , ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. Local Scalars .. - DOUBLE PRECISION TEMP1, TEMP2 - INTEGER I, INFO, IX, IY, J, JX, JY, K, KK, KX, KY -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. External Subroutines .. - EXTERNAL XERBLA -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - IF ( .NOT.LSAME( UPLO, 'U' ).AND. - $ .NOT.LSAME( UPLO, 'L' ) )THEN - INFO = 1 - ELSE IF( N.LT.0 )THEN - INFO = 2 - ELSE IF( INCX.EQ.0 )THEN - INFO = 6 - ELSE IF( INCY.EQ.0 )THEN - INFO = 9 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'DSPMV ', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( ( N.EQ.0 ).OR.( ( ALPHA.EQ.ZERO ).AND.( BETA.EQ.ONE ) ) ) - $ RETURN -* -* Set up the start points in X and Y. -* - IF( INCX.GT.0 )THEN - KX = 1 - ELSE - KX = 1 - ( N - 1 )*INCX - END IF - IF( INCY.GT.0 )THEN - KY = 1 - ELSE - KY = 1 - ( N - 1 )*INCY - END IF -* -* 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.NE.ONE )THEN - IF( INCY.EQ.1 )THEN - IF( BETA.EQ.ZERO )THEN - DO 10, I = 1, N - Y( I ) = ZERO - 10 CONTINUE - ELSE - DO 20, I = 1, N - Y( I ) = BETA*Y( I ) - 20 CONTINUE - END IF - ELSE - IY = KY - IF( BETA.EQ.ZERO )THEN - DO 30, I = 1, N - Y( IY ) = ZERO - IY = IY + INCY - 30 CONTINUE - ELSE - DO 40, I = 1, N - Y( IY ) = BETA*Y( IY ) - IY = IY + INCY - 40 CONTINUE - END IF - END IF - END IF - IF( ALPHA.EQ.ZERO ) - $ RETURN - KK = 1 - IF( LSAME( UPLO, 'U' ) )THEN -* -* Form y when AP contains the upper triangle. -* - IF( ( INCX.EQ.1 ).AND.( INCY.EQ.1 ) )THEN - DO 60, J = 1, N - TEMP1 = ALPHA*X( J ) - TEMP2 = ZERO - K = KK - DO 50, I = 1, J - 1 - Y( I ) = Y( I ) + TEMP1*AP( K ) - TEMP2 = TEMP2 + AP( K )*X( I ) - K = K + 1 - 50 CONTINUE - Y( J ) = Y( J ) + TEMP1*AP( KK + J - 1 ) + ALPHA*TEMP2 - KK = KK + J - 60 CONTINUE - ELSE - JX = KX - JY = KY - DO 80, J = 1, N - TEMP1 = ALPHA*X( JX ) - TEMP2 = ZERO - IX = KX - IY = KY - DO 70, K = KK, KK + J - 2 - Y( IY ) = Y( IY ) + TEMP1*AP( K ) - TEMP2 = TEMP2 + AP( K )*X( IX ) - IX = IX + INCX - IY = IY + INCY - 70 CONTINUE - Y( JY ) = Y( JY ) + TEMP1*AP( KK + J - 1 ) + ALPHA*TEMP2 - JX = JX + INCX - JY = JY + INCY - KK = KK + J - 80 CONTINUE - END IF - ELSE -* -* Form y when AP contains the lower triangle. -* - IF( ( INCX.EQ.1 ).AND.( INCY.EQ.1 ) )THEN - DO 100, J = 1, N - TEMP1 = ALPHA*X( J ) - TEMP2 = ZERO - Y( J ) = Y( J ) + TEMP1*AP( KK ) - K = KK + 1 - DO 90, I = J + 1, N - Y( I ) = Y( I ) + TEMP1*AP( K ) - TEMP2 = TEMP2 + AP( K )*X( I ) - K = K + 1 - 90 CONTINUE - Y( J ) = Y( J ) + ALPHA*TEMP2 - KK = KK + ( N - J + 1 ) - 100 CONTINUE - ELSE - JX = KX - JY = KY - DO 120, J = 1, N - TEMP1 = ALPHA*X( JX ) - TEMP2 = ZERO - Y( JY ) = Y( JY ) + TEMP1*AP( KK ) - IX = JX - IY = JY - DO 110, K = KK + 1, KK + N - J - IX = IX + INCX - IY = IY + INCY - Y( IY ) = Y( IY ) + TEMP1*AP( K ) - TEMP2 = TEMP2 + AP( K )*X( IX ) - 110 CONTINUE - Y( JY ) = Y( JY ) + ALPHA*TEMP2 - JX = JX + INCX - JY = JY + INCY - KK = KK + ( N - J + 1 ) - 120 CONTINUE - END IF - END IF -* - RETURN -* -* End of DSPMV . -* - END diff --git a/src/lib/blas/dspr.f b/src/lib/blas/dspr.f deleted file mode 100644 index 3da6889c..00000000 --- a/src/lib/blas/dspr.f +++ /dev/null @@ -1,198 +0,0 @@ - SUBROUTINE DSPR ( UPLO, N, ALPHA, X, INCX, AP ) -* .. Scalar Arguments .. - DOUBLE PRECISION ALPHA - INTEGER INCX, N - CHARACTER*1 UPLO -* .. Array Arguments .. - DOUBLE PRECISION AP( * ), X( * ) -* .. -* -* 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 .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D+0 ) -* .. Local Scalars .. - DOUBLE PRECISION TEMP - INTEGER I, INFO, IX, J, JX, K, KK, KX -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. External Subroutines .. - EXTERNAL XERBLA -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - IF ( .NOT.LSAME( UPLO, 'U' ).AND. - $ .NOT.LSAME( UPLO, 'L' ) )THEN - INFO = 1 - ELSE IF( N.LT.0 )THEN - INFO = 2 - ELSE IF( INCX.EQ.0 )THEN - INFO = 5 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'DSPR ', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( ( N.EQ.0 ).OR.( ALPHA.EQ.ZERO ) ) - $ RETURN -* -* Set the start point in X if the increment is not unity. -* - IF( INCX.LE.0 )THEN - KX = 1 - ( N - 1 )*INCX - ELSE IF( INCX.NE.1 )THEN - KX = 1 - END IF -* -* 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' ) )THEN -* -* Form A when upper triangle is stored in AP. -* - IF( INCX.EQ.1 )THEN - DO 20, J = 1, N - IF( X( J ).NE.ZERO )THEN - TEMP = ALPHA*X( J ) - K = KK - DO 10, I = 1, J - AP( K ) = AP( K ) + X( I )*TEMP - K = K + 1 - 10 CONTINUE - END IF - KK = KK + J - 20 CONTINUE - ELSE - JX = KX - DO 40, J = 1, N - IF( X( JX ).NE.ZERO )THEN - TEMP = ALPHA*X( JX ) - IX = KX - DO 30, K = KK, KK + J - 1 - AP( K ) = AP( K ) + X( IX )*TEMP - IX = IX + INCX - 30 CONTINUE - END IF - JX = JX + INCX - KK = KK + J - 40 CONTINUE - END IF - ELSE -* -* Form A when lower triangle is stored in AP. -* - IF( INCX.EQ.1 )THEN - DO 60, J = 1, N - IF( X( J ).NE.ZERO )THEN - TEMP = ALPHA*X( J ) - K = KK - DO 50, I = J, N - AP( K ) = AP( K ) + X( I )*TEMP - K = K + 1 - 50 CONTINUE - END IF - KK = KK + N - J + 1 - 60 CONTINUE - ELSE - JX = KX - DO 80, J = 1, N - IF( X( JX ).NE.ZERO )THEN - TEMP = ALPHA*X( JX ) - IX = JX - DO 70, K = KK, KK + N - J - AP( K ) = AP( K ) + X( IX )*TEMP - IX = IX + INCX - 70 CONTINUE - END IF - JX = JX + INCX - KK = KK + N - J + 1 - 80 CONTINUE - END IF - END IF -* - RETURN -* -* End of DSPR . -* - END diff --git a/src/lib/blas/dspr2.f b/src/lib/blas/dspr2.f deleted file mode 100644 index 1cfce21b..00000000 --- a/src/lib/blas/dspr2.f +++ /dev/null @@ -1,229 +0,0 @@ - SUBROUTINE DSPR2 ( UPLO, N, ALPHA, X, INCX, Y, INCY, AP ) -* .. Scalar Arguments .. - DOUBLE PRECISION ALPHA - INTEGER INCX, INCY, N - CHARACTER*1 UPLO -* .. Array Arguments .. - DOUBLE PRECISION AP( * ), X( * ), Y( * ) -* .. -* -* 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 .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D+0 ) -* .. Local Scalars .. - DOUBLE PRECISION TEMP1, TEMP2 - INTEGER I, INFO, IX, IY, J, JX, JY, K, KK, KX, KY -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. External Subroutines .. - EXTERNAL XERBLA -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - IF ( .NOT.LSAME( UPLO, 'U' ).AND. - $ .NOT.LSAME( UPLO, 'L' ) )THEN - INFO = 1 - ELSE IF( N.LT.0 )THEN - INFO = 2 - ELSE IF( INCX.EQ.0 )THEN - INFO = 5 - ELSE IF( INCY.EQ.0 )THEN - INFO = 7 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'DSPR2 ', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( ( N.EQ.0 ).OR.( ALPHA.EQ.ZERO ) ) - $ RETURN -* -* Set up the start points in X and Y if the increments are not both -* unity. -* - IF( ( INCX.NE.1 ).OR.( INCY.NE.1 ) )THEN - IF( INCX.GT.0 )THEN - KX = 1 - ELSE - KX = 1 - ( N - 1 )*INCX - END IF - IF( INCY.GT.0 )THEN - KY = 1 - ELSE - KY = 1 - ( N - 1 )*INCY - END IF - JX = KX - JY = KY - END IF -* -* 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' ) )THEN -* -* Form A when upper triangle is stored in AP. -* - IF( ( INCX.EQ.1 ).AND.( INCY.EQ.1 ) )THEN - DO 20, J = 1, N - IF( ( X( J ).NE.ZERO ).OR.( Y( J ).NE.ZERO ) )THEN - TEMP1 = ALPHA*Y( J ) - TEMP2 = ALPHA*X( J ) - K = KK - DO 10, I = 1, J - AP( K ) = AP( K ) + X( I )*TEMP1 + Y( I )*TEMP2 - K = K + 1 - 10 CONTINUE - END IF - KK = KK + J - 20 CONTINUE - ELSE - DO 40, J = 1, N - IF( ( X( JX ).NE.ZERO ).OR.( Y( JY ).NE.ZERO ) )THEN - TEMP1 = ALPHA*Y( JY ) - TEMP2 = ALPHA*X( JX ) - IX = KX - IY = KY - DO 30, K = KK, KK + J - 1 - AP( K ) = AP( K ) + X( IX )*TEMP1 + Y( IY )*TEMP2 - IX = IX + INCX - IY = IY + INCY - 30 CONTINUE - END IF - JX = JX + INCX - JY = JY + INCY - KK = KK + J - 40 CONTINUE - END IF - ELSE -* -* Form A when lower triangle is stored in AP. -* - IF( ( INCX.EQ.1 ).AND.( INCY.EQ.1 ) )THEN - DO 60, J = 1, N - IF( ( X( J ).NE.ZERO ).OR.( Y( J ).NE.ZERO ) )THEN - TEMP1 = ALPHA*Y( J ) - TEMP2 = ALPHA*X( J ) - K = KK - DO 50, I = J, N - AP( K ) = AP( K ) + X( I )*TEMP1 + Y( I )*TEMP2 - K = K + 1 - 50 CONTINUE - END IF - KK = KK + N - J + 1 - 60 CONTINUE - ELSE - DO 80, J = 1, N - IF( ( X( JX ).NE.ZERO ).OR.( Y( JY ).NE.ZERO ) )THEN - TEMP1 = ALPHA*Y( JY ) - TEMP2 = ALPHA*X( JX ) - IX = JX - IY = JY - DO 70, K = KK, KK + N - J - AP( K ) = AP( K ) + X( IX )*TEMP1 + Y( IY )*TEMP2 - IX = IX + INCX - IY = IY + INCY - 70 CONTINUE - END IF - JX = JX + INCX - JY = JY + INCY - KK = KK + N - J + 1 - 80 CONTINUE - END IF - END IF -* - RETURN -* -* End of DSPR2 . -* - END diff --git a/src/lib/blas/dswap.f b/src/lib/blas/dswap.f deleted file mode 100644 index 7f7d1fbb..00000000 --- a/src/lib/blas/dswap.f +++ /dev/null @@ -1,56 +0,0 @@ - subroutine dswap (n,dx,incx,dy,incy) -c -c interchanges two vectors. -c uses unrolled loops for increments equal one. -c jack dongarra, linpack, 3/11/78. -c modified 12/3/93, array(1) declarations changed to array(*) -c - double precision dx(*),dy(*),dtemp - integer i,incx,incy,ix,iy,m,mp1,n -c - if(n.le.0)return - if(incx.eq.1.and.incy.eq.1)go to 20 -c -c code for unequal increments or equal increments not equal -c to 1 -c - ix = 1 - iy = 1 - if(incx.lt.0)ix = (-n+1)*incx + 1 - if(incy.lt.0)iy = (-n+1)*incy + 1 - do 10 i = 1,n - dtemp = dx(ix) - dx(ix) = dy(iy) - dy(iy) = dtemp - ix = ix + incx - iy = iy + incy - 10 continue - return -c -c code for both increments equal to 1 -c -c -c clean-up loop -c - 20 m = mod(n,3) - if( m .eq. 0 ) go to 40 - do 30 i = 1,m - dtemp = dx(i) - dx(i) = dy(i) - dy(i) = dtemp - 30 continue - if( n .lt. 3 ) return - 40 mp1 = m + 1 - do 50 i = mp1,n,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 - 50 continue - return - end diff --git a/src/lib/blas/dsymm.f b/src/lib/blas/dsymm.f deleted file mode 100644 index 0f251417..00000000 --- a/src/lib/blas/dsymm.f +++ /dev/null @@ -1,294 +0,0 @@ - SUBROUTINE DSYMM ( SIDE, UPLO, M, N, ALPHA, A, LDA, B, LDB, - $ BETA, C, LDC ) -* .. Scalar Arguments .. - CHARACTER*1 SIDE, UPLO - INTEGER M, N, LDA, LDB, LDC - DOUBLE PRECISION ALPHA, BETA -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), B( LDB, * ), C( LDC, * ) -* .. -* -* 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 .. - LOGICAL LSAME - EXTERNAL LSAME -* .. External Subroutines .. - EXTERNAL XERBLA -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. Local Scalars .. - LOGICAL UPPER - INTEGER I, INFO, J, K, NROWA - DOUBLE PRECISION TEMP1, TEMP2 -* .. Parameters .. - DOUBLE PRECISION ONE , ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. -* .. Executable Statements .. -* -* Set NROWA as the number of rows of A. -* - IF( LSAME( SIDE, 'L' ) )THEN - NROWA = M - ELSE - NROWA = N - END IF - UPPER = LSAME( UPLO, 'U' ) -* -* Test the input parameters. -* - INFO = 0 - IF( ( .NOT.LSAME( SIDE, 'L' ) ).AND. - $ ( .NOT.LSAME( SIDE, 'R' ) ) )THEN - INFO = 1 - ELSE IF( ( .NOT.UPPER ).AND. - $ ( .NOT.LSAME( UPLO, 'L' ) ) )THEN - INFO = 2 - ELSE IF( M .LT.0 )THEN - INFO = 3 - ELSE IF( N .LT.0 )THEN - INFO = 4 - ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN - INFO = 7 - ELSE IF( LDB.LT.MAX( 1, M ) )THEN - INFO = 9 - ELSE IF( LDC.LT.MAX( 1, M ) )THEN - INFO = 12 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'DSYMM ', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR. - $ ( ( ALPHA.EQ.ZERO ).AND.( BETA.EQ.ONE ) ) ) - $ RETURN -* -* And when alpha.eq.zero. -* - IF( ALPHA.EQ.ZERO )THEN - IF( BETA.EQ.ZERO )THEN - DO 20, J = 1, N - DO 10, I = 1, M - C( I, J ) = ZERO - 10 CONTINUE - 20 CONTINUE - ELSE - DO 40, J = 1, N - DO 30, I = 1, M - C( I, J ) = BETA*C( I, J ) - 30 CONTINUE - 40 CONTINUE - END IF - RETURN - END IF -* -* Start the operations. -* - IF( LSAME( SIDE, 'L' ) )THEN -* -* Form C := alpha*A*B + beta*C. -* - IF( UPPER )THEN - DO 70, J = 1, N - DO 60, I = 1, M - TEMP1 = ALPHA*B( I, J ) - TEMP2 = ZERO - DO 50, K = 1, I - 1 - C( K, J ) = C( K, J ) + TEMP1 *A( K, I ) - TEMP2 = TEMP2 + B( K, J )*A( K, I ) - 50 CONTINUE - IF( BETA.EQ.ZERO )THEN - C( I, J ) = TEMP1*A( I, I ) + ALPHA*TEMP2 - ELSE - C( I, J ) = BETA *C( I, J ) + - $ TEMP1*A( I, I ) + ALPHA*TEMP2 - END IF - 60 CONTINUE - 70 CONTINUE - ELSE - DO 100, J = 1, N - DO 90, I = M, 1, -1 - TEMP1 = ALPHA*B( I, J ) - TEMP2 = ZERO - DO 80, K = I + 1, M - C( K, J ) = C( K, J ) + TEMP1 *A( K, I ) - TEMP2 = TEMP2 + B( K, J )*A( K, I ) - 80 CONTINUE - IF( BETA.EQ.ZERO )THEN - C( I, J ) = TEMP1*A( I, I ) + ALPHA*TEMP2 - ELSE - C( I, J ) = BETA *C( I, J ) + - $ TEMP1*A( I, I ) + ALPHA*TEMP2 - END IF - 90 CONTINUE - 100 CONTINUE - END IF - ELSE -* -* Form C := alpha*B*A + beta*C. -* - DO 170, J = 1, N - TEMP1 = ALPHA*A( J, J ) - IF( BETA.EQ.ZERO )THEN - DO 110, I = 1, M - C( I, J ) = TEMP1*B( I, J ) - 110 CONTINUE - ELSE - DO 120, I = 1, M - C( I, J ) = BETA*C( I, J ) + TEMP1*B( I, J ) - 120 CONTINUE - END IF - DO 140, K = 1, J - 1 - IF( UPPER )THEN - TEMP1 = ALPHA*A( K, J ) - ELSE - TEMP1 = ALPHA*A( J, K ) - END IF - DO 130, I = 1, M - C( I, J ) = C( I, J ) + TEMP1*B( I, K ) - 130 CONTINUE - 140 CONTINUE - DO 160, K = J + 1, N - IF( UPPER )THEN - TEMP1 = ALPHA*A( J, K ) - ELSE - TEMP1 = ALPHA*A( K, J ) - END IF - DO 150, I = 1, M - C( I, J ) = C( I, J ) + TEMP1*B( I, K ) - 150 CONTINUE - 160 CONTINUE - 170 CONTINUE - END IF -* - RETURN -* -* End of DSYMM . -* - END diff --git a/src/lib/blas/dsymv.f b/src/lib/blas/dsymv.f deleted file mode 100644 index 7592d156..00000000 --- a/src/lib/blas/dsymv.f +++ /dev/null @@ -1,262 +0,0 @@ - SUBROUTINE DSYMV ( UPLO, N, ALPHA, A, LDA, X, INCX, - $ BETA, Y, INCY ) -* .. Scalar Arguments .. - DOUBLE PRECISION ALPHA, BETA - INTEGER INCX, INCY, LDA, N - CHARACTER*1 UPLO -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), X( * ), Y( * ) -* .. -* -* 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 .. - DOUBLE PRECISION ONE , ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. Local Scalars .. - DOUBLE PRECISION TEMP1, TEMP2 - INTEGER I, INFO, IX, IY, J, JX, JY, KX, KY -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. External Subroutines .. - EXTERNAL XERBLA -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - IF ( .NOT.LSAME( UPLO, 'U' ).AND. - $ .NOT.LSAME( UPLO, 'L' ) )THEN - INFO = 1 - ELSE IF( N.LT.0 )THEN - INFO = 2 - ELSE IF( LDA.LT.MAX( 1, N ) )THEN - INFO = 5 - ELSE IF( INCX.EQ.0 )THEN - INFO = 7 - ELSE IF( INCY.EQ.0 )THEN - INFO = 10 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'DSYMV ', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( ( N.EQ.0 ).OR.( ( ALPHA.EQ.ZERO ).AND.( BETA.EQ.ONE ) ) ) - $ RETURN -* -* Set up the start points in X and Y. -* - IF( INCX.GT.0 )THEN - KX = 1 - ELSE - KX = 1 - ( N - 1 )*INCX - END IF - IF( INCY.GT.0 )THEN - KY = 1 - ELSE - KY = 1 - ( N - 1 )*INCY - END IF -* -* 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.NE.ONE )THEN - IF( INCY.EQ.1 )THEN - IF( BETA.EQ.ZERO )THEN - DO 10, I = 1, N - Y( I ) = ZERO - 10 CONTINUE - ELSE - DO 20, I = 1, N - Y( I ) = BETA*Y( I ) - 20 CONTINUE - END IF - ELSE - IY = KY - IF( BETA.EQ.ZERO )THEN - DO 30, I = 1, N - Y( IY ) = ZERO - IY = IY + INCY - 30 CONTINUE - ELSE - DO 40, I = 1, N - Y( IY ) = BETA*Y( IY ) - IY = IY + INCY - 40 CONTINUE - END IF - END IF - END IF - IF( ALPHA.EQ.ZERO ) - $ RETURN - IF( LSAME( UPLO, 'U' ) )THEN -* -* Form y when A is stored in upper triangle. -* - IF( ( INCX.EQ.1 ).AND.( INCY.EQ.1 ) )THEN - DO 60, J = 1, N - TEMP1 = ALPHA*X( J ) - TEMP2 = ZERO - DO 50, I = 1, J - 1 - Y( I ) = Y( I ) + TEMP1*A( I, J ) - TEMP2 = TEMP2 + A( I, J )*X( I ) - 50 CONTINUE - Y( J ) = Y( J ) + TEMP1*A( J, J ) + ALPHA*TEMP2 - 60 CONTINUE - ELSE - JX = KX - JY = KY - DO 80, J = 1, N - TEMP1 = ALPHA*X( JX ) - TEMP2 = ZERO - IX = KX - IY = KY - DO 70, I = 1, J - 1 - Y( IY ) = Y( IY ) + TEMP1*A( I, J ) - TEMP2 = TEMP2 + A( I, J )*X( IX ) - IX = IX + INCX - IY = IY + INCY - 70 CONTINUE - Y( JY ) = Y( JY ) + TEMP1*A( J, J ) + ALPHA*TEMP2 - JX = JX + INCX - JY = JY + INCY - 80 CONTINUE - END IF - ELSE -* -* Form y when A is stored in lower triangle. -* - IF( ( INCX.EQ.1 ).AND.( INCY.EQ.1 ) )THEN - DO 100, J = 1, N - TEMP1 = ALPHA*X( J ) - TEMP2 = ZERO - Y( J ) = Y( J ) + TEMP1*A( J, J ) - DO 90, I = J + 1, N - Y( I ) = Y( I ) + TEMP1*A( I, J ) - TEMP2 = TEMP2 + A( I, J )*X( I ) - 90 CONTINUE - Y( J ) = Y( J ) + ALPHA*TEMP2 - 100 CONTINUE - ELSE - JX = KX - JY = KY - DO 120, J = 1, N - TEMP1 = ALPHA*X( JX ) - TEMP2 = ZERO - Y( JY ) = Y( JY ) + TEMP1*A( J, J ) - IX = JX - IY = JY - DO 110, I = J + 1, N - IX = IX + INCX - IY = IY + INCY - Y( IY ) = Y( IY ) + TEMP1*A( I, J ) - TEMP2 = TEMP2 + A( I, J )*X( IX ) - 110 CONTINUE - Y( JY ) = Y( JY ) + ALPHA*TEMP2 - JX = JX + INCX - JY = JY + INCY - 120 CONTINUE - END IF - END IF -* - RETURN -* -* End of DSYMV . -* - END diff --git a/src/lib/blas/dsyr.f b/src/lib/blas/dsyr.f deleted file mode 100644 index 87377196..00000000 --- a/src/lib/blas/dsyr.f +++ /dev/null @@ -1,197 +0,0 @@ - SUBROUTINE DSYR ( UPLO, N, ALPHA, X, INCX, A, LDA ) -* .. Scalar Arguments .. - DOUBLE PRECISION ALPHA - INTEGER INCX, LDA, N - CHARACTER*1 UPLO -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), X( * ) -* .. -* -* 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 .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D+0 ) -* .. Local Scalars .. - DOUBLE PRECISION TEMP - INTEGER I, INFO, IX, J, JX, KX -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. External Subroutines .. - EXTERNAL XERBLA -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - IF ( .NOT.LSAME( UPLO, 'U' ).AND. - $ .NOT.LSAME( UPLO, 'L' ) )THEN - INFO = 1 - ELSE IF( N.LT.0 )THEN - INFO = 2 - ELSE IF( INCX.EQ.0 )THEN - INFO = 5 - ELSE IF( LDA.LT.MAX( 1, N ) )THEN - INFO = 7 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'DSYR ', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( ( N.EQ.0 ).OR.( ALPHA.EQ.ZERO ) ) - $ RETURN -* -* Set the start point in X if the increment is not unity. -* - IF( INCX.LE.0 )THEN - KX = 1 - ( N - 1 )*INCX - ELSE IF( INCX.NE.1 )THEN - KX = 1 - END IF -* -* 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' ) )THEN -* -* Form A when A is stored in upper triangle. -* - IF( INCX.EQ.1 )THEN - DO 20, J = 1, N - IF( X( J ).NE.ZERO )THEN - TEMP = ALPHA*X( J ) - DO 10, I = 1, J - A( I, J ) = A( I, J ) + X( I )*TEMP - 10 CONTINUE - END IF - 20 CONTINUE - ELSE - JX = KX - DO 40, J = 1, N - IF( X( JX ).NE.ZERO )THEN - TEMP = ALPHA*X( JX ) - IX = KX - DO 30, I = 1, J - A( I, J ) = A( I, J ) + X( IX )*TEMP - IX = IX + INCX - 30 CONTINUE - END IF - JX = JX + INCX - 40 CONTINUE - END IF - ELSE -* -* Form A when A is stored in lower triangle. -* - IF( INCX.EQ.1 )THEN - DO 60, J = 1, N - IF( X( J ).NE.ZERO )THEN - TEMP = ALPHA*X( J ) - DO 50, I = J, N - A( I, J ) = A( I, J ) + X( I )*TEMP - 50 CONTINUE - END IF - 60 CONTINUE - ELSE - JX = KX - DO 80, J = 1, N - IF( X( JX ).NE.ZERO )THEN - TEMP = ALPHA*X( JX ) - IX = JX - DO 70, I = J, N - A( I, J ) = A( I, J ) + X( IX )*TEMP - IX = IX + INCX - 70 CONTINUE - END IF - JX = JX + INCX - 80 CONTINUE - END IF - END IF -* - RETURN -* -* End of DSYR . -* - END diff --git a/src/lib/blas/dsyr2.f b/src/lib/blas/dsyr2.f deleted file mode 100644 index 918ad8a7..00000000 --- a/src/lib/blas/dsyr2.f +++ /dev/null @@ -1,230 +0,0 @@ - SUBROUTINE DSYR2 ( UPLO, N, ALPHA, X, INCX, Y, INCY, A, LDA ) -* .. Scalar Arguments .. - DOUBLE PRECISION ALPHA - INTEGER INCX, INCY, LDA, N - CHARACTER*1 UPLO -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), X( * ), Y( * ) -* .. -* -* 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 .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D+0 ) -* .. Local Scalars .. - DOUBLE PRECISION TEMP1, TEMP2 - INTEGER I, INFO, IX, IY, J, JX, JY, KX, KY -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. External Subroutines .. - EXTERNAL XERBLA -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - IF ( .NOT.LSAME( UPLO, 'U' ).AND. - $ .NOT.LSAME( UPLO, 'L' ) )THEN - INFO = 1 - ELSE IF( N.LT.0 )THEN - INFO = 2 - ELSE IF( INCX.EQ.0 )THEN - INFO = 5 - ELSE IF( INCY.EQ.0 )THEN - INFO = 7 - ELSE IF( LDA.LT.MAX( 1, N ) )THEN - INFO = 9 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'DSYR2 ', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( ( N.EQ.0 ).OR.( ALPHA.EQ.ZERO ) ) - $ RETURN -* -* Set up the start points in X and Y if the increments are not both -* unity. -* - IF( ( INCX.NE.1 ).OR.( INCY.NE.1 ) )THEN - IF( INCX.GT.0 )THEN - KX = 1 - ELSE - KX = 1 - ( N - 1 )*INCX - END IF - IF( INCY.GT.0 )THEN - KY = 1 - ELSE - KY = 1 - ( N - 1 )*INCY - END IF - JX = KX - JY = KY - END IF -* -* 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' ) )THEN -* -* Form A when A is stored in the upper triangle. -* - IF( ( INCX.EQ.1 ).AND.( INCY.EQ.1 ) )THEN - DO 20, J = 1, N - IF( ( X( J ).NE.ZERO ).OR.( Y( J ).NE.ZERO ) )THEN - TEMP1 = ALPHA*Y( J ) - TEMP2 = ALPHA*X( J ) - DO 10, I = 1, J - A( I, J ) = A( I, J ) + X( I )*TEMP1 + Y( I )*TEMP2 - 10 CONTINUE - END IF - 20 CONTINUE - ELSE - DO 40, J = 1, N - IF( ( X( JX ).NE.ZERO ).OR.( Y( JY ).NE.ZERO ) )THEN - TEMP1 = ALPHA*Y( JY ) - TEMP2 = ALPHA*X( JX ) - IX = KX - IY = KY - DO 30, I = 1, J - A( I, J ) = A( I, J ) + X( IX )*TEMP1 - $ + Y( IY )*TEMP2 - IX = IX + INCX - IY = IY + INCY - 30 CONTINUE - END IF - JX = JX + INCX - JY = JY + INCY - 40 CONTINUE - END IF - ELSE -* -* Form A when A is stored in the lower triangle. -* - IF( ( INCX.EQ.1 ).AND.( INCY.EQ.1 ) )THEN - DO 60, J = 1, N - IF( ( X( J ).NE.ZERO ).OR.( Y( J ).NE.ZERO ) )THEN - TEMP1 = ALPHA*Y( J ) - TEMP2 = ALPHA*X( J ) - DO 50, I = J, N - A( I, J ) = A( I, J ) + X( I )*TEMP1 + Y( I )*TEMP2 - 50 CONTINUE - END IF - 60 CONTINUE - ELSE - DO 80, J = 1, N - IF( ( X( JX ).NE.ZERO ).OR.( Y( JY ).NE.ZERO ) )THEN - TEMP1 = ALPHA*Y( JY ) - TEMP2 = ALPHA*X( JX ) - IX = JX - IY = JY - DO 70, I = J, N - A( I, J ) = A( I, J ) + X( IX )*TEMP1 - $ + Y( IY )*TEMP2 - IX = IX + INCX - IY = IY + INCY - 70 CONTINUE - END IF - JX = JX + INCX - JY = JY + INCY - 80 CONTINUE - END IF - END IF -* - RETURN -* -* End of DSYR2 . -* - END diff --git a/src/lib/blas/dsyr2k.f b/src/lib/blas/dsyr2k.f deleted file mode 100644 index ac7d97de..00000000 --- a/src/lib/blas/dsyr2k.f +++ /dev/null @@ -1,327 +0,0 @@ - SUBROUTINE DSYR2K( UPLO, TRANS, N, K, ALPHA, A, LDA, B, LDB, - $ BETA, C, LDC ) -* .. Scalar Arguments .. - CHARACTER*1 UPLO, TRANS - INTEGER N, K, LDA, LDB, LDC - DOUBLE PRECISION ALPHA, BETA -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), B( LDB, * ), C( LDC, * ) -* .. -* -* 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 .. - LOGICAL LSAME - EXTERNAL LSAME -* .. External Subroutines .. - EXTERNAL XERBLA -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. Local Scalars .. - LOGICAL UPPER - INTEGER I, INFO, J, L, NROWA - DOUBLE PRECISION TEMP1, TEMP2 -* .. Parameters .. - DOUBLE PRECISION ONE , ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - IF( LSAME( TRANS, 'N' ) )THEN - NROWA = N - ELSE - NROWA = K - END IF - UPPER = LSAME( UPLO, 'U' ) -* - INFO = 0 - IF( ( .NOT.UPPER ).AND. - $ ( .NOT.LSAME( UPLO , 'L' ) ) )THEN - INFO = 1 - ELSE IF( ( .NOT.LSAME( TRANS, 'N' ) ).AND. - $ ( .NOT.LSAME( TRANS, 'T' ) ).AND. - $ ( .NOT.LSAME( TRANS, 'C' ) ) )THEN - INFO = 2 - ELSE IF( N .LT.0 )THEN - INFO = 3 - ELSE IF( K .LT.0 )THEN - INFO = 4 - ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN - INFO = 7 - ELSE IF( LDB.LT.MAX( 1, NROWA ) )THEN - INFO = 9 - ELSE IF( LDC.LT.MAX( 1, N ) )THEN - INFO = 12 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'DSYR2K', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( ( N.EQ.0 ).OR. - $ ( ( ( ALPHA.EQ.ZERO ).OR.( K.EQ.0 ) ).AND.( BETA.EQ.ONE ) ) ) - $ RETURN -* -* And when alpha.eq.zero. -* - IF( ALPHA.EQ.ZERO )THEN - IF( UPPER )THEN - IF( BETA.EQ.ZERO )THEN - DO 20, J = 1, N - DO 10, I = 1, J - C( I, J ) = ZERO - 10 CONTINUE - 20 CONTINUE - ELSE - DO 40, J = 1, N - DO 30, I = 1, J - C( I, J ) = BETA*C( I, J ) - 30 CONTINUE - 40 CONTINUE - END IF - ELSE - IF( BETA.EQ.ZERO )THEN - DO 60, J = 1, N - DO 50, I = J, N - C( I, J ) = ZERO - 50 CONTINUE - 60 CONTINUE - ELSE - DO 80, J = 1, N - DO 70, I = J, N - C( I, J ) = BETA*C( I, J ) - 70 CONTINUE - 80 CONTINUE - END IF - END IF - RETURN - END IF -* -* Start the operations. -* - IF( LSAME( TRANS, 'N' ) )THEN -* -* Form C := alpha*A*B' + alpha*B*A' + C. -* - IF( UPPER )THEN - DO 130, J = 1, N - IF( BETA.EQ.ZERO )THEN - DO 90, I = 1, J - C( I, J ) = ZERO - 90 CONTINUE - ELSE IF( BETA.NE.ONE )THEN - DO 100, I = 1, J - C( I, J ) = BETA*C( I, J ) - 100 CONTINUE - END IF - DO 120, L = 1, K - IF( ( A( J, L ).NE.ZERO ).OR. - $ ( B( J, L ).NE.ZERO ) )THEN - TEMP1 = ALPHA*B( J, L ) - TEMP2 = ALPHA*A( J, L ) - DO 110, I = 1, J - C( I, J ) = C( I, J ) + - $ A( I, L )*TEMP1 + B( I, L )*TEMP2 - 110 CONTINUE - END IF - 120 CONTINUE - 130 CONTINUE - ELSE - DO 180, J = 1, N - IF( BETA.EQ.ZERO )THEN - DO 140, I = J, N - C( I, J ) = ZERO - 140 CONTINUE - ELSE IF( BETA.NE.ONE )THEN - DO 150, I = J, N - C( I, J ) = BETA*C( I, J ) - 150 CONTINUE - END IF - DO 170, L = 1, K - IF( ( A( J, L ).NE.ZERO ).OR. - $ ( B( J, L ).NE.ZERO ) )THEN - TEMP1 = ALPHA*B( J, L ) - TEMP2 = ALPHA*A( J, L ) - DO 160, I = J, N - C( I, J ) = C( I, J ) + - $ A( I, L )*TEMP1 + B( I, L )*TEMP2 - 160 CONTINUE - END IF - 170 CONTINUE - 180 CONTINUE - END IF - ELSE -* -* Form C := alpha*A'*B + alpha*B'*A + C. -* - IF( UPPER )THEN - DO 210, J = 1, N - DO 200, I = 1, J - TEMP1 = ZERO - TEMP2 = ZERO - DO 190, L = 1, K - TEMP1 = TEMP1 + A( L, I )*B( L, J ) - TEMP2 = TEMP2 + B( L, I )*A( L, J ) - 190 CONTINUE - IF( BETA.EQ.ZERO )THEN - C( I, J ) = ALPHA*TEMP1 + ALPHA*TEMP2 - ELSE - C( I, J ) = BETA *C( I, J ) + - $ ALPHA*TEMP1 + ALPHA*TEMP2 - END IF - 200 CONTINUE - 210 CONTINUE - ELSE - DO 240, J = 1, N - DO 230, I = J, N - TEMP1 = ZERO - TEMP2 = ZERO - DO 220, L = 1, K - TEMP1 = TEMP1 + A( L, I )*B( L, J ) - TEMP2 = TEMP2 + B( L, I )*A( L, J ) - 220 CONTINUE - IF( BETA.EQ.ZERO )THEN - C( I, J ) = ALPHA*TEMP1 + ALPHA*TEMP2 - ELSE - C( I, J ) = BETA *C( I, J ) + - $ ALPHA*TEMP1 + ALPHA*TEMP2 - END IF - 230 CONTINUE - 240 CONTINUE - END IF - END IF -* - RETURN -* -* End of DSYR2K. -* - END diff --git a/src/lib/blas/dsyrk.f b/src/lib/blas/dsyrk.f deleted file mode 100644 index b618b296..00000000 --- a/src/lib/blas/dsyrk.f +++ /dev/null @@ -1,294 +0,0 @@ - SUBROUTINE DSYRK ( UPLO, TRANS, N, K, ALPHA, A, LDA, - $ BETA, C, LDC ) -* .. Scalar Arguments .. - CHARACTER*1 UPLO, TRANS - INTEGER N, K, LDA, LDC - DOUBLE PRECISION ALPHA, BETA -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), C( LDC, * ) -* .. -* -* 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 .. - LOGICAL LSAME - EXTERNAL LSAME -* .. External Subroutines .. - EXTERNAL XERBLA -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. Local Scalars .. - LOGICAL UPPER - INTEGER I, INFO, J, L, NROWA - DOUBLE PRECISION TEMP -* .. Parameters .. - DOUBLE PRECISION ONE , ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - IF( LSAME( TRANS, 'N' ) )THEN - NROWA = N - ELSE - NROWA = K - END IF - UPPER = LSAME( UPLO, 'U' ) -* - INFO = 0 - IF( ( .NOT.UPPER ).AND. - $ ( .NOT.LSAME( UPLO , 'L' ) ) )THEN - INFO = 1 - ELSE IF( ( .NOT.LSAME( TRANS, 'N' ) ).AND. - $ ( .NOT.LSAME( TRANS, 'T' ) ).AND. - $ ( .NOT.LSAME( TRANS, 'C' ) ) )THEN - INFO = 2 - ELSE IF( N .LT.0 )THEN - INFO = 3 - ELSE IF( K .LT.0 )THEN - INFO = 4 - ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN - INFO = 7 - ELSE IF( LDC.LT.MAX( 1, N ) )THEN - INFO = 10 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'DSYRK ', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( ( N.EQ.0 ).OR. - $ ( ( ( ALPHA.EQ.ZERO ).OR.( K.EQ.0 ) ).AND.( BETA.EQ.ONE ) ) ) - $ RETURN -* -* And when alpha.eq.zero. -* - IF( ALPHA.EQ.ZERO )THEN - IF( UPPER )THEN - IF( BETA.EQ.ZERO )THEN - DO 20, J = 1, N - DO 10, I = 1, J - C( I, J ) = ZERO - 10 CONTINUE - 20 CONTINUE - ELSE - DO 40, J = 1, N - DO 30, I = 1, J - C( I, J ) = BETA*C( I, J ) - 30 CONTINUE - 40 CONTINUE - END IF - ELSE - IF( BETA.EQ.ZERO )THEN - DO 60, J = 1, N - DO 50, I = J, N - C( I, J ) = ZERO - 50 CONTINUE - 60 CONTINUE - ELSE - DO 80, J = 1, N - DO 70, I = J, N - C( I, J ) = BETA*C( I, J ) - 70 CONTINUE - 80 CONTINUE - END IF - END IF - RETURN - END IF -* -* Start the operations. -* - IF( LSAME( TRANS, 'N' ) )THEN -* -* Form C := alpha*A*A' + beta*C. -* - IF( UPPER )THEN - DO 130, J = 1, N - IF( BETA.EQ.ZERO )THEN - DO 90, I = 1, J - C( I, J ) = ZERO - 90 CONTINUE - ELSE IF( BETA.NE.ONE )THEN - DO 100, I = 1, J - C( I, J ) = BETA*C( I, J ) - 100 CONTINUE - END IF - DO 120, L = 1, K - IF( A( J, L ).NE.ZERO )THEN - TEMP = ALPHA*A( J, L ) - DO 110, I = 1, J - C( I, J ) = C( I, J ) + TEMP*A( I, L ) - 110 CONTINUE - END IF - 120 CONTINUE - 130 CONTINUE - ELSE - DO 180, J = 1, N - IF( BETA.EQ.ZERO )THEN - DO 140, I = J, N - C( I, J ) = ZERO - 140 CONTINUE - ELSE IF( BETA.NE.ONE )THEN - DO 150, I = J, N - C( I, J ) = BETA*C( I, J ) - 150 CONTINUE - END IF - DO 170, L = 1, K - IF( A( J, L ).NE.ZERO )THEN - TEMP = ALPHA*A( J, L ) - DO 160, I = J, N - C( I, J ) = C( I, J ) + TEMP*A( I, L ) - 160 CONTINUE - END IF - 170 CONTINUE - 180 CONTINUE - END IF - ELSE -* -* Form C := alpha*A'*A + beta*C. -* - IF( UPPER )THEN - DO 210, J = 1, N - DO 200, I = 1, J - TEMP = ZERO - DO 190, L = 1, K - TEMP = TEMP + A( L, I )*A( L, J ) - 190 CONTINUE - IF( BETA.EQ.ZERO )THEN - C( I, J ) = ALPHA*TEMP - ELSE - C( I, J ) = ALPHA*TEMP + BETA*C( I, J ) - END IF - 200 CONTINUE - 210 CONTINUE - ELSE - DO 240, J = 1, N - DO 230, I = J, N - TEMP = ZERO - DO 220, L = 1, K - TEMP = TEMP + A( L, I )*A( L, J ) - 220 CONTINUE - IF( BETA.EQ.ZERO )THEN - C( I, J ) = ALPHA*TEMP - ELSE - C( I, J ) = ALPHA*TEMP + BETA*C( I, J ) - END IF - 230 CONTINUE - 240 CONTINUE - END IF - END IF -* - RETURN -* -* End of DSYRK . -* - END diff --git a/src/lib/blas/dtbmv.f b/src/lib/blas/dtbmv.f deleted file mode 100644 index 1363db79..00000000 --- a/src/lib/blas/dtbmv.f +++ /dev/null @@ -1,342 +0,0 @@ - SUBROUTINE DTBMV ( UPLO, TRANS, DIAG, N, K, A, LDA, X, INCX ) -* .. Scalar Arguments .. - INTEGER INCX, K, LDA, N - CHARACTER*1 DIAG, TRANS, UPLO -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), X( * ) -* .. -* -* 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 .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D+0 ) -* .. Local Scalars .. - DOUBLE PRECISION TEMP - INTEGER I, INFO, IX, J, JX, KPLUS1, KX, L - LOGICAL NOUNIT -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. External Subroutines .. - EXTERNAL XERBLA -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - IF ( .NOT.LSAME( UPLO , 'U' ).AND. - $ .NOT.LSAME( UPLO , 'L' ) )THEN - INFO = 1 - ELSE IF( .NOT.LSAME( TRANS, 'N' ).AND. - $ .NOT.LSAME( TRANS, 'T' ).AND. - $ .NOT.LSAME( TRANS, 'C' ) )THEN - INFO = 2 - ELSE IF( .NOT.LSAME( DIAG , 'U' ).AND. - $ .NOT.LSAME( DIAG , 'N' ) )THEN - INFO = 3 - ELSE IF( N.LT.0 )THEN - INFO = 4 - ELSE IF( K.LT.0 )THEN - INFO = 5 - ELSE IF( LDA.LT.( K + 1 ) )THEN - INFO = 7 - ELSE IF( INCX.EQ.0 )THEN - INFO = 9 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'DTBMV ', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( N.EQ.0 ) - $ RETURN -* - NOUNIT = LSAME( DIAG, 'N' ) -* -* Set up the start point in X if the increment is not unity. This -* will be ( N - 1 )*INCX too small for descending loops. -* - IF( INCX.LE.0 )THEN - KX = 1 - ( N - 1 )*INCX - ELSE IF( INCX.NE.1 )THEN - KX = 1 - END IF -* -* Start the operations. In this version the elements of A are -* accessed sequentially with one pass through A. -* - IF( LSAME( TRANS, 'N' ) )THEN -* -* Form x := A*x. -* - IF( LSAME( UPLO, 'U' ) )THEN - KPLUS1 = K + 1 - IF( INCX.EQ.1 )THEN - DO 20, J = 1, N - IF( X( J ).NE.ZERO )THEN - TEMP = X( J ) - L = KPLUS1 - J - DO 10, I = MAX( 1, J - K ), J - 1 - X( I ) = X( I ) + TEMP*A( L + I, J ) - 10 CONTINUE - IF( NOUNIT ) - $ X( J ) = X( J )*A( KPLUS1, J ) - END IF - 20 CONTINUE - ELSE - JX = KX - DO 40, J = 1, N - IF( X( JX ).NE.ZERO )THEN - TEMP = X( JX ) - IX = KX - L = KPLUS1 - J - DO 30, I = MAX( 1, J - K ), J - 1 - X( IX ) = X( IX ) + TEMP*A( L + I, J ) - IX = IX + INCX - 30 CONTINUE - IF( NOUNIT ) - $ X( JX ) = X( JX )*A( KPLUS1, J ) - END IF - JX = JX + INCX - IF( J.GT.K ) - $ KX = KX + INCX - 40 CONTINUE - END IF - ELSE - IF( INCX.EQ.1 )THEN - DO 60, J = N, 1, -1 - IF( X( J ).NE.ZERO )THEN - TEMP = X( J ) - L = 1 - J - DO 50, I = MIN( N, J + K ), J + 1, -1 - X( I ) = X( I ) + TEMP*A( L + I, J ) - 50 CONTINUE - IF( NOUNIT ) - $ X( J ) = X( J )*A( 1, J ) - END IF - 60 CONTINUE - ELSE - KX = KX + ( N - 1 )*INCX - JX = KX - DO 80, J = N, 1, -1 - IF( X( JX ).NE.ZERO )THEN - TEMP = X( JX ) - IX = KX - L = 1 - J - DO 70, I = MIN( N, J + K ), J + 1, -1 - X( IX ) = X( IX ) + TEMP*A( L + I, J ) - IX = IX - INCX - 70 CONTINUE - IF( NOUNIT ) - $ X( JX ) = X( JX )*A( 1, J ) - END IF - JX = JX - INCX - IF( ( N - J ).GE.K ) - $ KX = KX - INCX - 80 CONTINUE - END IF - END IF - ELSE -* -* Form x := A'*x. -* - IF( LSAME( UPLO, 'U' ) )THEN - KPLUS1 = K + 1 - IF( INCX.EQ.1 )THEN - DO 100, J = N, 1, -1 - TEMP = X( J ) - L = KPLUS1 - J - IF( NOUNIT ) - $ TEMP = TEMP*A( KPLUS1, J ) - DO 90, I = J - 1, MAX( 1, J - K ), -1 - TEMP = TEMP + A( L + I, J )*X( I ) - 90 CONTINUE - X( J ) = TEMP - 100 CONTINUE - ELSE - KX = KX + ( N - 1 )*INCX - JX = KX - DO 120, J = N, 1, -1 - TEMP = X( JX ) - KX = KX - INCX - IX = KX - L = KPLUS1 - J - IF( NOUNIT ) - $ TEMP = TEMP*A( KPLUS1, J ) - DO 110, I = J - 1, MAX( 1, J - K ), -1 - TEMP = TEMP + A( L + I, J )*X( IX ) - IX = IX - INCX - 110 CONTINUE - X( JX ) = TEMP - JX = JX - INCX - 120 CONTINUE - END IF - ELSE - IF( INCX.EQ.1 )THEN - DO 140, J = 1, N - TEMP = X( J ) - L = 1 - J - IF( NOUNIT ) - $ TEMP = TEMP*A( 1, J ) - DO 130, I = J + 1, MIN( N, J + K ) - TEMP = TEMP + A( L + I, J )*X( I ) - 130 CONTINUE - X( J ) = TEMP - 140 CONTINUE - ELSE - JX = KX - DO 160, J = 1, N - TEMP = X( JX ) - KX = KX + INCX - IX = KX - L = 1 - J - IF( NOUNIT ) - $ TEMP = TEMP*A( 1, J ) - DO 150, I = J + 1, MIN( N, J + K ) - TEMP = TEMP + A( L + I, J )*X( IX ) - IX = IX + INCX - 150 CONTINUE - X( JX ) = TEMP - JX = JX + INCX - 160 CONTINUE - END IF - END IF - END IF -* - RETURN -* -* End of DTBMV . -* - END diff --git a/src/lib/blas/dtbsv.f b/src/lib/blas/dtbsv.f deleted file mode 100644 index d87ed82d..00000000 --- a/src/lib/blas/dtbsv.f +++ /dev/null @@ -1,346 +0,0 @@ - SUBROUTINE DTBSV ( UPLO, TRANS, DIAG, N, K, A, LDA, X, INCX ) -* .. Scalar Arguments .. - INTEGER INCX, K, LDA, N - CHARACTER*1 DIAG, TRANS, UPLO -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), X( * ) -* .. -* -* 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 .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D+0 ) -* .. Local Scalars .. - DOUBLE PRECISION TEMP - INTEGER I, INFO, IX, J, JX, KPLUS1, KX, L - LOGICAL NOUNIT -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. External Subroutines .. - EXTERNAL XERBLA -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - IF ( .NOT.LSAME( UPLO , 'U' ).AND. - $ .NOT.LSAME( UPLO , 'L' ) )THEN - INFO = 1 - ELSE IF( .NOT.LSAME( TRANS, 'N' ).AND. - $ .NOT.LSAME( TRANS, 'T' ).AND. - $ .NOT.LSAME( TRANS, 'C' ) )THEN - INFO = 2 - ELSE IF( .NOT.LSAME( DIAG , 'U' ).AND. - $ .NOT.LSAME( DIAG , 'N' ) )THEN - INFO = 3 - ELSE IF( N.LT.0 )THEN - INFO = 4 - ELSE IF( K.LT.0 )THEN - INFO = 5 - ELSE IF( LDA.LT.( K + 1 ) )THEN - INFO = 7 - ELSE IF( INCX.EQ.0 )THEN - INFO = 9 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'DTBSV ', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( N.EQ.0 ) - $ RETURN -* - NOUNIT = LSAME( DIAG, 'N' ) -* -* Set up the start point in X if the increment is not unity. This -* will be ( N - 1 )*INCX too small for descending loops. -* - IF( INCX.LE.0 )THEN - KX = 1 - ( N - 1 )*INCX - ELSE IF( INCX.NE.1 )THEN - KX = 1 - END IF -* -* Start the operations. In this version the elements of A are -* accessed by sequentially with one pass through A. -* - IF( LSAME( TRANS, 'N' ) )THEN -* -* Form x := inv( A )*x. -* - IF( LSAME( UPLO, 'U' ) )THEN - KPLUS1 = K + 1 - IF( INCX.EQ.1 )THEN - DO 20, J = N, 1, -1 - IF( X( J ).NE.ZERO )THEN - L = KPLUS1 - J - IF( NOUNIT ) - $ X( J ) = X( J )/A( KPLUS1, J ) - TEMP = X( J ) - DO 10, I = J - 1, MAX( 1, J - K ), -1 - X( I ) = X( I ) - TEMP*A( L + I, J ) - 10 CONTINUE - END IF - 20 CONTINUE - ELSE - KX = KX + ( N - 1 )*INCX - JX = KX - DO 40, J = N, 1, -1 - KX = KX - INCX - IF( X( JX ).NE.ZERO )THEN - IX = KX - L = KPLUS1 - J - IF( NOUNIT ) - $ X( JX ) = X( JX )/A( KPLUS1, J ) - TEMP = X( JX ) - DO 30, I = J - 1, MAX( 1, J - K ), -1 - X( IX ) = X( IX ) - TEMP*A( L + I, J ) - IX = IX - INCX - 30 CONTINUE - END IF - JX = JX - INCX - 40 CONTINUE - END IF - ELSE - IF( INCX.EQ.1 )THEN - DO 60, J = 1, N - IF( X( J ).NE.ZERO )THEN - L = 1 - J - IF( NOUNIT ) - $ X( J ) = X( J )/A( 1, J ) - TEMP = X( J ) - DO 50, I = J + 1, MIN( N, J + K ) - X( I ) = X( I ) - TEMP*A( L + I, J ) - 50 CONTINUE - END IF - 60 CONTINUE - ELSE - JX = KX - DO 80, J = 1, N - KX = KX + INCX - IF( X( JX ).NE.ZERO )THEN - IX = KX - L = 1 - J - IF( NOUNIT ) - $ X( JX ) = X( JX )/A( 1, J ) - TEMP = X( JX ) - DO 70, I = J + 1, MIN( N, J + K ) - X( IX ) = X( IX ) - TEMP*A( L + I, J ) - IX = IX + INCX - 70 CONTINUE - END IF - JX = JX + INCX - 80 CONTINUE - END IF - END IF - ELSE -* -* Form x := inv( A')*x. -* - IF( LSAME( UPLO, 'U' ) )THEN - KPLUS1 = K + 1 - IF( INCX.EQ.1 )THEN - DO 100, J = 1, N - TEMP = X( J ) - L = KPLUS1 - J - DO 90, I = MAX( 1, J - K ), J - 1 - TEMP = TEMP - A( L + I, J )*X( I ) - 90 CONTINUE - IF( NOUNIT ) - $ TEMP = TEMP/A( KPLUS1, J ) - X( J ) = TEMP - 100 CONTINUE - ELSE - JX = KX - DO 120, J = 1, N - TEMP = X( JX ) - IX = KX - L = KPLUS1 - J - DO 110, I = MAX( 1, J - K ), J - 1 - TEMP = TEMP - A( L + I, J )*X( IX ) - IX = IX + INCX - 110 CONTINUE - IF( NOUNIT ) - $ TEMP = TEMP/A( KPLUS1, J ) - X( JX ) = TEMP - JX = JX + INCX - IF( J.GT.K ) - $ KX = KX + INCX - 120 CONTINUE - END IF - ELSE - IF( INCX.EQ.1 )THEN - DO 140, J = N, 1, -1 - TEMP = X( J ) - L = 1 - J - DO 130, I = MIN( N, J + K ), J + 1, -1 - TEMP = TEMP - A( L + I, J )*X( I ) - 130 CONTINUE - IF( NOUNIT ) - $ TEMP = TEMP/A( 1, J ) - X( J ) = TEMP - 140 CONTINUE - ELSE - KX = KX + ( N - 1 )*INCX - JX = KX - DO 160, J = N, 1, -1 - TEMP = X( JX ) - IX = KX - L = 1 - J - DO 150, I = MIN( N, J + K ), J + 1, -1 - TEMP = TEMP - A( L + I, J )*X( IX ) - IX = IX - INCX - 150 CONTINUE - IF( NOUNIT ) - $ TEMP = TEMP/A( 1, J ) - X( JX ) = TEMP - JX = JX - INCX - IF( ( N - J ).GE.K ) - $ KX = KX - INCX - 160 CONTINUE - END IF - END IF - END IF -* - RETURN -* -* End of DTBSV . -* - END diff --git a/src/lib/blas/dtpmv.f b/src/lib/blas/dtpmv.f deleted file mode 100644 index ee11bc1b..00000000 --- a/src/lib/blas/dtpmv.f +++ /dev/null @@ -1,299 +0,0 @@ - SUBROUTINE DTPMV ( UPLO, TRANS, DIAG, N, AP, X, INCX ) -* .. Scalar Arguments .. - INTEGER INCX, N - CHARACTER*1 DIAG, TRANS, UPLO -* .. Array Arguments .. - DOUBLE PRECISION AP( * ), X( * ) -* .. -* -* 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 .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D+0 ) -* .. Local Scalars .. - DOUBLE PRECISION TEMP - INTEGER I, INFO, IX, J, JX, K, KK, KX - LOGICAL NOUNIT -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. External Subroutines .. - EXTERNAL XERBLA -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - IF ( .NOT.LSAME( UPLO , 'U' ).AND. - $ .NOT.LSAME( UPLO , 'L' ) )THEN - INFO = 1 - ELSE IF( .NOT.LSAME( TRANS, 'N' ).AND. - $ .NOT.LSAME( TRANS, 'T' ).AND. - $ .NOT.LSAME( TRANS, 'C' ) )THEN - INFO = 2 - ELSE IF( .NOT.LSAME( DIAG , 'U' ).AND. - $ .NOT.LSAME( DIAG , 'N' ) )THEN - INFO = 3 - ELSE IF( N.LT.0 )THEN - INFO = 4 - ELSE IF( INCX.EQ.0 )THEN - INFO = 7 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'DTPMV ', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( N.EQ.0 ) - $ RETURN -* - NOUNIT = LSAME( DIAG, 'N' ) -* -* Set up the start point in X if the increment is not unity. This -* will be ( N - 1 )*INCX too small for descending loops. -* - IF( INCX.LE.0 )THEN - KX = 1 - ( N - 1 )*INCX - ELSE IF( INCX.NE.1 )THEN - KX = 1 - END IF -* -* Start the operations. In this version the elements of AP are -* accessed sequentially with one pass through AP. -* - IF( LSAME( TRANS, 'N' ) )THEN -* -* Form x:= A*x. -* - IF( LSAME( UPLO, 'U' ) )THEN - KK =1 - IF( INCX.EQ.1 )THEN - DO 20, J = 1, N - IF( X( J ).NE.ZERO )THEN - TEMP = X( J ) - K = KK - DO 10, I = 1, J - 1 - X( I ) = X( I ) + TEMP*AP( K ) - K = K + 1 - 10 CONTINUE - IF( NOUNIT ) - $ X( J ) = X( J )*AP( KK + J - 1 ) - END IF - KK = KK + J - 20 CONTINUE - ELSE - JX = KX - DO 40, J = 1, N - IF( X( JX ).NE.ZERO )THEN - TEMP = X( JX ) - IX = KX - DO 30, K = KK, KK + J - 2 - X( IX ) = X( IX ) + TEMP*AP( K ) - IX = IX + INCX - 30 CONTINUE - IF( NOUNIT ) - $ X( JX ) = X( JX )*AP( KK + J - 1 ) - END IF - JX = JX + INCX - KK = KK + J - 40 CONTINUE - END IF - ELSE - KK = ( N*( N + 1 ) )/2 - IF( INCX.EQ.1 )THEN - DO 60, J = N, 1, -1 - IF( X( J ).NE.ZERO )THEN - TEMP = X( J ) - K = KK - DO 50, I = N, J + 1, -1 - X( I ) = X( I ) + TEMP*AP( K ) - K = K - 1 - 50 CONTINUE - IF( NOUNIT ) - $ X( J ) = X( J )*AP( KK - N + J ) - END IF - KK = KK - ( N - J + 1 ) - 60 CONTINUE - ELSE - KX = KX + ( N - 1 )*INCX - JX = KX - DO 80, J = N, 1, -1 - IF( X( JX ).NE.ZERO )THEN - TEMP = X( JX ) - IX = KX - DO 70, K = KK, KK - ( N - ( J + 1 ) ), -1 - X( IX ) = X( IX ) + TEMP*AP( K ) - IX = IX - INCX - 70 CONTINUE - IF( NOUNIT ) - $ X( JX ) = X( JX )*AP( KK - N + J ) - END IF - JX = JX - INCX - KK = KK - ( N - J + 1 ) - 80 CONTINUE - END IF - END IF - ELSE -* -* Form x := A'*x. -* - IF( LSAME( UPLO, 'U' ) )THEN - KK = ( N*( N + 1 ) )/2 - IF( INCX.EQ.1 )THEN - DO 100, J = N, 1, -1 - TEMP = X( J ) - IF( NOUNIT ) - $ TEMP = TEMP*AP( KK ) - K = KK - 1 - DO 90, I = J - 1, 1, -1 - TEMP = TEMP + AP( K )*X( I ) - K = K - 1 - 90 CONTINUE - X( J ) = TEMP - KK = KK - J - 100 CONTINUE - ELSE - JX = KX + ( N - 1 )*INCX - DO 120, J = N, 1, -1 - TEMP = X( JX ) - IX = JX - IF( NOUNIT ) - $ TEMP = TEMP*AP( KK ) - DO 110, K = KK - 1, KK - J + 1, -1 - IX = IX - INCX - TEMP = TEMP + AP( K )*X( IX ) - 110 CONTINUE - X( JX ) = TEMP - JX = JX - INCX - KK = KK - J - 120 CONTINUE - END IF - ELSE - KK = 1 - IF( INCX.EQ.1 )THEN - DO 140, J = 1, N - TEMP = X( J ) - IF( NOUNIT ) - $ TEMP = TEMP*AP( KK ) - K = KK + 1 - DO 130, I = J + 1, N - TEMP = TEMP + AP( K )*X( I ) - K = K + 1 - 130 CONTINUE - X( J ) = TEMP - KK = KK + ( N - J + 1 ) - 140 CONTINUE - ELSE - JX = KX - DO 160, J = 1, N - TEMP = X( JX ) - IX = JX - IF( NOUNIT ) - $ TEMP = TEMP*AP( KK ) - DO 150, K = KK + 1, KK + N - J - IX = IX + INCX - TEMP = TEMP + AP( K )*X( IX ) - 150 CONTINUE - X( JX ) = TEMP - JX = JX + INCX - KK = KK + ( N - J + 1 ) - 160 CONTINUE - END IF - END IF - END IF -* - RETURN -* -* End of DTPMV . -* - END diff --git a/src/lib/blas/dtpsv.f b/src/lib/blas/dtpsv.f deleted file mode 100644 index 91930d9f..00000000 --- a/src/lib/blas/dtpsv.f +++ /dev/null @@ -1,302 +0,0 @@ - SUBROUTINE DTPSV ( UPLO, TRANS, DIAG, N, AP, X, INCX ) -* .. Scalar Arguments .. - INTEGER INCX, N - CHARACTER*1 DIAG, TRANS, UPLO -* .. Array Arguments .. - DOUBLE PRECISION AP( * ), X( * ) -* .. -* -* 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 .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D+0 ) -* .. Local Scalars .. - DOUBLE PRECISION TEMP - INTEGER I, INFO, IX, J, JX, K, KK, KX - LOGICAL NOUNIT -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. External Subroutines .. - EXTERNAL XERBLA -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - IF ( .NOT.LSAME( UPLO , 'U' ).AND. - $ .NOT.LSAME( UPLO , 'L' ) )THEN - INFO = 1 - ELSE IF( .NOT.LSAME( TRANS, 'N' ).AND. - $ .NOT.LSAME( TRANS, 'T' ).AND. - $ .NOT.LSAME( TRANS, 'C' ) )THEN - INFO = 2 - ELSE IF( .NOT.LSAME( DIAG , 'U' ).AND. - $ .NOT.LSAME( DIAG , 'N' ) )THEN - INFO = 3 - ELSE IF( N.LT.0 )THEN - INFO = 4 - ELSE IF( INCX.EQ.0 )THEN - INFO = 7 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'DTPSV ', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( N.EQ.0 ) - $ RETURN -* - NOUNIT = LSAME( DIAG, 'N' ) -* -* Set up the start point in X if the increment is not unity. This -* will be ( N - 1 )*INCX too small for descending loops. -* - IF( INCX.LE.0 )THEN - KX = 1 - ( N - 1 )*INCX - ELSE IF( INCX.NE.1 )THEN - KX = 1 - END IF -* -* Start the operations. In this version the elements of AP are -* accessed sequentially with one pass through AP. -* - IF( LSAME( TRANS, 'N' ) )THEN -* -* Form x := inv( A )*x. -* - IF( LSAME( UPLO, 'U' ) )THEN - KK = ( N*( N + 1 ) )/2 - IF( INCX.EQ.1 )THEN - DO 20, J = N, 1, -1 - IF( X( J ).NE.ZERO )THEN - IF( NOUNIT ) - $ X( J ) = X( J )/AP( KK ) - TEMP = X( J ) - K = KK - 1 - DO 10, I = J - 1, 1, -1 - X( I ) = X( I ) - TEMP*AP( K ) - K = K - 1 - 10 CONTINUE - END IF - KK = KK - J - 20 CONTINUE - ELSE - JX = KX + ( N - 1 )*INCX - DO 40, J = N, 1, -1 - IF( X( JX ).NE.ZERO )THEN - IF( NOUNIT ) - $ X( JX ) = X( JX )/AP( KK ) - TEMP = X( JX ) - IX = JX - DO 30, K = KK - 1, KK - J + 1, -1 - IX = IX - INCX - X( IX ) = X( IX ) - TEMP*AP( K ) - 30 CONTINUE - END IF - JX = JX - INCX - KK = KK - J - 40 CONTINUE - END IF - ELSE - KK = 1 - IF( INCX.EQ.1 )THEN - DO 60, J = 1, N - IF( X( J ).NE.ZERO )THEN - IF( NOUNIT ) - $ X( J ) = X( J )/AP( KK ) - TEMP = X( J ) - K = KK + 1 - DO 50, I = J + 1, N - X( I ) = X( I ) - TEMP*AP( K ) - K = K + 1 - 50 CONTINUE - END IF - KK = KK + ( N - J + 1 ) - 60 CONTINUE - ELSE - JX = KX - DO 80, J = 1, N - IF( X( JX ).NE.ZERO )THEN - IF( NOUNIT ) - $ X( JX ) = X( JX )/AP( KK ) - TEMP = X( JX ) - IX = JX - DO 70, K = KK + 1, KK + N - J - IX = IX + INCX - X( IX ) = X( IX ) - TEMP*AP( K ) - 70 CONTINUE - END IF - JX = JX + INCX - KK = KK + ( N - J + 1 ) - 80 CONTINUE - END IF - END IF - ELSE -* -* Form x := inv( A' )*x. -* - IF( LSAME( UPLO, 'U' ) )THEN - KK = 1 - IF( INCX.EQ.1 )THEN - DO 100, J = 1, N - TEMP = X( J ) - K = KK - DO 90, I = 1, J - 1 - TEMP = TEMP - AP( K )*X( I ) - K = K + 1 - 90 CONTINUE - IF( NOUNIT ) - $ TEMP = TEMP/AP( KK + J - 1 ) - X( J ) = TEMP - KK = KK + J - 100 CONTINUE - ELSE - JX = KX - DO 120, J = 1, N - TEMP = X( JX ) - IX = KX - DO 110, K = KK, KK + J - 2 - TEMP = TEMP - AP( K )*X( IX ) - IX = IX + INCX - 110 CONTINUE - IF( NOUNIT ) - $ TEMP = TEMP/AP( KK + J - 1 ) - X( JX ) = TEMP - JX = JX + INCX - KK = KK + J - 120 CONTINUE - END IF - ELSE - KK = ( N*( N + 1 ) )/2 - IF( INCX.EQ.1 )THEN - DO 140, J = N, 1, -1 - TEMP = X( J ) - K = KK - DO 130, I = N, J + 1, -1 - TEMP = TEMP - AP( K )*X( I ) - K = K - 1 - 130 CONTINUE - IF( NOUNIT ) - $ TEMP = TEMP/AP( KK - N + J ) - X( J ) = TEMP - KK = KK - ( N - J + 1 ) - 140 CONTINUE - ELSE - KX = KX + ( N - 1 )*INCX - JX = KX - DO 160, J = N, 1, -1 - TEMP = X( JX ) - IX = KX - DO 150, K = KK, KK - ( N - ( J + 1 ) ), -1 - TEMP = TEMP - AP( K )*X( IX ) - IX = IX - INCX - 150 CONTINUE - IF( NOUNIT ) - $ TEMP = TEMP/AP( KK - N + J ) - X( JX ) = TEMP - JX = JX - INCX - KK = KK - (N - J + 1 ) - 160 CONTINUE - END IF - END IF - END IF -* - RETURN -* -* End of DTPSV . -* - END diff --git a/src/lib/blas/dtrmm.f b/src/lib/blas/dtrmm.f deleted file mode 100644 index f98da46a..00000000 --- a/src/lib/blas/dtrmm.f +++ /dev/null @@ -1,355 +0,0 @@ - SUBROUTINE DTRMM ( SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA, - $ B, LDB ) -* .. Scalar Arguments .. - CHARACTER*1 SIDE, UPLO, TRANSA, DIAG - INTEGER M, N, LDA, LDB - DOUBLE PRECISION ALPHA -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), B( LDB, * ) -* .. -* -* 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 .. - LOGICAL LSAME - EXTERNAL LSAME -* .. External Subroutines .. - EXTERNAL XERBLA -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. Local Scalars .. - LOGICAL LSIDE, NOUNIT, UPPER - INTEGER I, INFO, J, K, NROWA - DOUBLE PRECISION TEMP -* .. Parameters .. - DOUBLE PRECISION ONE , ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - LSIDE = LSAME( SIDE , 'L' ) - IF( LSIDE )THEN - NROWA = M - ELSE - NROWA = N - END IF - NOUNIT = LSAME( DIAG , 'N' ) - UPPER = LSAME( UPLO , 'U' ) -* - INFO = 0 - IF( ( .NOT.LSIDE ).AND. - $ ( .NOT.LSAME( SIDE , 'R' ) ) )THEN - INFO = 1 - ELSE IF( ( .NOT.UPPER ).AND. - $ ( .NOT.LSAME( UPLO , 'L' ) ) )THEN - INFO = 2 - ELSE IF( ( .NOT.LSAME( TRANSA, 'N' ) ).AND. - $ ( .NOT.LSAME( TRANSA, 'T' ) ).AND. - $ ( .NOT.LSAME( TRANSA, 'C' ) ) )THEN - INFO = 3 - ELSE IF( ( .NOT.LSAME( DIAG , 'U' ) ).AND. - $ ( .NOT.LSAME( DIAG , 'N' ) ) )THEN - INFO = 4 - ELSE IF( M .LT.0 )THEN - INFO = 5 - ELSE IF( N .LT.0 )THEN - INFO = 6 - ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN - INFO = 9 - ELSE IF( LDB.LT.MAX( 1, M ) )THEN - INFO = 11 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'DTRMM ', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( N.EQ.0 ) - $ RETURN -* -* And when alpha.eq.zero. -* - IF( ALPHA.EQ.ZERO )THEN - DO 20, J = 1, N - DO 10, I = 1, M - B( I, J ) = ZERO - 10 CONTINUE - 20 CONTINUE - RETURN - END IF -* -* Start the operations. -* - IF( LSIDE )THEN - IF( LSAME( TRANSA, 'N' ) )THEN -* -* Form B := alpha*A*B. -* - IF( UPPER )THEN - DO 50, J = 1, N - DO 40, K = 1, M - IF( B( K, J ).NE.ZERO )THEN - TEMP = ALPHA*B( K, J ) - DO 30, I = 1, K - 1 - B( I, J ) = B( I, J ) + TEMP*A( I, K ) - 30 CONTINUE - IF( NOUNIT ) - $ TEMP = TEMP*A( K, K ) - B( K, J ) = TEMP - END IF - 40 CONTINUE - 50 CONTINUE - ELSE - DO 80, J = 1, N - DO 70 K = M, 1, -1 - IF( B( K, J ).NE.ZERO )THEN - TEMP = ALPHA*B( K, J ) - B( K, J ) = TEMP - IF( NOUNIT ) - $ B( K, J ) = B( K, J )*A( K, K ) - DO 60, I = K + 1, M - B( I, J ) = B( I, J ) + TEMP*A( I, K ) - 60 CONTINUE - END IF - 70 CONTINUE - 80 CONTINUE - END IF - ELSE -* -* Form B := alpha*B*A'. -* - IF( UPPER )THEN - DO 110, J = 1, N - DO 100, I = M, 1, -1 - TEMP = B( I, J ) - IF( NOUNIT ) - $ TEMP = TEMP*A( I, I ) - DO 90, K = 1, I - 1 - TEMP = TEMP + A( K, I )*B( K, J ) - 90 CONTINUE - B( I, J ) = ALPHA*TEMP - 100 CONTINUE - 110 CONTINUE - ELSE - DO 140, J = 1, N - DO 130, I = 1, M - TEMP = B( I, J ) - IF( NOUNIT ) - $ TEMP = TEMP*A( I, I ) - DO 120, K = I + 1, M - TEMP = TEMP + A( K, I )*B( K, J ) - 120 CONTINUE - B( I, J ) = ALPHA*TEMP - 130 CONTINUE - 140 CONTINUE - END IF - END IF - ELSE - IF( LSAME( TRANSA, 'N' ) )THEN -* -* Form B := alpha*B*A. -* - IF( UPPER )THEN - DO 180, J = N, 1, -1 - TEMP = ALPHA - IF( NOUNIT ) - $ TEMP = TEMP*A( J, J ) - DO 150, I = 1, M - B( I, J ) = TEMP*B( I, J ) - 150 CONTINUE - DO 170, K = 1, J - 1 - IF( A( K, J ).NE.ZERO )THEN - TEMP = ALPHA*A( K, J ) - DO 160, I = 1, M - B( I, J ) = B( I, J ) + TEMP*B( I, K ) - 160 CONTINUE - END IF - 170 CONTINUE - 180 CONTINUE - ELSE - DO 220, J = 1, N - TEMP = ALPHA - IF( NOUNIT ) - $ TEMP = TEMP*A( J, J ) - DO 190, I = 1, M - B( I, J ) = TEMP*B( I, J ) - 190 CONTINUE - DO 210, K = J + 1, N - IF( A( K, J ).NE.ZERO )THEN - TEMP = ALPHA*A( K, J ) - DO 200, I = 1, M - B( I, J ) = B( I, J ) + TEMP*B( I, K ) - 200 CONTINUE - END IF - 210 CONTINUE - 220 CONTINUE - END IF - ELSE -* -* Form B := alpha*B*A'. -* - IF( UPPER )THEN - DO 260, K = 1, N - DO 240, J = 1, K - 1 - IF( A( J, K ).NE.ZERO )THEN - TEMP = ALPHA*A( J, K ) - DO 230, I = 1, M - B( I, J ) = B( I, J ) + TEMP*B( I, K ) - 230 CONTINUE - END IF - 240 CONTINUE - TEMP = ALPHA - IF( NOUNIT ) - $ TEMP = TEMP*A( K, K ) - IF( TEMP.NE.ONE )THEN - DO 250, I = 1, M - B( I, K ) = TEMP*B( I, K ) - 250 CONTINUE - END IF - 260 CONTINUE - ELSE - DO 300, K = N, 1, -1 - DO 280, J = K + 1, N - IF( A( J, K ).NE.ZERO )THEN - TEMP = ALPHA*A( J, K ) - DO 270, I = 1, M - B( I, J ) = B( I, J ) + TEMP*B( I, K ) - 270 CONTINUE - END IF - 280 CONTINUE - TEMP = ALPHA - IF( NOUNIT ) - $ TEMP = TEMP*A( K, K ) - IF( TEMP.NE.ONE )THEN - DO 290, I = 1, M - B( I, K ) = TEMP*B( I, K ) - 290 CONTINUE - END IF - 300 CONTINUE - END IF - END IF - END IF -* - RETURN -* -* End of DTRMM . -* - END diff --git a/src/lib/blas/dtrmv.f b/src/lib/blas/dtrmv.f deleted file mode 100644 index 3d5c61b2..00000000 --- a/src/lib/blas/dtrmv.f +++ /dev/null @@ -1,286 +0,0 @@ - SUBROUTINE DTRMV ( UPLO, TRANS, DIAG, N, A, LDA, X, INCX ) -* .. Scalar Arguments .. - INTEGER INCX, LDA, N - CHARACTER*1 DIAG, TRANS, UPLO -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), X( * ) -* .. -* -* 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 .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D+0 ) -* .. Local Scalars .. - DOUBLE PRECISION TEMP - INTEGER I, INFO, IX, J, JX, KX - LOGICAL NOUNIT -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. External Subroutines .. - EXTERNAL XERBLA -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - IF ( .NOT.LSAME( UPLO , 'U' ).AND. - $ .NOT.LSAME( UPLO , 'L' ) )THEN - INFO = 1 - ELSE IF( .NOT.LSAME( TRANS, 'N' ).AND. - $ .NOT.LSAME( TRANS, 'T' ).AND. - $ .NOT.LSAME( TRANS, 'C' ) )THEN - INFO = 2 - ELSE IF( .NOT.LSAME( DIAG , 'U' ).AND. - $ .NOT.LSAME( DIAG , 'N' ) )THEN - INFO = 3 - ELSE IF( N.LT.0 )THEN - INFO = 4 - ELSE IF( LDA.LT.MAX( 1, N ) )THEN - INFO = 6 - ELSE IF( INCX.EQ.0 )THEN - INFO = 8 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'DTRMV ', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( N.EQ.0 ) - $ RETURN -* - NOUNIT = LSAME( DIAG, 'N' ) -* -* Set up the start point in X if the increment is not unity. This -* will be ( N - 1 )*INCX too small for descending loops. -* - IF( INCX.LE.0 )THEN - KX = 1 - ( N - 1 )*INCX - ELSE IF( INCX.NE.1 )THEN - KX = 1 - END IF -* -* Start the operations. In this version the elements of A are -* accessed sequentially with one pass through A. -* - IF( LSAME( TRANS, 'N' ) )THEN -* -* Form x := A*x. -* - IF( LSAME( UPLO, 'U' ) )THEN - IF( INCX.EQ.1 )THEN - DO 20, J = 1, N - IF( X( J ).NE.ZERO )THEN - TEMP = X( J ) - DO 10, I = 1, J - 1 - X( I ) = X( I ) + TEMP*A( I, J ) - 10 CONTINUE - IF( NOUNIT ) - $ X( J ) = X( J )*A( J, J ) - END IF - 20 CONTINUE - ELSE - JX = KX - DO 40, J = 1, N - IF( X( JX ).NE.ZERO )THEN - TEMP = X( JX ) - IX = KX - DO 30, I = 1, J - 1 - X( IX ) = X( IX ) + TEMP*A( I, J ) - IX = IX + INCX - 30 CONTINUE - IF( NOUNIT ) - $ X( JX ) = X( JX )*A( J, J ) - END IF - JX = JX + INCX - 40 CONTINUE - END IF - ELSE - IF( INCX.EQ.1 )THEN - DO 60, J = N, 1, -1 - IF( X( J ).NE.ZERO )THEN - TEMP = X( J ) - DO 50, I = N, J + 1, -1 - X( I ) = X( I ) + TEMP*A( I, J ) - 50 CONTINUE - IF( NOUNIT ) - $ X( J ) = X( J )*A( J, J ) - END IF - 60 CONTINUE - ELSE - KX = KX + ( N - 1 )*INCX - JX = KX - DO 80, J = N, 1, -1 - IF( X( JX ).NE.ZERO )THEN - TEMP = X( JX ) - IX = KX - DO 70, I = N, J + 1, -1 - X( IX ) = X( IX ) + TEMP*A( I, J ) - IX = IX - INCX - 70 CONTINUE - IF( NOUNIT ) - $ X( JX ) = X( JX )*A( J, J ) - END IF - JX = JX - INCX - 80 CONTINUE - END IF - END IF - ELSE -* -* Form x := A'*x. -* - IF( LSAME( UPLO, 'U' ) )THEN - IF( INCX.EQ.1 )THEN - DO 100, J = N, 1, -1 - TEMP = X( J ) - IF( NOUNIT ) - $ TEMP = TEMP*A( J, J ) - DO 90, I = J - 1, 1, -1 - TEMP = TEMP + A( I, J )*X( I ) - 90 CONTINUE - X( J ) = TEMP - 100 CONTINUE - ELSE - JX = KX + ( N - 1 )*INCX - DO 120, J = N, 1, -1 - TEMP = X( JX ) - IX = JX - IF( NOUNIT ) - $ TEMP = TEMP*A( J, J ) - DO 110, I = J - 1, 1, -1 - IX = IX - INCX - TEMP = TEMP + A( I, J )*X( IX ) - 110 CONTINUE - X( JX ) = TEMP - JX = JX - INCX - 120 CONTINUE - END IF - ELSE - IF( INCX.EQ.1 )THEN - DO 140, J = 1, N - TEMP = X( J ) - IF( NOUNIT ) - $ TEMP = TEMP*A( J, J ) - DO 130, I = J + 1, N - TEMP = TEMP + A( I, J )*X( I ) - 130 CONTINUE - X( J ) = TEMP - 140 CONTINUE - ELSE - JX = KX - DO 160, J = 1, N - TEMP = X( JX ) - IX = JX - IF( NOUNIT ) - $ TEMP = TEMP*A( J, J ) - DO 150, I = J + 1, N - IX = IX + INCX - TEMP = TEMP + A( I, J )*X( IX ) - 150 CONTINUE - X( JX ) = TEMP - JX = JX + INCX - 160 CONTINUE - END IF - END IF - END IF -* - RETURN -* -* End of DTRMV . -* - END diff --git a/src/lib/blas/dtrsm.f b/src/lib/blas/dtrsm.f deleted file mode 100644 index e8425142..00000000 --- a/src/lib/blas/dtrsm.f +++ /dev/null @@ -1,378 +0,0 @@ - SUBROUTINE DTRSM ( SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA, - $ B, LDB ) -* .. Scalar Arguments .. - CHARACTER*1 SIDE, UPLO, TRANSA, DIAG - INTEGER M, N, LDA, LDB - DOUBLE PRECISION ALPHA -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), B( LDB, * ) -* .. -* -* 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 .. - LOGICAL LSAME - EXTERNAL LSAME -* .. External Subroutines .. - EXTERNAL XERBLA -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. Local Scalars .. - LOGICAL LSIDE, NOUNIT, UPPER - INTEGER I, INFO, J, K, NROWA - DOUBLE PRECISION TEMP -* .. Parameters .. - DOUBLE PRECISION ONE , ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - LSIDE = LSAME( SIDE , 'L' ) - IF( LSIDE )THEN - NROWA = M - ELSE - NROWA = N - END IF - NOUNIT = LSAME( DIAG , 'N' ) - UPPER = LSAME( UPLO , 'U' ) -* - INFO = 0 - IF( ( .NOT.LSIDE ).AND. - $ ( .NOT.LSAME( SIDE , 'R' ) ) )THEN - INFO = 1 - ELSE IF( ( .NOT.UPPER ).AND. - $ ( .NOT.LSAME( UPLO , 'L' ) ) )THEN - INFO = 2 - ELSE IF( ( .NOT.LSAME( TRANSA, 'N' ) ).AND. - $ ( .NOT.LSAME( TRANSA, 'T' ) ).AND. - $ ( .NOT.LSAME( TRANSA, 'C' ) ) )THEN - INFO = 3 - ELSE IF( ( .NOT.LSAME( DIAG , 'U' ) ).AND. - $ ( .NOT.LSAME( DIAG , 'N' ) ) )THEN - INFO = 4 - ELSE IF( M .LT.0 )THEN - INFO = 5 - ELSE IF( N .LT.0 )THEN - INFO = 6 - ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN - INFO = 9 - ELSE IF( LDB.LT.MAX( 1, M ) )THEN - INFO = 11 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'DTRSM ', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( N.EQ.0 ) - $ RETURN -* -* And when alpha.eq.zero. -* - IF( ALPHA.EQ.ZERO )THEN - DO 20, J = 1, N - DO 10, I = 1, M - B( I, J ) = ZERO - 10 CONTINUE - 20 CONTINUE - RETURN - END IF -* -* Start the operations. -* - IF( LSIDE )THEN - IF( LSAME( TRANSA, 'N' ) )THEN -* -* Form B := alpha*inv( A )*B. -* - IF( UPPER )THEN - DO 60, J = 1, N - IF( ALPHA.NE.ONE )THEN - DO 30, I = 1, M - B( I, J ) = ALPHA*B( I, J ) - 30 CONTINUE - END IF - DO 50, K = M, 1, -1 - IF( B( K, J ).NE.ZERO )THEN - IF( NOUNIT ) - $ B( K, J ) = B( K, J )/A( K, K ) - DO 40, I = 1, K - 1 - B( I, J ) = B( I, J ) - B( K, J )*A( I, K ) - 40 CONTINUE - END IF - 50 CONTINUE - 60 CONTINUE - ELSE - DO 100, J = 1, N - IF( ALPHA.NE.ONE )THEN - DO 70, I = 1, M - B( I, J ) = ALPHA*B( I, J ) - 70 CONTINUE - END IF - DO 90 K = 1, M - IF( B( K, J ).NE.ZERO )THEN - IF( NOUNIT ) - $ B( K, J ) = B( K, J )/A( K, K ) - DO 80, I = K + 1, M - B( I, J ) = B( I, J ) - B( K, J )*A( I, K ) - 80 CONTINUE - END IF - 90 CONTINUE - 100 CONTINUE - END IF - ELSE -* -* Form B := alpha*inv( A' )*B. -* - IF( UPPER )THEN - DO 130, J = 1, N - DO 120, I = 1, M - TEMP = ALPHA*B( I, J ) - DO 110, K = 1, I - 1 - TEMP = TEMP - A( K, I )*B( K, J ) - 110 CONTINUE - IF( NOUNIT ) - $ TEMP = TEMP/A( I, I ) - B( I, J ) = TEMP - 120 CONTINUE - 130 CONTINUE - ELSE - DO 160, J = 1, N - DO 150, I = M, 1, -1 - TEMP = ALPHA*B( I, J ) - DO 140, K = I + 1, M - TEMP = TEMP - A( K, I )*B( K, J ) - 140 CONTINUE - IF( NOUNIT ) - $ TEMP = TEMP/A( I, I ) - B( I, J ) = TEMP - 150 CONTINUE - 160 CONTINUE - END IF - END IF - ELSE - IF( LSAME( TRANSA, 'N' ) )THEN -* -* Form B := alpha*B*inv( A ). -* - IF( UPPER )THEN - DO 210, J = 1, N - IF( ALPHA.NE.ONE )THEN - DO 170, I = 1, M - B( I, J ) = ALPHA*B( I, J ) - 170 CONTINUE - END IF - DO 190, K = 1, J - 1 - IF( A( K, J ).NE.ZERO )THEN - DO 180, I = 1, M - B( I, J ) = B( I, J ) - A( K, J )*B( I, K ) - 180 CONTINUE - END IF - 190 CONTINUE - IF( NOUNIT )THEN - TEMP = ONE/A( J, J ) - DO 200, I = 1, M - B( I, J ) = TEMP*B( I, J ) - 200 CONTINUE - END IF - 210 CONTINUE - ELSE - DO 260, J = N, 1, -1 - IF( ALPHA.NE.ONE )THEN - DO 220, I = 1, M - B( I, J ) = ALPHA*B( I, J ) - 220 CONTINUE - END IF - DO 240, K = J + 1, N - IF( A( K, J ).NE.ZERO )THEN - DO 230, I = 1, M - B( I, J ) = B( I, J ) - A( K, J )*B( I, K ) - 230 CONTINUE - END IF - 240 CONTINUE - IF( NOUNIT )THEN - TEMP = ONE/A( J, J ) - DO 250, I = 1, M - B( I, J ) = TEMP*B( I, J ) - 250 CONTINUE - END IF - 260 CONTINUE - END IF - ELSE -* -* Form B := alpha*B*inv( A' ). -* - IF( UPPER )THEN - DO 310, K = N, 1, -1 - IF( NOUNIT )THEN - TEMP = ONE/A( K, K ) - DO 270, I = 1, M - B( I, K ) = TEMP*B( I, K ) - 270 CONTINUE - END IF - DO 290, J = 1, K - 1 - IF( A( J, K ).NE.ZERO )THEN - TEMP = A( J, K ) - DO 280, I = 1, M - B( I, J ) = B( I, J ) - TEMP*B( I, K ) - 280 CONTINUE - END IF - 290 CONTINUE - IF( ALPHA.NE.ONE )THEN - DO 300, I = 1, M - B( I, K ) = ALPHA*B( I, K ) - 300 CONTINUE - END IF - 310 CONTINUE - ELSE - DO 360, K = 1, N - IF( NOUNIT )THEN - TEMP = ONE/A( K, K ) - DO 320, I = 1, M - B( I, K ) = TEMP*B( I, K ) - 320 CONTINUE - END IF - DO 340, J = K + 1, N - IF( A( J, K ).NE.ZERO )THEN - TEMP = A( J, K ) - DO 330, I = 1, M - B( I, J ) = B( I, J ) - TEMP*B( I, K ) - 330 CONTINUE - END IF - 340 CONTINUE - IF( ALPHA.NE.ONE )THEN - DO 350, I = 1, M - B( I, K ) = ALPHA*B( I, K ) - 350 CONTINUE - END IF - 360 CONTINUE - END IF - END IF - END IF -* - RETURN -* -* End of DTRSM . -* - END diff --git a/src/lib/blas/dtrsv.f b/src/lib/blas/dtrsv.f deleted file mode 100644 index 9c3e90a9..00000000 --- a/src/lib/blas/dtrsv.f +++ /dev/null @@ -1,289 +0,0 @@ - SUBROUTINE DTRSV ( UPLO, TRANS, DIAG, N, A, LDA, X, INCX ) -* .. Scalar Arguments .. - INTEGER INCX, LDA, N - CHARACTER*1 DIAG, TRANS, UPLO -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), X( * ) -* .. -* -* 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 .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D+0 ) -* .. Local Scalars .. - DOUBLE PRECISION TEMP - INTEGER I, INFO, IX, J, JX, KX - LOGICAL NOUNIT -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. External Subroutines .. - EXTERNAL XERBLA -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - IF ( .NOT.LSAME( UPLO , 'U' ).AND. - $ .NOT.LSAME( UPLO , 'L' ) )THEN - INFO = 1 - ELSE IF( .NOT.LSAME( TRANS, 'N' ).AND. - $ .NOT.LSAME( TRANS, 'T' ).AND. - $ .NOT.LSAME( TRANS, 'C' ) )THEN - INFO = 2 - ELSE IF( .NOT.LSAME( DIAG , 'U' ).AND. - $ .NOT.LSAME( DIAG , 'N' ) )THEN - INFO = 3 - ELSE IF( N.LT.0 )THEN - INFO = 4 - ELSE IF( LDA.LT.MAX( 1, N ) )THEN - INFO = 6 - ELSE IF( INCX.EQ.0 )THEN - INFO = 8 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'DTRSV ', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( N.EQ.0 ) - $ RETURN -* - NOUNIT = LSAME( DIAG, 'N' ) -* -* Set up the start point in X if the increment is not unity. This -* will be ( N - 1 )*INCX too small for descending loops. -* - IF( INCX.LE.0 )THEN - KX = 1 - ( N - 1 )*INCX - ELSE IF( INCX.NE.1 )THEN - KX = 1 - END IF -* -* Start the operations. In this version the elements of A are -* accessed sequentially with one pass through A. -* - IF( LSAME( TRANS, 'N' ) )THEN -* -* Form x := inv( A )*x. -* - IF( LSAME( UPLO, 'U' ) )THEN - IF( INCX.EQ.1 )THEN - DO 20, J = N, 1, -1 - IF( X( J ).NE.ZERO )THEN - IF( NOUNIT ) - $ X( J ) = X( J )/A( J, J ) - TEMP = X( J ) - DO 10, I = J - 1, 1, -1 - X( I ) = X( I ) - TEMP*A( I, J ) - 10 CONTINUE - END IF - 20 CONTINUE - ELSE - JX = KX + ( N - 1 )*INCX - DO 40, J = N, 1, -1 - IF( X( JX ).NE.ZERO )THEN - IF( NOUNIT ) - $ X( JX ) = X( JX )/A( J, J ) - TEMP = X( JX ) - IX = JX - DO 30, I = J - 1, 1, -1 - IX = IX - INCX - X( IX ) = X( IX ) - TEMP*A( I, J ) - 30 CONTINUE - END IF - JX = JX - INCX - 40 CONTINUE - END IF - ELSE - IF( INCX.EQ.1 )THEN - DO 60, J = 1, N - IF( X( J ).NE.ZERO )THEN - IF( NOUNIT ) - $ X( J ) = X( J )/A( J, J ) - TEMP = X( J ) - DO 50, I = J + 1, N - X( I ) = X( I ) - TEMP*A( I, J ) - 50 CONTINUE - END IF - 60 CONTINUE - ELSE - JX = KX - DO 80, J = 1, N - IF( X( JX ).NE.ZERO )THEN - IF( NOUNIT ) - $ X( JX ) = X( JX )/A( J, J ) - TEMP = X( JX ) - IX = JX - DO 70, I = J + 1, N - IX = IX + INCX - X( IX ) = X( IX ) - TEMP*A( I, J ) - 70 CONTINUE - END IF - JX = JX + INCX - 80 CONTINUE - END IF - END IF - ELSE -* -* Form x := inv( A' )*x. -* - IF( LSAME( UPLO, 'U' ) )THEN - IF( INCX.EQ.1 )THEN - DO 100, J = 1, N - TEMP = X( J ) - DO 90, I = 1, J - 1 - TEMP = TEMP - A( I, J )*X( I ) - 90 CONTINUE - IF( NOUNIT ) - $ TEMP = TEMP/A( J, J ) - X( J ) = TEMP - 100 CONTINUE - ELSE - JX = KX - DO 120, J = 1, N - TEMP = X( JX ) - IX = KX - DO 110, I = 1, J - 1 - TEMP = TEMP - A( I, J )*X( IX ) - IX = IX + INCX - 110 CONTINUE - IF( NOUNIT ) - $ TEMP = TEMP/A( J, J ) - X( JX ) = TEMP - JX = JX + INCX - 120 CONTINUE - END IF - ELSE - IF( INCX.EQ.1 )THEN - DO 140, J = N, 1, -1 - TEMP = X( J ) - DO 130, I = N, J + 1, -1 - TEMP = TEMP - A( I, J )*X( I ) - 130 CONTINUE - IF( NOUNIT ) - $ TEMP = TEMP/A( J, J ) - X( J ) = TEMP - 140 CONTINUE - ELSE - KX = KX + ( N - 1 )*INCX - JX = KX - DO 160, J = N, 1, -1 - TEMP = X( JX ) - IX = KX - DO 150, I = N, J + 1, -1 - TEMP = TEMP - A( I, J )*X( IX ) - IX = IX - INCX - 150 CONTINUE - IF( NOUNIT ) - $ TEMP = TEMP/A( J, J ) - X( JX ) = TEMP - JX = JX - INCX - 160 CONTINUE - END IF - END IF - END IF -* - RETURN -* -* End of DTRSV . -* - END diff --git a/src/lib/blas/dzasum.f b/src/lib/blas/dzasum.f deleted file mode 100644 index d21c1ffc..00000000 --- a/src/lib/blas/dzasum.f +++ /dev/null @@ -1,34 +0,0 @@ - double precision function dzasum(n,zx,incx) -c -c takes the sum of the absolute values. -c jack dongarra, 3/11/78. -c modified 3/93 to return if incx .le. 0. -c modified 12/3/93, array(1) declarations changed to array(*) -c - double complex zx(*) - double precision stemp,dcabs1 - integer i,incx,ix,n -c - dzasum = 0.0d0 - stemp = 0.0d0 - if( n.le.0 .or. incx.le.0 )return - if(incx.eq.1)go to 20 -c -c code for increment not equal to 1 -c - ix = 1 - do 10 i = 1,n - stemp = stemp + dcabs1(zx(ix)) - ix = ix + incx - 10 continue - dzasum = stemp - return -c -c code for increment equal to 1 -c - 20 do 30 i = 1,n - stemp = stemp + dcabs1(zx(i)) - 30 continue - dzasum = stemp - return - end diff --git a/src/lib/blas/dznrm2.f b/src/lib/blas/dznrm2.f deleted file mode 100644 index 205ce393..00000000 --- a/src/lib/blas/dznrm2.f +++ /dev/null @@ -1,67 +0,0 @@ - DOUBLE PRECISION FUNCTION DZNRM2( N, X, INCX ) -* .. Scalar Arguments .. - INTEGER INCX, N -* .. Array Arguments .. - COMPLEX*16 X( * ) -* .. -* -* 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 .. - DOUBLE PRECISION ONE , ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. Local Scalars .. - INTEGER IX - DOUBLE PRECISION NORM, SCALE, SSQ, TEMP -* .. Intrinsic Functions .. - INTRINSIC ABS, DIMAG, DBLE, SQRT -* .. -* .. Executable Statements .. - IF( N.LT.1 .OR. INCX.LT.1 )THEN - NORM = ZERO - ELSE - SCALE = ZERO - SSQ = ONE -* The following loop is equivalent to this call to the LAPACK -* auxiliary routine: -* CALL ZLASSQ( N, X, INCX, SCALE, SSQ ) -* - DO 10, IX = 1, 1 + ( N - 1 )*INCX, INCX - IF( DBLE( X( IX ) ).NE.ZERO )THEN - TEMP = ABS( DBLE( X( IX ) ) ) - IF( SCALE.LT.TEMP )THEN - SSQ = ONE + SSQ*( SCALE/TEMP )**2 - SCALE = TEMP - ELSE - SSQ = SSQ + ( TEMP/SCALE )**2 - END IF - END IF - IF( DIMAG( X( IX ) ).NE.ZERO )THEN - TEMP = ABS( DIMAG( X( IX ) ) ) - IF( SCALE.LT.TEMP )THEN - SSQ = ONE + SSQ*( SCALE/TEMP )**2 - SCALE = TEMP - ELSE - SSQ = SSQ + ( TEMP/SCALE )**2 - END IF - END IF - 10 CONTINUE - NORM = SCALE * SQRT( SSQ ) - END IF -* - DZNRM2 = NORM - RETURN -* -* End of DZNRM2. -* - END diff --git a/src/lib/blas/idamax.f b/src/lib/blas/idamax.f deleted file mode 100644 index 59d80dc4..00000000 --- a/src/lib/blas/idamax.f +++ /dev/null @@ -1,39 +0,0 @@ - integer function idamax(n,dx,incx) -c -c finds the index of element having max. absolute value. -c jack dongarra, linpack, 3/11/78. -c modified 3/93 to return if incx .le. 0. -c modified 12/3/93, array(1) declarations changed to array(*) -c - double precision dx(*),dmax - integer i,incx,ix,n -c - idamax = 0 - if( n.lt.1 .or. incx.le.0 ) return - idamax = 1 - if(n.eq.1)return - if(incx.eq.1)go to 20 -c -c code for increment not equal to 1 -c - ix = 1 - dmax = dabs(dx(1)) - ix = ix + incx - do 10 i = 2,n - if(dabs(dx(ix)).le.dmax) go to 5 - idamax = i - dmax = dabs(dx(ix)) - 5 ix = ix + incx - 10 continue - return -c -c code for increment equal to 1 -c - 20 dmax = dabs(dx(1)) - do 30 i = 2,n - if(dabs(dx(i)).le.dmax) go to 30 - idamax = i - dmax = dabs(dx(i)) - 30 continue - return - end diff --git a/src/lib/blas/izamax.f b/src/lib/blas/izamax.f deleted file mode 100644 index ec14f827..00000000 --- a/src/lib/blas/izamax.f +++ /dev/null @@ -1,41 +0,0 @@ - integer function izamax(n,zx,incx) -c -c finds the index of element having max. absolute value. -c jack dongarra, 1/15/85. -c modified 3/93 to return if incx .le. 0. -c modified 12/3/93, array(1) declarations changed to array(*) -c - double complex zx(*) - double precision smax - integer i,incx,ix,n - double precision dcabs1 -c - izamax = 0 - if( n.lt.1 .or. incx.le.0 )return - izamax = 1 - if(n.eq.1)return - if(incx.eq.1)go to 20 -c -c code for increment not equal to 1 -c - ix = 1 - smax = dcabs1(zx(1)) - ix = ix + incx - do 10 i = 2,n - if(dcabs1(zx(ix)).le.smax) go to 5 - izamax = i - smax = dcabs1(zx(ix)) - 5 ix = ix + incx - 10 continue - return -c -c code for increment equal to 1 -c - 20 smax = dcabs1(zx(1)) - do 30 i = 2,n - if(dcabs1(zx(i)).le.smax) go to 30 - izamax = i - smax = dcabs1(zx(i)) - 30 continue - return - end diff --git a/src/lib/blas/license.txt b/src/lib/blas/license.txt deleted file mode 100644 index 8014a5bd..00000000 --- a/src/lib/blas/license.txt +++ /dev/null @@ -1,6 +0,0 @@ -This software is in the public domain - - -More information: -http://www.netlib.org/blas/faq.html#2 -http://packages.debian.org/changelogs/pool/main/b/blas/blas_1.1-14/blas.copyright
\ No newline at end of file diff --git a/src/lib/blas/lsame.f b/src/lib/blas/lsame.f deleted file mode 100644 index bf25d86f..00000000 --- a/src/lib/blas/lsame.f +++ /dev/null @@ -1,87 +0,0 @@ - LOGICAL FUNCTION LSAME( CA, CB ) -* -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* September 30, 1994 -* -* .. Scalar Arguments .. - CHARACTER CA, CB -* .. -* -* Purpose -* ======= -* -* LSAME returns .TRUE. if CA is the same letter as CB regardless of -* case. -* -* Arguments -* ========= -* -* CA (input) CHARACTER*1 -* CB (input) CHARACTER*1 -* CA and CB specify the single characters to be compared. -* -* ===================================================================== -* -* .. Intrinsic Functions .. - INTRINSIC ICHAR -* .. -* .. Local Scalars .. - INTEGER INTA, INTB, ZCODE -* .. -* .. Executable Statements .. -* -* Test if the characters are equal -* - LSAME = CA.EQ.CB - IF( LSAME ) - $ RETURN -* -* Now test for equivalence if both characters are alphabetic. -* - ZCODE = ICHAR( 'Z' ) -* -* Use 'Z' rather than 'A' so that ASCII can be detected on Prime -* machines, on which ICHAR returns a value with bit 8 set. -* ICHAR('A') on Prime machines returns 193 which is the same as -* ICHAR('A') on an EBCDIC machine. -* - INTA = ICHAR( CA ) - INTB = ICHAR( CB ) -* - IF( ZCODE.EQ.90 .OR. ZCODE.EQ.122 ) THEN -* -* ASCII is assumed - ZCODE is the ASCII code of either lower or -* upper case 'Z'. -* - IF( INTA.GE.97 .AND. INTA.LE.122 ) INTA = INTA - 32 - IF( INTB.GE.97 .AND. INTB.LE.122 ) INTB = INTB - 32 -* - ELSE IF( ZCODE.EQ.233 .OR. ZCODE.EQ.169 ) THEN -* -* EBCDIC is assumed - ZCODE is the EBCDIC code of either lower or -* upper case 'Z'. -* - IF( INTA.GE.129 .AND. INTA.LE.137 .OR. - $ INTA.GE.145 .AND. INTA.LE.153 .OR. - $ INTA.GE.162 .AND. INTA.LE.169 ) INTA = INTA + 64 - IF( INTB.GE.129 .AND. INTB.LE.137 .OR. - $ INTB.GE.145 .AND. INTB.LE.153 .OR. - $ INTB.GE.162 .AND. INTB.LE.169 ) INTB = INTB + 64 -* - ELSE IF( ZCODE.EQ.218 .OR. ZCODE.EQ.250 ) THEN -* -* ASCII is assumed, on Prime machines - ZCODE is the ASCII code -* plus 128 of either lower or upper case 'Z'. -* - IF( INTA.GE.225 .AND. INTA.LE.250 ) INTA = INTA - 32 - IF( INTB.GE.225 .AND. INTB.LE.250 ) INTB = INTB - 32 - END IF - LSAME = INTA.EQ.INTB -* -* RETURN -* -* End of LSAME -* - END diff --git a/src/lib/blas/xerbla.f b/src/lib/blas/xerbla.f deleted file mode 100644 index 6e11175f..00000000 --- a/src/lib/blas/xerbla.f +++ /dev/null @@ -1,46 +0,0 @@ - SUBROUTINE XERBLA( SRNAME, INFO ) -* -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* September 30, 1994 -* -* .. Scalar Arguments .. - CHARACTER*6 SRNAME - INTEGER INFO -* .. -* -* Purpose -* ======= -* -* XERBLA is an error handler for the LAPACK routines. -* It is called by an LAPACK routine if an input parameter has an -* invalid value. A message is printed and execution stops. -* -* Installers may consider modifying the STOP statement in order to -* call system-specific exception-handling facilities. -* -* Arguments -* ========= -* -* SRNAME (input) CHARACTER*6 -* The name of the routine which called XERBLA. -* -* INFO (input) INTEGER -* The position of the invalid parameter in the parameter list -* of the calling routine. -* -* ===================================================================== -* -* .. Executable Statements .. -* - WRITE( *, FMT = 9999 )SRNAME, INFO -* - STOP -* - 9999 FORMAT( ' ** On entry to ', A6, ' parameter number ', I2, ' had ', - $ 'an illegal value' ) -* -* End of XERBLA -* - END diff --git a/src/lib/blas/zaxpy.f b/src/lib/blas/zaxpy.f deleted file mode 100644 index 4fa3b1e4..00000000 --- a/src/lib/blas/zaxpy.f +++ /dev/null @@ -1,34 +0,0 @@ - subroutine zaxpy(n,za,zx,incx,zy,incy) -c -c constant times a vector plus a vector. -c jack dongarra, 3/11/78. -c modified 12/3/93, array(1) declarations changed to array(*) -c - double complex zx(*),zy(*),za - integer i,incx,incy,ix,iy,n - double precision dcabs1 - if(n.le.0)return - if (dcabs1(za) .eq. 0.0d0) return - if (incx.eq.1.and.incy.eq.1)go to 20 -c -c code for unequal increments or equal increments -c not equal to 1 -c - ix = 1 - iy = 1 - if(incx.lt.0)ix = (-n+1)*incx + 1 - if(incy.lt.0)iy = (-n+1)*incy + 1 - do 10 i = 1,n - zy(iy) = zy(iy) + za*zx(ix) - ix = ix + incx - iy = iy + incy - 10 continue - return -c -c code for both increments equal to 1 -c - 20 do 30 i = 1,n - zy(i) = zy(i) + za*zx(i) - 30 continue - return - end diff --git a/src/lib/blas/zcopy.f b/src/lib/blas/zcopy.f deleted file mode 100644 index 9ccfa880..00000000 --- a/src/lib/blas/zcopy.f +++ /dev/null @@ -1,33 +0,0 @@ - subroutine zcopy(n,zx,incx,zy,incy) -c -c copies a vector, x, to a vector, y. -c jack dongarra, linpack, 4/11/78. -c modified 12/3/93, array(1) declarations changed to array(*) -c - double complex zx(*),zy(*) - integer i,incx,incy,ix,iy,n -c - if(n.le.0)return - if(incx.eq.1.and.incy.eq.1)go to 20 -c -c code for unequal increments or equal increments -c not equal to 1 -c - ix = 1 - iy = 1 - if(incx.lt.0)ix = (-n+1)*incx + 1 - if(incy.lt.0)iy = (-n+1)*incy + 1 - do 10 i = 1,n - zy(iy) = zx(ix) - ix = ix + incx - iy = iy + incy - 10 continue - return -c -c code for both increments equal to 1 -c - 20 do 30 i = 1,n - zy(i) = zx(i) - 30 continue - return - end diff --git a/src/lib/blas/zdotc.f b/src/lib/blas/zdotc.f deleted file mode 100644 index d6ac6853..00000000 --- a/src/lib/blas/zdotc.f +++ /dev/null @@ -1,36 +0,0 @@ - double complex function zdotc(n,zx,incx,zy,incy) -c -c forms the dot product of a vector. -c jack dongarra, 3/11/78. -c modified 12/3/93, array(1) declarations changed to array(*) -c - double complex zx(*),zy(*),ztemp - integer i,incx,incy,ix,iy,n - ztemp = (0.0d0,0.0d0) - zdotc = (0.0d0,0.0d0) - if(n.le.0)return - if(incx.eq.1.and.incy.eq.1)go to 20 -c -c code for unequal increments or equal increments -c not equal to 1 -c - ix = 1 - iy = 1 - if(incx.lt.0)ix = (-n+1)*incx + 1 - if(incy.lt.0)iy = (-n+1)*incy + 1 - do 10 i = 1,n - ztemp = ztemp + dconjg(zx(ix))*zy(iy) - ix = ix + incx - iy = iy + incy - 10 continue - zdotc = ztemp - return -c -c code for both increments equal to 1 -c - 20 do 30 i = 1,n - ztemp = ztemp + dconjg(zx(i))*zy(i) - 30 continue - zdotc = ztemp - return - end diff --git a/src/lib/blas/zdotu.f b/src/lib/blas/zdotu.f deleted file mode 100644 index 329e9885..00000000 --- a/src/lib/blas/zdotu.f +++ /dev/null @@ -1,36 +0,0 @@ - double complex function zdotu(n,zx,incx,zy,incy) -c -c forms the dot product of two vectors. -c jack dongarra, 3/11/78. -c modified 12/3/93, array(1) declarations changed to array(*) -c - double complex zx(*),zy(*),ztemp - integer i,incx,incy,ix,iy,n - ztemp = (0.0d0,0.0d0) - zdotu = (0.0d0,0.0d0) - if(n.le.0)return - if(incx.eq.1.and.incy.eq.1)go to 20 -c -c code for unequal increments or equal increments -c not equal to 1 -c - ix = 1 - iy = 1 - if(incx.lt.0)ix = (-n+1)*incx + 1 - if(incy.lt.0)iy = (-n+1)*incy + 1 - do 10 i = 1,n - ztemp = ztemp + zx(ix)*zy(iy) - ix = ix + incx - iy = iy + incy - 10 continue - zdotu = ztemp - return -c -c code for both increments equal to 1 -c - 20 do 30 i = 1,n - ztemp = ztemp + zx(i)*zy(i) - 30 continue - zdotu = ztemp - return - end diff --git a/src/lib/blas/zdscal.f b/src/lib/blas/zdscal.f deleted file mode 100644 index 8123424d..00000000 --- a/src/lib/blas/zdscal.f +++ /dev/null @@ -1,30 +0,0 @@ - subroutine zdscal(n,da,zx,incx) -c -c scales a vector by a constant. -c jack dongarra, 3/11/78. -c modified 3/93 to return if incx .le. 0. -c modified 12/3/93, array(1) declarations changed to array(*) -c - double complex zx(*) - double precision da - integer i,incx,ix,n -c - if( n.le.0 .or. incx.le.0 )return - if(incx.eq.1)go to 20 -c -c code for increment not equal to 1 -c - ix = 1 - do 10 i = 1,n - zx(ix) = dcmplx(da,0.0d0)*zx(ix) - ix = ix + incx - 10 continue - return -c -c code for increment equal to 1 -c - 20 do 30 i = 1,n - zx(i) = dcmplx(da,0.0d0)*zx(i) - 30 continue - return - end diff --git a/src/lib/blas/zgbmv.f b/src/lib/blas/zgbmv.f deleted file mode 100644 index 91ce9a60..00000000 --- a/src/lib/blas/zgbmv.f +++ /dev/null @@ -1,322 +0,0 @@ - SUBROUTINE ZGBMV ( TRANS, M, N, KL, KU, ALPHA, A, LDA, X, INCX, - $ BETA, Y, INCY ) -* .. Scalar Arguments .. - COMPLEX*16 ALPHA, BETA - INTEGER INCX, INCY, KL, KU, LDA, M, N - CHARACTER*1 TRANS -* .. Array Arguments .. - COMPLEX*16 A( LDA, * ), X( * ), Y( * ) -* .. -* -* Purpose -* ======= -* -* ZGBMV performs one of the matrix-vector operations -* -* y := alpha*A*x + beta*y, or y := alpha*A'*x + beta*y, or -* -* y := alpha*conjg( A' )*x + beta*y, -* -* where alpha and beta are scalars, x and y are vectors and A is an -* m by n band matrix, with kl sub-diagonals and ku super-diagonals. -* -* 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*16 . -* On entry, ALPHA specifies the scalar alpha. -* Unchanged on exit. -* -* A - COMPLEX*16 array of DIMENSION ( LDA, n ). -* Before entry, the leading ( kl + ku + 1 ) by n part of the -* array A must contain the matrix of coefficients, supplied -* column by column, with the leading diagonal of the matrix in -* row ( ku + 1 ) of the array, the first super-diagonal -* starting at position 2 in row ku, the first sub-diagonal -* starting at position 1 in row ( ku + 2 ), and so on. -* Elements in the array A that do not correspond to elements -* in the band matrix (such as the top left ku by ku triangle) -* are not referenced. -* The following program segment will transfer a band matrix -* from conventional full matrix storage to band storage: -* -* DO 20, J = 1, N -* K = KU + 1 - J -* DO 10, I = MAX( 1, J - KU ), MIN( M, J + KL ) -* A( K + I, J ) = matrix( I, J ) -* 10 CONTINUE -* 20 CONTINUE -* -* Unchanged on exit. -* -* LDA - INTEGER. -* On entry, LDA specifies the first dimension of A as declared -* in the calling (sub) program. LDA must be at least -* ( kl + ku + 1 ). -* Unchanged on exit. -* -* X - COMPLEX*16 array of DIMENSION at least -* ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n' -* and at least -* ( 1 + ( m - 1 )*abs( INCX ) ) otherwise. -* Before entry, the incremented array X must contain the -* vector x. -* Unchanged on exit. -* -* INCX - INTEGER. -* On entry, INCX specifies the increment for the elements of -* X. INCX must not be zero. -* Unchanged on exit. -* -* BETA - COMPLEX*16 . -* On entry, BETA specifies the scalar beta. When BETA is -* supplied as zero then Y need not be set on input. -* Unchanged on exit. -* -* Y - COMPLEX*16 array of DIMENSION at least -* ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n' -* and at least -* ( 1 + ( n - 1 )*abs( INCY ) ) otherwise. -* Before entry, the incremented array Y must contain the -* vector y. On exit, Y is overwritten by the updated vector y. -* -* -* INCY - INTEGER. -* On entry, INCY specifies the increment for the elements of -* Y. INCY must not be zero. -* Unchanged on exit. -* -* -* Level 2 Blas routine. -* -* -- Written on 22-October-1986. -* Jack Dongarra, Argonne National Lab. -* Jeremy Du Croz, Nag Central Office. -* Sven Hammarling, Nag Central Office. -* Richard Hanson, Sandia National Labs. -* -* -* .. Parameters .. - COMPLEX*16 ONE - PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) ) - COMPLEX*16 ZERO - PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) ) -* .. Local Scalars .. - COMPLEX*16 TEMP - INTEGER I, INFO, IX, IY, J, JX, JY, K, KUP1, KX, KY, - $ LENX, LENY - LOGICAL NOCONJ -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. External Subroutines .. - EXTERNAL XERBLA -* .. Intrinsic Functions .. - INTRINSIC DCONJG, MAX, MIN -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - IF ( .NOT.LSAME( TRANS, 'N' ).AND. - $ .NOT.LSAME( TRANS, 'T' ).AND. - $ .NOT.LSAME( TRANS, 'C' ) )THEN - INFO = 1 - ELSE IF( M.LT.0 )THEN - INFO = 2 - ELSE IF( N.LT.0 )THEN - INFO = 3 - ELSE IF( KL.LT.0 )THEN - INFO = 4 - ELSE IF( KU.LT.0 )THEN - INFO = 5 - ELSE IF( LDA.LT.( KL + KU + 1 ) )THEN - INFO = 8 - ELSE IF( INCX.EQ.0 )THEN - INFO = 10 - ELSE IF( INCY.EQ.0 )THEN - INFO = 13 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'ZGBMV ', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR. - $ ( ( ALPHA.EQ.ZERO ).AND.( BETA.EQ.ONE ) ) ) - $ RETURN -* - NOCONJ = LSAME( TRANS, 'T' ) -* -* Set LENX and LENY, the lengths of the vectors x and y, and set -* up the start points in X and Y. -* - IF( LSAME( TRANS, 'N' ) )THEN - LENX = N - LENY = M - ELSE - LENX = M - LENY = N - END IF - IF( INCX.GT.0 )THEN - KX = 1 - ELSE - KX = 1 - ( LENX - 1 )*INCX - END IF - IF( INCY.GT.0 )THEN - KY = 1 - ELSE - KY = 1 - ( LENY - 1 )*INCY - END IF -* -* 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.NE.ONE )THEN - IF( INCY.EQ.1 )THEN - IF( BETA.EQ.ZERO )THEN - DO 10, I = 1, LENY - Y( I ) = ZERO - 10 CONTINUE - ELSE - DO 20, I = 1, LENY - Y( I ) = BETA*Y( I ) - 20 CONTINUE - END IF - ELSE - IY = KY - IF( BETA.EQ.ZERO )THEN - DO 30, I = 1, LENY - Y( IY ) = ZERO - IY = IY + INCY - 30 CONTINUE - ELSE - DO 40, I = 1, LENY - Y( IY ) = BETA*Y( IY ) - IY = IY + INCY - 40 CONTINUE - END IF - END IF - END IF - IF( ALPHA.EQ.ZERO ) - $ RETURN - KUP1 = KU + 1 - IF( LSAME( TRANS, 'N' ) )THEN -* -* Form y := alpha*A*x + y. -* - JX = KX - IF( INCY.EQ.1 )THEN - DO 60, J = 1, N - IF( X( JX ).NE.ZERO )THEN - TEMP = ALPHA*X( JX ) - K = KUP1 - J - DO 50, I = MAX( 1, J - KU ), MIN( M, J + KL ) - Y( I ) = Y( I ) + TEMP*A( K + I, J ) - 50 CONTINUE - END IF - JX = JX + INCX - 60 CONTINUE - ELSE - DO 80, J = 1, N - IF( X( JX ).NE.ZERO )THEN - TEMP = ALPHA*X( JX ) - IY = KY - K = KUP1 - J - DO 70, I = MAX( 1, J - KU ), MIN( M, J + KL ) - Y( IY ) = Y( IY ) + TEMP*A( K + I, J ) - IY = IY + INCY - 70 CONTINUE - END IF - JX = JX + INCX - IF( J.GT.KU ) - $ KY = KY + INCY - 80 CONTINUE - END IF - ELSE -* -* Form y := alpha*A'*x + y or y := alpha*conjg( A' )*x + y. -* - JY = KY - IF( INCX.EQ.1 )THEN - DO 110, J = 1, N - TEMP = ZERO - K = KUP1 - J - IF( NOCONJ )THEN - DO 90, I = MAX( 1, J - KU ), MIN( M, J + KL ) - TEMP = TEMP + A( K + I, J )*X( I ) - 90 CONTINUE - ELSE - DO 100, I = MAX( 1, J - KU ), MIN( M, J + KL ) - TEMP = TEMP + DCONJG( A( K + I, J ) )*X( I ) - 100 CONTINUE - END IF - Y( JY ) = Y( JY ) + ALPHA*TEMP - JY = JY + INCY - 110 CONTINUE - ELSE - DO 140, J = 1, N - TEMP = ZERO - IX = KX - K = KUP1 - J - IF( NOCONJ )THEN - DO 120, I = MAX( 1, J - KU ), MIN( M, J + KL ) - TEMP = TEMP + A( K + I, J )*X( IX ) - IX = IX + INCX - 120 CONTINUE - ELSE - DO 130, I = MAX( 1, J - KU ), MIN( M, J + KL ) - TEMP = TEMP + DCONJG( A( K + I, J ) )*X( IX ) - IX = IX + INCX - 130 CONTINUE - END IF - Y( JY ) = Y( JY ) + ALPHA*TEMP - JY = JY + INCY - IF( J.GT.KU ) - $ KX = KX + INCX - 140 CONTINUE - END IF - END IF -* - RETURN -* -* End of ZGBMV . -* - END diff --git a/src/lib/blas/zgemm.f b/src/lib/blas/zgemm.f deleted file mode 100644 index 09cd151e..00000000 --- a/src/lib/blas/zgemm.f +++ /dev/null @@ -1,415 +0,0 @@ - SUBROUTINE ZGEMM ( TRANSA, TRANSB, M, N, K, ALPHA, A, LDA, B, LDB, - $ BETA, C, LDC ) -* .. Scalar Arguments .. - CHARACTER*1 TRANSA, TRANSB - INTEGER M, N, K, LDA, LDB, LDC - COMPLEX*16 ALPHA, BETA -* .. Array Arguments .. - COMPLEX*16 A( LDA, * ), B( LDB, * ), C( LDC, * ) -* .. -* -* Purpose -* ======= -* -* ZGEMM performs one of the matrix-matrix operations -* -* C := alpha*op( A )*op( B ) + beta*C, -* -* where op( X ) is one of -* -* op( X ) = X or op( X ) = X' or op( X ) = conjg( X' ), -* -* alpha and beta are scalars, and A, B and C are matrices, with op( A ) -* an m by k matrix, op( B ) a k by n matrix and C an m by n matrix. -* -* 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*16 . -* On entry, ALPHA specifies the scalar alpha. -* Unchanged on exit. -* -* A - COMPLEX*16 array of DIMENSION ( LDA, ka ), where ka is -* k when TRANSA = 'N' or 'n', and is m otherwise. -* Before entry with TRANSA = 'N' or 'n', the leading m by k -* part of the array A must contain the matrix A, otherwise -* the leading k by m part of the array A must contain the -* matrix A. -* Unchanged on exit. -* -* LDA - INTEGER. -* On entry, LDA specifies the first dimension of A as declared -* in the calling (sub) program. When TRANSA = 'N' or 'n' then -* LDA must be at least max( 1, m ), otherwise LDA must be at -* least max( 1, k ). -* Unchanged on exit. -* -* B - COMPLEX*16 array of DIMENSION ( LDB, kb ), where kb is -* n when TRANSB = 'N' or 'n', and is k otherwise. -* Before entry with TRANSB = 'N' or 'n', the leading k by n -* part of the array B must contain the matrix B, otherwise -* the leading n by k part of the array B must contain the -* matrix B. -* Unchanged on exit. -* -* LDB - INTEGER. -* On entry, LDB specifies the first dimension of B as declared -* in the calling (sub) program. When TRANSB = 'N' or 'n' then -* LDB must be at least max( 1, k ), otherwise LDB must be at -* least max( 1, n ). -* Unchanged on exit. -* -* BETA - COMPLEX*16 . -* On entry, BETA specifies the scalar beta. When BETA is -* supplied as zero then C need not be set on input. -* Unchanged on exit. -* -* C - COMPLEX*16 array of DIMENSION ( LDC, n ). -* Before entry, the leading m by n part of the array C must -* contain the matrix C, except when beta is zero, in which -* case C need not be set on entry. -* On exit, the array C is overwritten by the m by n matrix -* ( alpha*op( A )*op( B ) + beta*C ). -* -* LDC - INTEGER. -* On entry, LDC specifies the first dimension of C as declared -* in the calling (sub) program. LDC must be at least -* max( 1, m ). -* Unchanged on exit. -* -* -* Level 3 Blas routine. -* -* -- Written on 8-February-1989. -* Jack Dongarra, Argonne National Laboratory. -* Iain Duff, AERE Harwell. -* Jeremy Du Croz, Numerical Algorithms Group Ltd. -* Sven Hammarling, Numerical Algorithms Group Ltd. -* -* -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. External Subroutines .. - EXTERNAL XERBLA -* .. Intrinsic Functions .. - INTRINSIC DCONJG, MAX -* .. Local Scalars .. - LOGICAL CONJA, CONJB, NOTA, NOTB - INTEGER I, INFO, J, L, NCOLA, NROWA, NROWB - COMPLEX*16 TEMP -* .. Parameters .. - COMPLEX*16 ONE - PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) ) - COMPLEX*16 ZERO - PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) ) -* .. -* .. 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. -* - NOTA = LSAME( TRANSA, 'N' ) - NOTB = LSAME( TRANSB, 'N' ) - CONJA = LSAME( TRANSA, 'C' ) - CONJB = LSAME( TRANSB, 'C' ) - IF( NOTA )THEN - NROWA = M - NCOLA = K - ELSE - NROWA = K - NCOLA = M - END IF - IF( NOTB )THEN - NROWB = K - ELSE - NROWB = N - END IF -* -* Test the input parameters. -* - INFO = 0 - IF( ( .NOT.NOTA ).AND. - $ ( .NOT.CONJA ).AND. - $ ( .NOT.LSAME( TRANSA, 'T' ) ) )THEN - INFO = 1 - ELSE IF( ( .NOT.NOTB ).AND. - $ ( .NOT.CONJB ).AND. - $ ( .NOT.LSAME( TRANSB, 'T' ) ) )THEN - INFO = 2 - ELSE IF( M .LT.0 )THEN - INFO = 3 - ELSE IF( N .LT.0 )THEN - INFO = 4 - ELSE IF( K .LT.0 )THEN - INFO = 5 - ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN - INFO = 8 - ELSE IF( LDB.LT.MAX( 1, NROWB ) )THEN - INFO = 10 - ELSE IF( LDC.LT.MAX( 1, M ) )THEN - INFO = 13 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'ZGEMM ', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR. - $ ( ( ( ALPHA.EQ.ZERO ).OR.( K.EQ.0 ) ).AND.( BETA.EQ.ONE ) ) ) - $ RETURN -* -* And when alpha.eq.zero. -* - IF( ALPHA.EQ.ZERO )THEN - IF( BETA.EQ.ZERO )THEN - DO 20, J = 1, N - DO 10, I = 1, M - C( I, J ) = ZERO - 10 CONTINUE - 20 CONTINUE - ELSE - DO 40, J = 1, N - DO 30, I = 1, M - C( I, J ) = BETA*C( I, J ) - 30 CONTINUE - 40 CONTINUE - END IF - RETURN - END IF -* -* Start the operations. -* - IF( NOTB )THEN - IF( NOTA )THEN -* -* Form C := alpha*A*B + beta*C. -* - DO 90, J = 1, N - IF( BETA.EQ.ZERO )THEN - DO 50, I = 1, M - C( I, J ) = ZERO - 50 CONTINUE - ELSE IF( BETA.NE.ONE )THEN - DO 60, I = 1, M - C( I, J ) = BETA*C( I, J ) - 60 CONTINUE - END IF - DO 80, L = 1, K - IF( B( L, J ).NE.ZERO )THEN - TEMP = ALPHA*B( L, J ) - DO 70, I = 1, M - C( I, J ) = C( I, J ) + TEMP*A( I, L ) - 70 CONTINUE - END IF - 80 CONTINUE - 90 CONTINUE - ELSE IF( CONJA )THEN -* -* Form C := alpha*conjg( A' )*B + beta*C. -* - DO 120, J = 1, N - DO 110, I = 1, M - TEMP = ZERO - DO 100, L = 1, K - TEMP = TEMP + DCONJG( A( L, I ) )*B( L, J ) - 100 CONTINUE - IF( BETA.EQ.ZERO )THEN - C( I, J ) = ALPHA*TEMP - ELSE - C( I, J ) = ALPHA*TEMP + BETA*C( I, J ) - END IF - 110 CONTINUE - 120 CONTINUE - ELSE -* -* Form C := alpha*A'*B + beta*C -* - DO 150, J = 1, N - DO 140, I = 1, M - TEMP = ZERO - DO 130, L = 1, K - TEMP = TEMP + A( L, I )*B( L, J ) - 130 CONTINUE - IF( BETA.EQ.ZERO )THEN - C( I, J ) = ALPHA*TEMP - ELSE - C( I, J ) = ALPHA*TEMP + BETA*C( I, J ) - END IF - 140 CONTINUE - 150 CONTINUE - END IF - ELSE IF( NOTA )THEN - IF( CONJB )THEN -* -* Form C := alpha*A*conjg( B' ) + beta*C. -* - DO 200, J = 1, N - IF( BETA.EQ.ZERO )THEN - DO 160, I = 1, M - C( I, J ) = ZERO - 160 CONTINUE - ELSE IF( BETA.NE.ONE )THEN - DO 170, I = 1, M - C( I, J ) = BETA*C( I, J ) - 170 CONTINUE - END IF - DO 190, L = 1, K - IF( B( J, L ).NE.ZERO )THEN - TEMP = ALPHA*DCONJG( B( J, L ) ) - DO 180, I = 1, M - C( I, J ) = C( I, J ) + TEMP*A( I, L ) - 180 CONTINUE - END IF - 190 CONTINUE - 200 CONTINUE - ELSE -* -* Form C := alpha*A*B' + beta*C -* - DO 250, J = 1, N - IF( BETA.EQ.ZERO )THEN - DO 210, I = 1, M - C( I, J ) = ZERO - 210 CONTINUE - ELSE IF( BETA.NE.ONE )THEN - DO 220, I = 1, M - C( I, J ) = BETA*C( I, J ) - 220 CONTINUE - END IF - DO 240, L = 1, K - IF( B( J, L ).NE.ZERO )THEN - TEMP = ALPHA*B( J, L ) - DO 230, I = 1, M - C( I, J ) = C( I, J ) + TEMP*A( I, L ) - 230 CONTINUE - END IF - 240 CONTINUE - 250 CONTINUE - END IF - ELSE IF( CONJA )THEN - IF( CONJB )THEN -* -* Form C := alpha*conjg( A' )*conjg( B' ) + beta*C. -* - DO 280, J = 1, N - DO 270, I = 1, M - TEMP = ZERO - DO 260, L = 1, K - TEMP = TEMP + - $ DCONJG( A( L, I ) )*DCONJG( B( J, L ) ) - 260 CONTINUE - IF( BETA.EQ.ZERO )THEN - C( I, J ) = ALPHA*TEMP - ELSE - C( I, J ) = ALPHA*TEMP + BETA*C( I, J ) - END IF - 270 CONTINUE - 280 CONTINUE - ELSE -* -* Form C := alpha*conjg( A' )*B' + beta*C -* - DO 310, J = 1, N - DO 300, I = 1, M - TEMP = ZERO - DO 290, L = 1, K - TEMP = TEMP + DCONJG( A( L, I ) )*B( J, L ) - 290 CONTINUE - IF( BETA.EQ.ZERO )THEN - C( I, J ) = ALPHA*TEMP - ELSE - C( I, J ) = ALPHA*TEMP + BETA*C( I, J ) - END IF - 300 CONTINUE - 310 CONTINUE - END IF - ELSE - IF( CONJB )THEN -* -* Form C := alpha*A'*conjg( B' ) + beta*C -* - DO 340, J = 1, N - DO 330, I = 1, M - TEMP = ZERO - DO 320, L = 1, K - TEMP = TEMP + A( L, I )*DCONJG( B( J, L ) ) - 320 CONTINUE - IF( BETA.EQ.ZERO )THEN - C( I, J ) = ALPHA*TEMP - ELSE - C( I, J ) = ALPHA*TEMP + BETA*C( I, J ) - END IF - 330 CONTINUE - 340 CONTINUE - ELSE -* -* Form C := alpha*A'*B' + beta*C -* - DO 370, J = 1, N - DO 360, I = 1, M - TEMP = ZERO - DO 350, L = 1, K - TEMP = TEMP + A( L, I )*B( J, L ) - 350 CONTINUE - IF( BETA.EQ.ZERO )THEN - C( I, J ) = ALPHA*TEMP - ELSE - C( I, J ) = ALPHA*TEMP + BETA*C( I, J ) - END IF - 360 CONTINUE - 370 CONTINUE - END IF - END IF -* - RETURN -* -* End of ZGEMM . -* - END diff --git a/src/lib/blas/zgemv.f b/src/lib/blas/zgemv.f deleted file mode 100644 index 014a5e02..00000000 --- a/src/lib/blas/zgemv.f +++ /dev/null @@ -1,281 +0,0 @@ - SUBROUTINE ZGEMV ( TRANS, M, N, ALPHA, A, LDA, X, INCX, - $ BETA, Y, INCY ) -* .. Scalar Arguments .. - COMPLEX*16 ALPHA, BETA - INTEGER INCX, INCY, LDA, M, N - CHARACTER*1 TRANS -* .. Array Arguments .. - COMPLEX*16 A( LDA, * ), X( * ), Y( * ) -* .. -* -* Purpose -* ======= -* -* ZGEMV performs one of the matrix-vector operations -* -* y := alpha*A*x + beta*y, or y := alpha*A'*x + beta*y, or -* -* y := alpha*conjg( A' )*x + beta*y, -* -* where alpha and beta are scalars, x and y are vectors and A is an -* m by n matrix. -* -* 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*16 . -* On entry, ALPHA specifies the scalar alpha. -* Unchanged on exit. -* -* A - COMPLEX*16 array of DIMENSION ( LDA, n ). -* Before entry, the leading m by n part of the array A must -* contain the matrix of coefficients. -* Unchanged on exit. -* -* LDA - INTEGER. -* On entry, LDA specifies the first dimension of A as declared -* in the calling (sub) program. LDA must be at least -* max( 1, m ). -* Unchanged on exit. -* -* X - COMPLEX*16 array of DIMENSION at least -* ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n' -* and at least -* ( 1 + ( m - 1 )*abs( INCX ) ) otherwise. -* Before entry, the incremented array X must contain the -* vector x. -* Unchanged on exit. -* -* INCX - INTEGER. -* On entry, INCX specifies the increment for the elements of -* X. INCX must not be zero. -* Unchanged on exit. -* -* BETA - COMPLEX*16 . -* On entry, BETA specifies the scalar beta. When BETA is -* supplied as zero then Y need not be set on input. -* Unchanged on exit. -* -* Y - COMPLEX*16 array of DIMENSION at least -* ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n' -* and at least -* ( 1 + ( n - 1 )*abs( INCY ) ) otherwise. -* Before entry with BETA non-zero, the incremented array Y -* must contain the vector y. On exit, Y is overwritten by the -* updated vector y. -* -* INCY - INTEGER. -* On entry, INCY specifies the increment for the elements of -* Y. INCY must not be zero. -* Unchanged on exit. -* -* -* Level 2 Blas routine. -* -* -- Written on 22-October-1986. -* Jack Dongarra, Argonne National Lab. -* Jeremy Du Croz, Nag Central Office. -* Sven Hammarling, Nag Central Office. -* Richard Hanson, Sandia National Labs. -* -* -* .. Parameters .. - COMPLEX*16 ONE - PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) ) - COMPLEX*16 ZERO - PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) ) -* .. Local Scalars .. - COMPLEX*16 TEMP - INTEGER I, INFO, IX, IY, J, JX, JY, KX, KY, LENX, LENY - LOGICAL NOCONJ -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. External Subroutines .. - EXTERNAL XERBLA -* .. Intrinsic Functions .. - INTRINSIC DCONJG, MAX -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - IF ( .NOT.LSAME( TRANS, 'N' ).AND. - $ .NOT.LSAME( TRANS, 'T' ).AND. - $ .NOT.LSAME( TRANS, 'C' ) )THEN - INFO = 1 - ELSE IF( M.LT.0 )THEN - INFO = 2 - ELSE IF( N.LT.0 )THEN - INFO = 3 - ELSE IF( LDA.LT.MAX( 1, M ) )THEN - INFO = 6 - ELSE IF( INCX.EQ.0 )THEN - INFO = 8 - ELSE IF( INCY.EQ.0 )THEN - INFO = 11 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'ZGEMV ', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR. - $ ( ( ALPHA.EQ.ZERO ).AND.( BETA.EQ.ONE ) ) ) - $ RETURN -* - NOCONJ = LSAME( TRANS, 'T' ) -* -* Set LENX and LENY, the lengths of the vectors x and y, and set -* up the start points in X and Y. -* - IF( LSAME( TRANS, 'N' ) )THEN - LENX = N - LENY = M - ELSE - LENX = M - LENY = N - END IF - IF( INCX.GT.0 )THEN - KX = 1 - ELSE - KX = 1 - ( LENX - 1 )*INCX - END IF - IF( INCY.GT.0 )THEN - KY = 1 - ELSE - KY = 1 - ( LENY - 1 )*INCY - END IF -* -* 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.NE.ONE )THEN - IF( INCY.EQ.1 )THEN - IF( BETA.EQ.ZERO )THEN - DO 10, I = 1, LENY - Y( I ) = ZERO - 10 CONTINUE - ELSE - DO 20, I = 1, LENY - Y( I ) = BETA*Y( I ) - 20 CONTINUE - END IF - ELSE - IY = KY - IF( BETA.EQ.ZERO )THEN - DO 30, I = 1, LENY - Y( IY ) = ZERO - IY = IY + INCY - 30 CONTINUE - ELSE - DO 40, I = 1, LENY - Y( IY ) = BETA*Y( IY ) - IY = IY + INCY - 40 CONTINUE - END IF - END IF - END IF - IF( ALPHA.EQ.ZERO ) - $ RETURN - IF( LSAME( TRANS, 'N' ) )THEN -* -* Form y := alpha*A*x + y. -* - JX = KX - IF( INCY.EQ.1 )THEN - DO 60, J = 1, N - IF( X( JX ).NE.ZERO )THEN - TEMP = ALPHA*X( JX ) - DO 50, I = 1, M - Y( I ) = Y( I ) + TEMP*A( I, J ) - 50 CONTINUE - END IF - JX = JX + INCX - 60 CONTINUE - ELSE - DO 80, J = 1, N - IF( X( JX ).NE.ZERO )THEN - TEMP = ALPHA*X( JX ) - IY = KY - DO 70, I = 1, M - Y( IY ) = Y( IY ) + TEMP*A( I, J ) - IY = IY + INCY - 70 CONTINUE - END IF - JX = JX + INCX - 80 CONTINUE - END IF - ELSE -* -* Form y := alpha*A'*x + y or y := alpha*conjg( A' )*x + y. -* - JY = KY - IF( INCX.EQ.1 )THEN - DO 110, J = 1, N - TEMP = ZERO - IF( NOCONJ )THEN - DO 90, I = 1, M - TEMP = TEMP + A( I, J )*X( I ) - 90 CONTINUE - ELSE - DO 100, I = 1, M - TEMP = TEMP + DCONJG( A( I, J ) )*X( I ) - 100 CONTINUE - END IF - Y( JY ) = Y( JY ) + ALPHA*TEMP - JY = JY + INCY - 110 CONTINUE - ELSE - DO 140, J = 1, N - TEMP = ZERO - IX = KX - IF( NOCONJ )THEN - DO 120, I = 1, M - TEMP = TEMP + A( I, J )*X( IX ) - IX = IX + INCX - 120 CONTINUE - ELSE - DO 130, I = 1, M - TEMP = TEMP + DCONJG( A( I, J ) )*X( IX ) - IX = IX + INCX - 130 CONTINUE - END IF - Y( JY ) = Y( JY ) + ALPHA*TEMP - JY = JY + INCY - 140 CONTINUE - END IF - END IF -* - RETURN -* -* End of ZGEMV . -* - END diff --git a/src/lib/blas/zgerc.f b/src/lib/blas/zgerc.f deleted file mode 100644 index 968c5b47..00000000 --- a/src/lib/blas/zgerc.f +++ /dev/null @@ -1,157 +0,0 @@ - SUBROUTINE ZGERC ( M, N, ALPHA, X, INCX, Y, INCY, A, LDA ) -* .. Scalar Arguments .. - COMPLEX*16 ALPHA - INTEGER INCX, INCY, LDA, M, N -* .. Array Arguments .. - COMPLEX*16 A( LDA, * ), X( * ), Y( * ) -* .. -* -* Purpose -* ======= -* -* ZGERC performs the rank 1 operation -* -* A := alpha*x*conjg( y' ) + A, -* -* where alpha is a scalar, x is an m element vector, y is an n element -* vector and A is an m by n matrix. -* -* 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*16 . -* On entry, ALPHA specifies the scalar alpha. -* Unchanged on exit. -* -* X - COMPLEX*16 array of dimension at least -* ( 1 + ( m - 1 )*abs( INCX ) ). -* Before entry, the incremented array X must contain the m -* element vector x. -* Unchanged on exit. -* -* INCX - INTEGER. -* On entry, INCX specifies the increment for the elements of -* X. INCX must not be zero. -* Unchanged on exit. -* -* Y - COMPLEX*16 array of dimension at least -* ( 1 + ( n - 1 )*abs( INCY ) ). -* Before entry, the incremented array Y must contain the n -* element vector y. -* Unchanged on exit. -* -* INCY - INTEGER. -* On entry, INCY specifies the increment for the elements of -* Y. INCY must not be zero. -* Unchanged on exit. -* -* A - COMPLEX*16 array of DIMENSION ( LDA, n ). -* Before entry, the leading m by n part of the array A must -* contain the matrix of coefficients. On exit, A is -* overwritten by the updated matrix. -* -* LDA - INTEGER. -* On entry, LDA specifies the first dimension of A as declared -* in the calling (sub) program. LDA must be at least -* max( 1, m ). -* Unchanged on exit. -* -* -* Level 2 Blas routine. -* -* -- Written on 22-October-1986. -* Jack Dongarra, Argonne National Lab. -* Jeremy Du Croz, Nag Central Office. -* Sven Hammarling, Nag Central Office. -* Richard Hanson, Sandia National Labs. -* -* -* .. Parameters .. - COMPLEX*16 ZERO - PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) ) -* .. Local Scalars .. - COMPLEX*16 TEMP - INTEGER I, INFO, IX, J, JY, KX -* .. External Subroutines .. - EXTERNAL XERBLA -* .. Intrinsic Functions .. - INTRINSIC DCONJG, MAX -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - IF ( M.LT.0 )THEN - INFO = 1 - ELSE IF( N.LT.0 )THEN - INFO = 2 - ELSE IF( INCX.EQ.0 )THEN - INFO = 5 - ELSE IF( INCY.EQ.0 )THEN - INFO = 7 - ELSE IF( LDA.LT.MAX( 1, M ) )THEN - INFO = 9 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'ZGERC ', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR.( ALPHA.EQ.ZERO ) ) - $ RETURN -* -* Start the operations. In this version the elements of A are -* accessed sequentially with one pass through A. -* - IF( INCY.GT.0 )THEN - JY = 1 - ELSE - JY = 1 - ( N - 1 )*INCY - END IF - IF( INCX.EQ.1 )THEN - DO 20, J = 1, N - IF( Y( JY ).NE.ZERO )THEN - TEMP = ALPHA*DCONJG( Y( JY ) ) - DO 10, I = 1, M - A( I, J ) = A( I, J ) + X( I )*TEMP - 10 CONTINUE - END IF - JY = JY + INCY - 20 CONTINUE - ELSE - IF( INCX.GT.0 )THEN - KX = 1 - ELSE - KX = 1 - ( M - 1 )*INCX - END IF - DO 40, J = 1, N - IF( Y( JY ).NE.ZERO )THEN - TEMP = ALPHA*DCONJG( Y( JY ) ) - IX = KX - DO 30, I = 1, M - A( I, J ) = A( I, J ) + X( IX )*TEMP - IX = IX + INCX - 30 CONTINUE - END IF - JY = JY + INCY - 40 CONTINUE - END IF -* - RETURN -* -* End of ZGERC . -* - END diff --git a/src/lib/blas/zgeru.f b/src/lib/blas/zgeru.f deleted file mode 100644 index 5283af64..00000000 --- a/src/lib/blas/zgeru.f +++ /dev/null @@ -1,157 +0,0 @@ - SUBROUTINE ZGERU ( M, N, ALPHA, X, INCX, Y, INCY, A, LDA ) -* .. Scalar Arguments .. - COMPLEX*16 ALPHA - INTEGER INCX, INCY, LDA, M, N -* .. Array Arguments .. - COMPLEX*16 A( LDA, * ), X( * ), Y( * ) -* .. -* -* Purpose -* ======= -* -* ZGERU performs the rank 1 operation -* -* A := alpha*x*y' + A, -* -* where alpha is a scalar, x is an m element vector, y is an n element -* vector and A is an m by n matrix. -* -* 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*16 . -* On entry, ALPHA specifies the scalar alpha. -* Unchanged on exit. -* -* X - COMPLEX*16 array of dimension at least -* ( 1 + ( m - 1 )*abs( INCX ) ). -* Before entry, the incremented array X must contain the m -* element vector x. -* Unchanged on exit. -* -* INCX - INTEGER. -* On entry, INCX specifies the increment for the elements of -* X. INCX must not be zero. -* Unchanged on exit. -* -* Y - COMPLEX*16 array of dimension at least -* ( 1 + ( n - 1 )*abs( INCY ) ). -* Before entry, the incremented array Y must contain the n -* element vector y. -* Unchanged on exit. -* -* INCY - INTEGER. -* On entry, INCY specifies the increment for the elements of -* Y. INCY must not be zero. -* Unchanged on exit. -* -* A - COMPLEX*16 array of DIMENSION ( LDA, n ). -* Before entry, the leading m by n part of the array A must -* contain the matrix of coefficients. On exit, A is -* overwritten by the updated matrix. -* -* LDA - INTEGER. -* On entry, LDA specifies the first dimension of A as declared -* in the calling (sub) program. LDA must be at least -* max( 1, m ). -* Unchanged on exit. -* -* -* Level 2 Blas routine. -* -* -- Written on 22-October-1986. -* Jack Dongarra, Argonne National Lab. -* Jeremy Du Croz, Nag Central Office. -* Sven Hammarling, Nag Central Office. -* Richard Hanson, Sandia National Labs. -* -* -* .. Parameters .. - COMPLEX*16 ZERO - PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) ) -* .. Local Scalars .. - COMPLEX*16 TEMP - INTEGER I, INFO, IX, J, JY, KX -* .. External Subroutines .. - EXTERNAL XERBLA -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - IF ( M.LT.0 )THEN - INFO = 1 - ELSE IF( N.LT.0 )THEN - INFO = 2 - ELSE IF( INCX.EQ.0 )THEN - INFO = 5 - ELSE IF( INCY.EQ.0 )THEN - INFO = 7 - ELSE IF( LDA.LT.MAX( 1, M ) )THEN - INFO = 9 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'ZGERU ', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR.( ALPHA.EQ.ZERO ) ) - $ RETURN -* -* Start the operations. In this version the elements of A are -* accessed sequentially with one pass through A. -* - IF( INCY.GT.0 )THEN - JY = 1 - ELSE - JY = 1 - ( N - 1 )*INCY - END IF - IF( INCX.EQ.1 )THEN - DO 20, J = 1, N - IF( Y( JY ).NE.ZERO )THEN - TEMP = ALPHA*Y( JY ) - DO 10, I = 1, M - A( I, J ) = A( I, J ) + X( I )*TEMP - 10 CONTINUE - END IF - JY = JY + INCY - 20 CONTINUE - ELSE - IF( INCX.GT.0 )THEN - KX = 1 - ELSE - KX = 1 - ( M - 1 )*INCX - END IF - DO 40, J = 1, N - IF( Y( JY ).NE.ZERO )THEN - TEMP = ALPHA*Y( JY ) - IX = KX - DO 30, I = 1, M - A( I, J ) = A( I, J ) + X( IX )*TEMP - IX = IX + INCX - 30 CONTINUE - END IF - JY = JY + INCY - 40 CONTINUE - END IF -* - RETURN -* -* End of ZGERU . -* - END diff --git a/src/lib/blas/zhbmv.f b/src/lib/blas/zhbmv.f deleted file mode 100644 index 1c044936..00000000 --- a/src/lib/blas/zhbmv.f +++ /dev/null @@ -1,309 +0,0 @@ - SUBROUTINE ZHBMV ( UPLO, N, K, ALPHA, A, LDA, X, INCX, - $ BETA, Y, INCY ) -* .. Scalar Arguments .. - COMPLEX*16 ALPHA, BETA - INTEGER INCX, INCY, K, LDA, N - CHARACTER*1 UPLO -* .. Array Arguments .. - COMPLEX*16 A( LDA, * ), X( * ), Y( * ) -* .. -* -* Purpose -* ======= -* -* ZHBMV performs the matrix-vector operation -* -* y := alpha*A*x + beta*y, -* -* where alpha and beta are scalars, x and y are n element vectors and -* A is an n by n hermitian band matrix, with k super-diagonals. -* -* 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*16 . -* On entry, ALPHA specifies the scalar alpha. -* Unchanged on exit. -* -* A - COMPLEX*16 array of DIMENSION ( LDA, n ). -* Before entry with UPLO = 'U' or 'u', the leading ( k + 1 ) -* by n part of the array A must contain the upper triangular -* band part of the hermitian matrix, supplied column by -* column, with the leading diagonal of the matrix in row -* ( k + 1 ) of the array, the first super-diagonal starting at -* position 2 in row k, and so on. The top left k by k triangle -* of the array A is not referenced. -* The following program segment will transfer the upper -* triangular part of a hermitian band matrix from conventional -* full matrix storage to band storage: -* -* DO 20, J = 1, N -* M = K + 1 - J -* DO 10, I = MAX( 1, J - K ), J -* A( M + I, J ) = matrix( I, J ) -* 10 CONTINUE -* 20 CONTINUE -* -* Before entry with UPLO = 'L' or 'l', the leading ( k + 1 ) -* by n part of the array A must contain the lower triangular -* band part of the hermitian matrix, supplied column by -* column, with the leading diagonal of the matrix in row 1 of -* the array, the first sub-diagonal starting at position 1 in -* row 2, and so on. The bottom right k by k triangle of the -* array A is not referenced. -* The following program segment will transfer the lower -* triangular part of a hermitian band matrix from conventional -* full matrix storage to band storage: -* -* DO 20, J = 1, N -* M = 1 - J -* DO 10, I = J, MIN( N, J + K ) -* A( M + I, J ) = matrix( I, J ) -* 10 CONTINUE -* 20 CONTINUE -* -* Note that the imaginary parts of the diagonal elements need -* not be set and are assumed to be zero. -* Unchanged on exit. -* -* LDA - INTEGER. -* On entry, LDA specifies the first dimension of A as declared -* in the calling (sub) program. LDA must be at least -* ( k + 1 ). -* Unchanged on exit. -* -* X - COMPLEX*16 array of DIMENSION at least -* ( 1 + ( n - 1 )*abs( INCX ) ). -* Before entry, the incremented array X must contain the -* vector x. -* Unchanged on exit. -* -* INCX - INTEGER. -* On entry, INCX specifies the increment for the elements of -* X. INCX must not be zero. -* Unchanged on exit. -* -* BETA - COMPLEX*16 . -* On entry, BETA specifies the scalar beta. -* Unchanged on exit. -* -* Y - COMPLEX*16 array of DIMENSION at least -* ( 1 + ( n - 1 )*abs( INCY ) ). -* Before entry, the incremented array Y must contain the -* vector y. On exit, Y is overwritten by the updated vector y. -* -* INCY - INTEGER. -* On entry, INCY specifies the increment for the elements of -* Y. INCY must not be zero. -* Unchanged on exit. -* -* -* Level 2 Blas routine. -* -* -- Written on 22-October-1986. -* Jack Dongarra, Argonne National Lab. -* Jeremy Du Croz, Nag Central Office. -* Sven Hammarling, Nag Central Office. -* Richard Hanson, Sandia National Labs. -* -* -* .. Parameters .. - COMPLEX*16 ONE - PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) ) - COMPLEX*16 ZERO - PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) ) -* .. Local Scalars .. - COMPLEX*16 TEMP1, TEMP2 - INTEGER I, INFO, IX, IY, J, JX, JY, KPLUS1, KX, KY, L -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. External Subroutines .. - EXTERNAL XERBLA -* .. Intrinsic Functions .. - INTRINSIC DCONJG, MAX, MIN, DBLE -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - IF ( .NOT.LSAME( UPLO, 'U' ).AND. - $ .NOT.LSAME( UPLO, 'L' ) )THEN - INFO = 1 - ELSE IF( N.LT.0 )THEN - INFO = 2 - ELSE IF( K.LT.0 )THEN - INFO = 3 - ELSE IF( LDA.LT.( K + 1 ) )THEN - INFO = 6 - ELSE IF( INCX.EQ.0 )THEN - INFO = 8 - ELSE IF( INCY.EQ.0 )THEN - INFO = 11 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'ZHBMV ', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( ( N.EQ.0 ).OR.( ( ALPHA.EQ.ZERO ).AND.( BETA.EQ.ONE ) ) ) - $ RETURN -* -* Set up the start points in X and Y. -* - IF( INCX.GT.0 )THEN - KX = 1 - ELSE - KX = 1 - ( N - 1 )*INCX - END IF - IF( INCY.GT.0 )THEN - KY = 1 - ELSE - KY = 1 - ( N - 1 )*INCY - END IF -* -* 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.NE.ONE )THEN - IF( INCY.EQ.1 )THEN - IF( BETA.EQ.ZERO )THEN - DO 10, I = 1, N - Y( I ) = ZERO - 10 CONTINUE - ELSE - DO 20, I = 1, N - Y( I ) = BETA*Y( I ) - 20 CONTINUE - END IF - ELSE - IY = KY - IF( BETA.EQ.ZERO )THEN - DO 30, I = 1, N - Y( IY ) = ZERO - IY = IY + INCY - 30 CONTINUE - ELSE - DO 40, I = 1, N - Y( IY ) = BETA*Y( IY ) - IY = IY + INCY - 40 CONTINUE - END IF - END IF - END IF - IF( ALPHA.EQ.ZERO ) - $ RETURN - IF( LSAME( UPLO, 'U' ) )THEN -* -* Form y when upper triangle of A is stored. -* - KPLUS1 = K + 1 - IF( ( INCX.EQ.1 ).AND.( INCY.EQ.1 ) )THEN - DO 60, J = 1, N - TEMP1 = ALPHA*X( J ) - TEMP2 = ZERO - L = KPLUS1 - J - DO 50, I = MAX( 1, J - K ), J - 1 - Y( I ) = Y( I ) + TEMP1*A( L + I, J ) - TEMP2 = TEMP2 + DCONJG( A( L + I, J ) )*X( I ) - 50 CONTINUE - Y( J ) = Y( J ) + TEMP1*DBLE( A( KPLUS1, J ) ) - $ + ALPHA*TEMP2 - 60 CONTINUE - ELSE - JX = KX - JY = KY - DO 80, J = 1, N - TEMP1 = ALPHA*X( JX ) - TEMP2 = ZERO - IX = KX - IY = KY - L = KPLUS1 - J - DO 70, I = MAX( 1, J - K ), J - 1 - Y( IY ) = Y( IY ) + TEMP1*A( L + I, J ) - TEMP2 = TEMP2 + DCONJG( A( L + I, J ) )*X( IX ) - IX = IX + INCX - IY = IY + INCY - 70 CONTINUE - Y( JY ) = Y( JY ) + TEMP1*DBLE( A( KPLUS1, J ) ) - $ + ALPHA*TEMP2 - JX = JX + INCX - JY = JY + INCY - IF( J.GT.K )THEN - KX = KX + INCX - KY = KY + INCY - END IF - 80 CONTINUE - END IF - ELSE -* -* Form y when lower triangle of A is stored. -* - IF( ( INCX.EQ.1 ).AND.( INCY.EQ.1 ) )THEN - DO 100, J = 1, N - TEMP1 = ALPHA*X( J ) - TEMP2 = ZERO - Y( J ) = Y( J ) + TEMP1*DBLE( A( 1, J ) ) - L = 1 - J - DO 90, I = J + 1, MIN( N, J + K ) - Y( I ) = Y( I ) + TEMP1*A( L + I, J ) - TEMP2 = TEMP2 + DCONJG( A( L + I, J ) )*X( I ) - 90 CONTINUE - Y( J ) = Y( J ) + ALPHA*TEMP2 - 100 CONTINUE - ELSE - JX = KX - JY = KY - DO 120, J = 1, N - TEMP1 = ALPHA*X( JX ) - TEMP2 = ZERO - Y( JY ) = Y( JY ) + TEMP1*DBLE( A( 1, J ) ) - L = 1 - J - IX = JX - IY = JY - DO 110, I = J + 1, MIN( N, J + K ) - IX = IX + INCX - IY = IY + INCY - Y( IY ) = Y( IY ) + TEMP1*A( L + I, J ) - TEMP2 = TEMP2 + DCONJG( A( L + I, J ) )*X( IX ) - 110 CONTINUE - Y( JY ) = Y( JY ) + ALPHA*TEMP2 - JX = JX + INCX - JY = JY + INCY - 120 CONTINUE - END IF - END IF -* - RETURN -* -* End of ZHBMV . -* - END diff --git a/src/lib/blas/zhemm.f b/src/lib/blas/zhemm.f deleted file mode 100644 index d3912c08..00000000 --- a/src/lib/blas/zhemm.f +++ /dev/null @@ -1,304 +0,0 @@ - SUBROUTINE ZHEMM ( SIDE, UPLO, M, N, ALPHA, A, LDA, B, LDB, - $ BETA, C, LDC ) -* .. Scalar Arguments .. - CHARACTER*1 SIDE, UPLO - INTEGER M, N, LDA, LDB, LDC - COMPLEX*16 ALPHA, BETA -* .. Array Arguments .. - COMPLEX*16 A( LDA, * ), B( LDB, * ), C( LDC, * ) -* .. -* -* Purpose -* ======= -* -* ZHEMM performs one of the matrix-matrix operations -* -* C := alpha*A*B + beta*C, -* -* or -* -* C := alpha*B*A + beta*C, -* -* where alpha and beta are scalars, A is an hermitian matrix and B and -* C are m by n matrices. -* -* 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*16 . -* On entry, ALPHA specifies the scalar alpha. -* Unchanged on exit. -* -* A - COMPLEX*16 array of DIMENSION ( LDA, ka ), where ka is -* m when SIDE = 'L' or 'l' and is n otherwise. -* Before entry with SIDE = 'L' or 'l', the m by m part of -* the array A must contain the hermitian matrix, such that -* when UPLO = 'U' or 'u', the leading m by m upper triangular -* part of the array A must contain the upper triangular part -* of the hermitian matrix and the strictly lower triangular -* part of A is not referenced, and when UPLO = 'L' or 'l', -* the leading m by m lower triangular part of the array A -* must contain the lower triangular part of the hermitian -* matrix and the strictly upper triangular part of A is not -* referenced. -* Before entry with SIDE = 'R' or 'r', the n by n part of -* the array A must contain the hermitian matrix, such that -* when UPLO = 'U' or 'u', the leading n by n upper triangular -* part of the array A must contain the upper triangular part -* of the hermitian matrix and the strictly lower triangular -* part of A is not referenced, and when UPLO = 'L' or 'l', -* the leading n by n lower triangular part of the array A -* must contain the lower triangular part of the hermitian -* matrix and the strictly upper triangular part of A is not -* referenced. -* Note that the imaginary parts of the diagonal elements need -* not be set, they are assumed to be zero. -* Unchanged on exit. -* -* LDA - INTEGER. -* On entry, LDA specifies the first dimension of A as declared -* in the calling (sub) program. When SIDE = 'L' or 'l' then -* LDA must be at least max( 1, m ), otherwise LDA must be at -* least max( 1, n ). -* Unchanged on exit. -* -* B - COMPLEX*16 array of DIMENSION ( LDB, n ). -* Before entry, the leading m by n part of the array B must -* contain the matrix B. -* Unchanged on exit. -* -* LDB - INTEGER. -* On entry, LDB specifies the first dimension of B as declared -* in the calling (sub) program. LDB must be at least -* max( 1, m ). -* Unchanged on exit. -* -* BETA - COMPLEX*16 . -* On entry, BETA specifies the scalar beta. When BETA is -* supplied as zero then C need not be set on input. -* Unchanged on exit. -* -* C - COMPLEX*16 array of DIMENSION ( LDC, n ). -* Before entry, the leading m by n part of the array C must -* contain the matrix C, except when beta is zero, in which -* case C need not be set on entry. -* On exit, the array C is overwritten by the m by n updated -* matrix. -* -* LDC - INTEGER. -* On entry, LDC specifies the first dimension of C as declared -* in the calling (sub) program. LDC must be at least -* max( 1, m ). -* Unchanged on exit. -* -* -* Level 3 Blas routine. -* -* -- Written on 8-February-1989. -* Jack Dongarra, Argonne National Laboratory. -* Iain Duff, AERE Harwell. -* Jeremy Du Croz, Numerical Algorithms Group Ltd. -* Sven Hammarling, Numerical Algorithms Group Ltd. -* -* -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. External Subroutines .. - EXTERNAL XERBLA -* .. Intrinsic Functions .. - INTRINSIC DCONJG, MAX, DBLE -* .. Local Scalars .. - LOGICAL UPPER - INTEGER I, INFO, J, K, NROWA - COMPLEX*16 TEMP1, TEMP2 -* .. Parameters .. - COMPLEX*16 ONE - PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) ) - COMPLEX*16 ZERO - PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) ) -* .. -* .. Executable Statements .. -* -* Set NROWA as the number of rows of A. -* - IF( LSAME( SIDE, 'L' ) )THEN - NROWA = M - ELSE - NROWA = N - END IF - UPPER = LSAME( UPLO, 'U' ) -* -* Test the input parameters. -* - INFO = 0 - IF( ( .NOT.LSAME( SIDE, 'L' ) ).AND. - $ ( .NOT.LSAME( SIDE, 'R' ) ) )THEN - INFO = 1 - ELSE IF( ( .NOT.UPPER ).AND. - $ ( .NOT.LSAME( UPLO, 'L' ) ) )THEN - INFO = 2 - ELSE IF( M .LT.0 )THEN - INFO = 3 - ELSE IF( N .LT.0 )THEN - INFO = 4 - ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN - INFO = 7 - ELSE IF( LDB.LT.MAX( 1, M ) )THEN - INFO = 9 - ELSE IF( LDC.LT.MAX( 1, M ) )THEN - INFO = 12 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'ZHEMM ', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR. - $ ( ( ALPHA.EQ.ZERO ).AND.( BETA.EQ.ONE ) ) ) - $ RETURN -* -* And when alpha.eq.zero. -* - IF( ALPHA.EQ.ZERO )THEN - IF( BETA.EQ.ZERO )THEN - DO 20, J = 1, N - DO 10, I = 1, M - C( I, J ) = ZERO - 10 CONTINUE - 20 CONTINUE - ELSE - DO 40, J = 1, N - DO 30, I = 1, M - C( I, J ) = BETA*C( I, J ) - 30 CONTINUE - 40 CONTINUE - END IF - RETURN - END IF -* -* Start the operations. -* - IF( LSAME( SIDE, 'L' ) )THEN -* -* Form C := alpha*A*B + beta*C. -* - IF( UPPER )THEN - DO 70, J = 1, N - DO 60, I = 1, M - TEMP1 = ALPHA*B( I, J ) - TEMP2 = ZERO - DO 50, K = 1, I - 1 - C( K, J ) = C( K, J ) + TEMP1*A( K, I ) - TEMP2 = TEMP2 + - $ B( K, J )*DCONJG( A( K, I ) ) - 50 CONTINUE - IF( BETA.EQ.ZERO )THEN - C( I, J ) = TEMP1*DBLE( A( I, I ) ) + - $ ALPHA*TEMP2 - ELSE - C( I, J ) = BETA *C( I, J ) + - $ TEMP1*DBLE( A( I, I ) ) + - $ ALPHA*TEMP2 - END IF - 60 CONTINUE - 70 CONTINUE - ELSE - DO 100, J = 1, N - DO 90, I = M, 1, -1 - TEMP1 = ALPHA*B( I, J ) - TEMP2 = ZERO - DO 80, K = I + 1, M - C( K, J ) = C( K, J ) + TEMP1*A( K, I ) - TEMP2 = TEMP2 + - $ B( K, J )*DCONJG( A( K, I ) ) - 80 CONTINUE - IF( BETA.EQ.ZERO )THEN - C( I, J ) = TEMP1*DBLE( A( I, I ) ) + - $ ALPHA*TEMP2 - ELSE - C( I, J ) = BETA *C( I, J ) + - $ TEMP1*DBLE( A( I, I ) ) + - $ ALPHA*TEMP2 - END IF - 90 CONTINUE - 100 CONTINUE - END IF - ELSE -* -* Form C := alpha*B*A + beta*C. -* - DO 170, J = 1, N - TEMP1 = ALPHA*DBLE( A( J, J ) ) - IF( BETA.EQ.ZERO )THEN - DO 110, I = 1, M - C( I, J ) = TEMP1*B( I, J ) - 110 CONTINUE - ELSE - DO 120, I = 1, M - C( I, J ) = BETA*C( I, J ) + TEMP1*B( I, J ) - 120 CONTINUE - END IF - DO 140, K = 1, J - 1 - IF( UPPER )THEN - TEMP1 = ALPHA*A( K, J ) - ELSE - TEMP1 = ALPHA*DCONJG( A( J, K ) ) - END IF - DO 130, I = 1, M - C( I, J ) = C( I, J ) + TEMP1*B( I, K ) - 130 CONTINUE - 140 CONTINUE - DO 160, K = J + 1, N - IF( UPPER )THEN - TEMP1 = ALPHA*DCONJG( A( J, K ) ) - ELSE - TEMP1 = ALPHA*A( K, J ) - END IF - DO 150, I = 1, M - C( I, J ) = C( I, J ) + TEMP1*B( I, K ) - 150 CONTINUE - 160 CONTINUE - 170 CONTINUE - END IF -* - RETURN -* -* End of ZHEMM . -* - END diff --git a/src/lib/blas/zhemv.f b/src/lib/blas/zhemv.f deleted file mode 100644 index 54aa7b90..00000000 --- a/src/lib/blas/zhemv.f +++ /dev/null @@ -1,266 +0,0 @@ - SUBROUTINE ZHEMV ( UPLO, N, ALPHA, A, LDA, X, INCX, - $ BETA, Y, INCY ) -* .. Scalar Arguments .. - COMPLEX*16 ALPHA, BETA - INTEGER INCX, INCY, LDA, N - CHARACTER*1 UPLO -* .. Array Arguments .. - COMPLEX*16 A( LDA, * ), X( * ), Y( * ) -* .. -* -* Purpose -* ======= -* -* ZHEMV performs the matrix-vector operation -* -* y := alpha*A*x + beta*y, -* -* where alpha and beta are scalars, x and y are n element vectors and -* A is an n by n hermitian matrix. -* -* 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*16 . -* On entry, ALPHA specifies the scalar alpha. -* Unchanged on exit. -* -* A - COMPLEX*16 array of DIMENSION ( LDA, n ). -* Before entry with UPLO = 'U' or 'u', the leading n by n -* upper triangular part of the array A must contain the upper -* triangular part of the hermitian matrix and the strictly -* lower triangular part of A is not referenced. -* Before entry with UPLO = 'L' or 'l', the leading n by n -* lower triangular part of the array A must contain the lower -* triangular part of the hermitian matrix and the strictly -* upper triangular part of A is not referenced. -* Note that the imaginary parts of the diagonal elements need -* not be set and are assumed to be zero. -* Unchanged on exit. -* -* LDA - INTEGER. -* On entry, LDA specifies the first dimension of A as declared -* in the calling (sub) program. LDA must be at least -* max( 1, n ). -* Unchanged on exit. -* -* X - COMPLEX*16 array of dimension at least -* ( 1 + ( n - 1 )*abs( INCX ) ). -* Before entry, the incremented array X must contain the n -* element vector x. -* Unchanged on exit. -* -* INCX - INTEGER. -* On entry, INCX specifies the increment for the elements of -* X. INCX must not be zero. -* Unchanged on exit. -* -* BETA - COMPLEX*16 . -* On entry, BETA specifies the scalar beta. When BETA is -* supplied as zero then Y need not be set on input. -* Unchanged on exit. -* -* Y - COMPLEX*16 array of dimension at least -* ( 1 + ( n - 1 )*abs( INCY ) ). -* Before entry, the incremented array Y must contain the n -* element vector y. On exit, Y is overwritten by the updated -* vector y. -* -* INCY - INTEGER. -* On entry, INCY specifies the increment for the elements of -* Y. INCY must not be zero. -* Unchanged on exit. -* -* -* Level 2 Blas routine. -* -* -- Written on 22-October-1986. -* Jack Dongarra, Argonne National Lab. -* Jeremy Du Croz, Nag Central Office. -* Sven Hammarling, Nag Central Office. -* Richard Hanson, Sandia National Labs. -* -* -* .. Parameters .. - COMPLEX*16 ONE - PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) ) - COMPLEX*16 ZERO - PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) ) -* .. Local Scalars .. - COMPLEX*16 TEMP1, TEMP2 - INTEGER I, INFO, IX, IY, J, JX, JY, KX, KY -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. External Subroutines .. - EXTERNAL XERBLA -* .. Intrinsic Functions .. - INTRINSIC DCONJG, MAX, DBLE -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - IF ( .NOT.LSAME( UPLO, 'U' ).AND. - $ .NOT.LSAME( UPLO, 'L' ) )THEN - INFO = 1 - ELSE IF( N.LT.0 )THEN - INFO = 2 - ELSE IF( LDA.LT.MAX( 1, N ) )THEN - INFO = 5 - ELSE IF( INCX.EQ.0 )THEN - INFO = 7 - ELSE IF( INCY.EQ.0 )THEN - INFO = 10 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'ZHEMV ', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( ( N.EQ.0 ).OR.( ( ALPHA.EQ.ZERO ).AND.( BETA.EQ.ONE ) ) ) - $ RETURN -* -* Set up the start points in X and Y. -* - IF( INCX.GT.0 )THEN - KX = 1 - ELSE - KX = 1 - ( N - 1 )*INCX - END IF - IF( INCY.GT.0 )THEN - KY = 1 - ELSE - KY = 1 - ( N - 1 )*INCY - END IF -* -* 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.NE.ONE )THEN - IF( INCY.EQ.1 )THEN - IF( BETA.EQ.ZERO )THEN - DO 10, I = 1, N - Y( I ) = ZERO - 10 CONTINUE - ELSE - DO 20, I = 1, N - Y( I ) = BETA*Y( I ) - 20 CONTINUE - END IF - ELSE - IY = KY - IF( BETA.EQ.ZERO )THEN - DO 30, I = 1, N - Y( IY ) = ZERO - IY = IY + INCY - 30 CONTINUE - ELSE - DO 40, I = 1, N - Y( IY ) = BETA*Y( IY ) - IY = IY + INCY - 40 CONTINUE - END IF - END IF - END IF - IF( ALPHA.EQ.ZERO ) - $ RETURN - IF( LSAME( UPLO, 'U' ) )THEN -* -* Form y when A is stored in upper triangle. -* - IF( ( INCX.EQ.1 ).AND.( INCY.EQ.1 ) )THEN - DO 60, J = 1, N - TEMP1 = ALPHA*X( J ) - TEMP2 = ZERO - DO 50, I = 1, J - 1 - Y( I ) = Y( I ) + TEMP1*A( I, J ) - TEMP2 = TEMP2 + DCONJG( A( I, J ) )*X( I ) - 50 CONTINUE - Y( J ) = Y( J ) + TEMP1*DBLE( A( J, J ) ) + ALPHA*TEMP2 - 60 CONTINUE - ELSE - JX = KX - JY = KY - DO 80, J = 1, N - TEMP1 = ALPHA*X( JX ) - TEMP2 = ZERO - IX = KX - IY = KY - DO 70, I = 1, J - 1 - Y( IY ) = Y( IY ) + TEMP1*A( I, J ) - TEMP2 = TEMP2 + DCONJG( A( I, J ) )*X( IX ) - IX = IX + INCX - IY = IY + INCY - 70 CONTINUE - Y( JY ) = Y( JY ) + TEMP1*DBLE( A( J, J ) ) + ALPHA*TEMP2 - JX = JX + INCX - JY = JY + INCY - 80 CONTINUE - END IF - ELSE -* -* Form y when A is stored in lower triangle. -* - IF( ( INCX.EQ.1 ).AND.( INCY.EQ.1 ) )THEN - DO 100, J = 1, N - TEMP1 = ALPHA*X( J ) - TEMP2 = ZERO - Y( J ) = Y( J ) + TEMP1*DBLE( A( J, J ) ) - DO 90, I = J + 1, N - Y( I ) = Y( I ) + TEMP1*A( I, J ) - TEMP2 = TEMP2 + DCONJG( A( I, J ) )*X( I ) - 90 CONTINUE - Y( J ) = Y( J ) + ALPHA*TEMP2 - 100 CONTINUE - ELSE - JX = KX - JY = KY - DO 120, J = 1, N - TEMP1 = ALPHA*X( JX ) - TEMP2 = ZERO - Y( JY ) = Y( JY ) + TEMP1*DBLE( A( J, J ) ) - IX = JX - IY = JY - DO 110, I = J + 1, N - IX = IX + INCX - IY = IY + INCY - Y( IY ) = Y( IY ) + TEMP1*A( I, J ) - TEMP2 = TEMP2 + DCONJG( A( I, J ) )*X( IX ) - 110 CONTINUE - Y( JY ) = Y( JY ) + ALPHA*TEMP2 - JX = JX + INCX - JY = JY + INCY - 120 CONTINUE - END IF - END IF -* - RETURN -* -* End of ZHEMV . -* - END diff --git a/src/lib/blas/zher.f b/src/lib/blas/zher.f deleted file mode 100644 index fcf40a5e..00000000 --- a/src/lib/blas/zher.f +++ /dev/null @@ -1,212 +0,0 @@ - SUBROUTINE ZHER ( UPLO, N, ALPHA, X, INCX, A, LDA ) -* .. Scalar Arguments .. - DOUBLE PRECISION ALPHA - INTEGER INCX, LDA, N - CHARACTER*1 UPLO -* .. Array Arguments .. - COMPLEX*16 A( LDA, * ), X( * ) -* .. -* -* Purpose -* ======= -* -* ZHER performs the hermitian rank 1 operation -* -* A := alpha*x*conjg( x' ) + A, -* -* where alpha is a real scalar, x is an n element vector and A is an -* n by n hermitian matrix. -* -* 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 - COMPLEX*16 array of dimension at least -* ( 1 + ( n - 1 )*abs( INCX ) ). -* Before entry, the incremented array X must contain the n -* element vector x. -* Unchanged on exit. -* -* INCX - INTEGER. -* On entry, INCX specifies the increment for the elements of -* X. INCX must not be zero. -* Unchanged on exit. -* -* A - COMPLEX*16 array of DIMENSION ( LDA, n ). -* Before entry with UPLO = 'U' or 'u', the leading n by n -* upper triangular part of the array A must contain the upper -* triangular part of the hermitian matrix and the strictly -* lower triangular part of A is not referenced. On exit, the -* upper triangular part of the array A is overwritten by the -* upper triangular part of the updated matrix. -* Before entry with UPLO = 'L' or 'l', the leading n by n -* lower triangular part of the array A must contain the lower -* triangular part of the hermitian matrix and the strictly -* upper triangular part of A is not referenced. On exit, the -* lower triangular part of the array A is overwritten by the -* lower triangular part of the updated matrix. -* Note that the imaginary parts of the diagonal elements need -* not be set, they are assumed to be zero, and on exit they -* are set to zero. -* -* LDA - INTEGER. -* On entry, LDA specifies the first dimension of A as declared -* in the calling (sub) program. LDA must be at least -* max( 1, n ). -* Unchanged on exit. -* -* -* Level 2 Blas routine. -* -* -- Written on 22-October-1986. -* Jack Dongarra, Argonne National Lab. -* Jeremy Du Croz, Nag Central Office. -* Sven Hammarling, Nag Central Office. -* Richard Hanson, Sandia National Labs. -* -* -* .. Parameters .. - COMPLEX*16 ZERO - PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) ) -* .. Local Scalars .. - COMPLEX*16 TEMP - INTEGER I, INFO, IX, J, JX, KX -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. External Subroutines .. - EXTERNAL XERBLA -* .. Intrinsic Functions .. - INTRINSIC DCONJG, MAX, DBLE -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - IF ( .NOT.LSAME( UPLO, 'U' ).AND. - $ .NOT.LSAME( UPLO, 'L' ) )THEN - INFO = 1 - ELSE IF( N.LT.0 )THEN - INFO = 2 - ELSE IF( INCX.EQ.0 )THEN - INFO = 5 - ELSE IF( LDA.LT.MAX( 1, N ) )THEN - INFO = 7 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'ZHER ', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( ( N.EQ.0 ).OR.( ALPHA.EQ.DBLE( ZERO ) ) ) - $ RETURN -* -* Set the start point in X if the increment is not unity. -* - IF( INCX.LE.0 )THEN - KX = 1 - ( N - 1 )*INCX - ELSE IF( INCX.NE.1 )THEN - KX = 1 - END IF -* -* 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' ) )THEN -* -* Form A when A is stored in upper triangle. -* - IF( INCX.EQ.1 )THEN - DO 20, J = 1, N - IF( X( J ).NE.ZERO )THEN - TEMP = ALPHA*DCONJG( X( J ) ) - DO 10, I = 1, J - 1 - A( I, J ) = A( I, J ) + X( I )*TEMP - 10 CONTINUE - A( J, J ) = DBLE( A( J, J ) ) + DBLE( X( J )*TEMP ) - ELSE - A( J, J ) = DBLE( A( J, J ) ) - END IF - 20 CONTINUE - ELSE - JX = KX - DO 40, J = 1, N - IF( X( JX ).NE.ZERO )THEN - TEMP = ALPHA*DCONJG( X( JX ) ) - IX = KX - DO 30, I = 1, J - 1 - A( I, J ) = A( I, J ) + X( IX )*TEMP - IX = IX + INCX - 30 CONTINUE - A( J, J ) = DBLE( A( J, J ) ) + DBLE( X( JX )*TEMP ) - ELSE - A( J, J ) = DBLE( A( J, J ) ) - END IF - JX = JX + INCX - 40 CONTINUE - END IF - ELSE -* -* Form A when A is stored in lower triangle. -* - IF( INCX.EQ.1 )THEN - DO 60, J = 1, N - IF( X( J ).NE.ZERO )THEN - TEMP = ALPHA*DCONJG( X( J ) ) - A( J, J ) = DBLE( A( J, J ) ) + DBLE( TEMP*X( J ) ) - DO 50, I = J + 1, N - A( I, J ) = A( I, J ) + X( I )*TEMP - 50 CONTINUE - ELSE - A( J, J ) = DBLE( A( J, J ) ) - END IF - 60 CONTINUE - ELSE - JX = KX - DO 80, J = 1, N - IF( X( JX ).NE.ZERO )THEN - TEMP = ALPHA*DCONJG( X( JX ) ) - A( J, J ) = DBLE( A( J, J ) ) + DBLE( TEMP*X( JX ) ) - IX = JX - DO 70, I = J + 1, N - IX = IX + INCX - A( I, J ) = A( I, J ) + X( IX )*TEMP - 70 CONTINUE - ELSE - A( J, J ) = DBLE( A( J, J ) ) - END IF - JX = JX + INCX - 80 CONTINUE - END IF - END IF -* - RETURN -* -* End of ZHER . -* - END diff --git a/src/lib/blas/zher2.f b/src/lib/blas/zher2.f deleted file mode 100644 index 06acdff7..00000000 --- a/src/lib/blas/zher2.f +++ /dev/null @@ -1,249 +0,0 @@ - SUBROUTINE ZHER2 ( UPLO, N, ALPHA, X, INCX, Y, INCY, A, LDA ) -* .. Scalar Arguments .. - COMPLEX*16 ALPHA - INTEGER INCX, INCY, LDA, N - CHARACTER*1 UPLO -* .. Array Arguments .. - COMPLEX*16 A( LDA, * ), X( * ), Y( * ) -* .. -* -* Purpose -* ======= -* -* ZHER2 performs the hermitian rank 2 operation -* -* A := alpha*x*conjg( y' ) + conjg( alpha )*y*conjg( x' ) + A, -* -* where alpha is a scalar, x and y are n element vectors and A is an n -* by n hermitian matrix. -* -* 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*16 . -* On entry, ALPHA specifies the scalar alpha. -* Unchanged on exit. -* -* X - COMPLEX*16 array of dimension at least -* ( 1 + ( n - 1 )*abs( INCX ) ). -* Before entry, the incremented array X must contain the n -* element vector x. -* Unchanged on exit. -* -* INCX - INTEGER. -* On entry, INCX specifies the increment for the elements of -* X. INCX must not be zero. -* Unchanged on exit. -* -* Y - COMPLEX*16 array of dimension at least -* ( 1 + ( n - 1 )*abs( INCY ) ). -* Before entry, the incremented array Y must contain the n -* element vector y. -* Unchanged on exit. -* -* INCY - INTEGER. -* On entry, INCY specifies the increment for the elements of -* Y. INCY must not be zero. -* Unchanged on exit. -* -* A - COMPLEX*16 array of DIMENSION ( LDA, n ). -* Before entry with UPLO = 'U' or 'u', the leading n by n -* upper triangular part of the array A must contain the upper -* triangular part of the hermitian matrix and the strictly -* lower triangular part of A is not referenced. On exit, the -* upper triangular part of the array A is overwritten by the -* upper triangular part of the updated matrix. -* Before entry with UPLO = 'L' or 'l', the leading n by n -* lower triangular part of the array A must contain the lower -* triangular part of the hermitian matrix and the strictly -* upper triangular part of A is not referenced. On exit, the -* lower triangular part of the array A is overwritten by the -* lower triangular part of the updated matrix. -* Note that the imaginary parts of the diagonal elements need -* not be set, they are assumed to be zero, and on exit they -* are set to zero. -* -* LDA - INTEGER. -* On entry, LDA specifies the first dimension of A as declared -* in the calling (sub) program. LDA must be at least -* max( 1, n ). -* Unchanged on exit. -* -* -* Level 2 Blas routine. -* -* -- Written on 22-October-1986. -* Jack Dongarra, Argonne National Lab. -* Jeremy Du Croz, Nag Central Office. -* Sven Hammarling, Nag Central Office. -* Richard Hanson, Sandia National Labs. -* -* -* .. Parameters .. - COMPLEX*16 ZERO - PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) ) -* .. Local Scalars .. - COMPLEX*16 TEMP1, TEMP2 - INTEGER I, INFO, IX, IY, J, JX, JY, KX, KY -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. External Subroutines .. - EXTERNAL XERBLA -* .. Intrinsic Functions .. - INTRINSIC DCONJG, MAX, DBLE -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - IF ( .NOT.LSAME( UPLO, 'U' ).AND. - $ .NOT.LSAME( UPLO, 'L' ) )THEN - INFO = 1 - ELSE IF( N.LT.0 )THEN - INFO = 2 - ELSE IF( INCX.EQ.0 )THEN - INFO = 5 - ELSE IF( INCY.EQ.0 )THEN - INFO = 7 - ELSE IF( LDA.LT.MAX( 1, N ) )THEN - INFO = 9 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'ZHER2 ', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( ( N.EQ.0 ).OR.( ALPHA.EQ.ZERO ) ) - $ RETURN -* -* Set up the start points in X and Y if the increments are not both -* unity. -* - IF( ( INCX.NE.1 ).OR.( INCY.NE.1 ) )THEN - IF( INCX.GT.0 )THEN - KX = 1 - ELSE - KX = 1 - ( N - 1 )*INCX - END IF - IF( INCY.GT.0 )THEN - KY = 1 - ELSE - KY = 1 - ( N - 1 )*INCY - END IF - JX = KX - JY = KY - END IF -* -* 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' ) )THEN -* -* Form A when A is stored in the upper triangle. -* - IF( ( INCX.EQ.1 ).AND.( INCY.EQ.1 ) )THEN - DO 20, J = 1, N - IF( ( X( J ).NE.ZERO ).OR.( Y( J ).NE.ZERO ) )THEN - TEMP1 = ALPHA*DCONJG( Y( J ) ) - TEMP2 = DCONJG( ALPHA*X( J ) ) - DO 10, I = 1, J - 1 - A( I, J ) = A( I, J ) + X( I )*TEMP1 + Y( I )*TEMP2 - 10 CONTINUE - A( J, J ) = DBLE( A( J, J ) ) + - $ DBLE( X( J )*TEMP1 + Y( J )*TEMP2 ) - ELSE - A( J, J ) = DBLE( A( J, J ) ) - END IF - 20 CONTINUE - ELSE - DO 40, J = 1, N - IF( ( X( JX ).NE.ZERO ).OR.( Y( JY ).NE.ZERO ) )THEN - TEMP1 = ALPHA*DCONJG( Y( JY ) ) - TEMP2 = DCONJG( ALPHA*X( JX ) ) - IX = KX - IY = KY - DO 30, I = 1, J - 1 - A( I, J ) = A( I, J ) + X( IX )*TEMP1 - $ + Y( IY )*TEMP2 - IX = IX + INCX - IY = IY + INCY - 30 CONTINUE - A( J, J ) = DBLE( A( J, J ) ) + - $ DBLE( X( JX )*TEMP1 + Y( JY )*TEMP2 ) - ELSE - A( J, J ) = DBLE( A( J, J ) ) - END IF - JX = JX + INCX - JY = JY + INCY - 40 CONTINUE - END IF - ELSE -* -* Form A when A is stored in the lower triangle. -* - IF( ( INCX.EQ.1 ).AND.( INCY.EQ.1 ) )THEN - DO 60, J = 1, N - IF( ( X( J ).NE.ZERO ).OR.( Y( J ).NE.ZERO ) )THEN - TEMP1 = ALPHA*DCONJG( Y( J ) ) - TEMP2 = DCONJG( ALPHA*X( J ) ) - A( J, J ) = DBLE( A( J, J ) ) + - $ DBLE( X( J )*TEMP1 + Y( J )*TEMP2 ) - DO 50, I = J + 1, N - A( I, J ) = A( I, J ) + X( I )*TEMP1 + Y( I )*TEMP2 - 50 CONTINUE - ELSE - A( J, J ) = DBLE( A( J, J ) ) - END IF - 60 CONTINUE - ELSE - DO 80, J = 1, N - IF( ( X( JX ).NE.ZERO ).OR.( Y( JY ).NE.ZERO ) )THEN - TEMP1 = ALPHA*DCONJG( Y( JY ) ) - TEMP2 = DCONJG( ALPHA*X( JX ) ) - A( J, J ) = DBLE( A( J, J ) ) + - $ DBLE( X( JX )*TEMP1 + Y( JY )*TEMP2 ) - IX = JX - IY = JY - DO 70, I = J + 1, N - IX = IX + INCX - IY = IY + INCY - A( I, J ) = A( I, J ) + X( IX )*TEMP1 - $ + Y( IY )*TEMP2 - 70 CONTINUE - ELSE - A( J, J ) = DBLE( A( J, J ) ) - END IF - JX = JX + INCX - JY = JY + INCY - 80 CONTINUE - END IF - END IF -* - RETURN -* -* End of ZHER2 . -* - END diff --git a/src/lib/blas/zher2k.f b/src/lib/blas/zher2k.f deleted file mode 100644 index 408d75cf..00000000 --- a/src/lib/blas/zher2k.f +++ /dev/null @@ -1,372 +0,0 @@ - SUBROUTINE ZHER2K( UPLO, TRANS, N, K, ALPHA, A, LDA, B, LDB, BETA, - $ C, LDC ) -* .. Scalar Arguments .. - CHARACTER TRANS, UPLO - INTEGER K, LDA, LDB, LDC, N - DOUBLE PRECISION BETA - COMPLEX*16 ALPHA -* .. -* .. Array Arguments .. - COMPLEX*16 A( LDA, * ), B( LDB, * ), C( LDC, * ) -* .. -* -* Purpose -* ======= -* -* ZHER2K performs one of the hermitian rank 2k operations -* -* C := alpha*A*conjg( B' ) + conjg( alpha )*B*conjg( A' ) + beta*C, -* -* or -* -* C := alpha*conjg( A' )*B + conjg( alpha )*conjg( B' )*A + beta*C, -* -* where alpha and beta are scalars with beta real, C is an n by n -* hermitian matrix and A and B are n by k matrices in the first case -* and k by n matrices in the second case. -* -* 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*16 . -* On entry, ALPHA specifies the scalar alpha. -* Unchanged on exit. -* -* A - COMPLEX*16 array of DIMENSION ( LDA, ka ), where ka is -* k when TRANS = 'N' or 'n', and is n otherwise. -* Before entry with TRANS = 'N' or 'n', the leading n by k -* part of the array A must contain the matrix A, otherwise -* the leading k by n part of the array A must contain the -* matrix A. -* Unchanged on exit. -* -* LDA - INTEGER. -* On entry, LDA specifies the first dimension of A as declared -* in the calling (sub) program. When TRANS = 'N' or 'n' -* then LDA must be at least max( 1, n ), otherwise LDA must -* be at least max( 1, k ). -* Unchanged on exit. -* -* B - COMPLEX*16 array of DIMENSION ( LDB, kb ), where kb is -* k when TRANS = 'N' or 'n', and is n otherwise. -* Before entry with TRANS = 'N' or 'n', the leading n by k -* part of the array B must contain the matrix B, otherwise -* the leading k by n part of the array B must contain the -* matrix B. -* Unchanged on exit. -* -* LDB - INTEGER. -* On entry, LDB specifies the first dimension of B as declared -* in the calling (sub) program. When TRANS = 'N' or 'n' -* then LDB must be at least max( 1, n ), otherwise LDB must -* be at least max( 1, k ). -* Unchanged on exit. -* -* BETA - DOUBLE PRECISION . -* On entry, BETA specifies the scalar beta. -* Unchanged on exit. -* -* C - COMPLEX*16 array of DIMENSION ( LDC, n ). -* Before entry with UPLO = 'U' or 'u', the leading n by n -* upper triangular part of the array C must contain the upper -* triangular part of the hermitian matrix and the strictly -* lower triangular part of C is not referenced. On exit, the -* upper triangular part of the array C is overwritten by the -* upper triangular part of the updated matrix. -* Before entry with UPLO = 'L' or 'l', the leading n by n -* lower triangular part of the array C must contain the lower -* triangular part of the hermitian matrix and the strictly -* upper triangular part of C is not referenced. On exit, the -* lower triangular part of the array C is overwritten by the -* lower triangular part of the updated matrix. -* Note that the imaginary parts of the diagonal elements need -* not be set, they are assumed to be zero, and on exit they -* are set to zero. -* -* LDC - INTEGER. -* On entry, LDC specifies the first dimension of C as declared -* in the calling (sub) program. LDC must be at least -* max( 1, n ). -* Unchanged on exit. -* -* -* Level 3 Blas routine. -* -* -- Written on 8-February-1989. -* Jack Dongarra, Argonne National Laboratory. -* Iain Duff, AERE Harwell. -* Jeremy Du Croz, Numerical Algorithms Group Ltd. -* Sven Hammarling, Numerical Algorithms Group Ltd. -* -* -- Modified 8-Nov-93 to set C(J,J) to DBLE( C(J,J) ) when BETA = 1. -* Ed Anderson, Cray Research Inc. -* -* -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC DBLE, DCONJG, MAX -* .. -* .. Local Scalars .. - LOGICAL UPPER - INTEGER I, INFO, J, L, NROWA - COMPLEX*16 TEMP1, TEMP2 -* .. -* .. Parameters .. - DOUBLE PRECISION ONE - PARAMETER ( ONE = 1.0D+0 ) - COMPLEX*16 ZERO - PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) ) -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - IF( LSAME( TRANS, 'N' ) ) THEN - NROWA = N - ELSE - NROWA = K - END IF - UPPER = LSAME( UPLO, 'U' ) -* - INFO = 0 - IF( ( .NOT.UPPER ) .AND. ( .NOT.LSAME( UPLO, 'L' ) ) ) THEN - INFO = 1 - ELSE IF( ( .NOT.LSAME( TRANS, 'N' ) ) .AND. - $ ( .NOT.LSAME( TRANS, 'C' ) ) ) THEN - INFO = 2 - ELSE IF( N.LT.0 ) THEN - INFO = 3 - ELSE IF( K.LT.0 ) THEN - INFO = 4 - ELSE IF( LDA.LT.MAX( 1, NROWA ) ) THEN - INFO = 7 - ELSE IF( LDB.LT.MAX( 1, NROWA ) ) THEN - INFO = 9 - ELSE IF( LDC.LT.MAX( 1, N ) ) THEN - INFO = 12 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'ZHER2K', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( ( N.EQ.0 ) .OR. ( ( ( ALPHA.EQ.ZERO ) .OR. ( K.EQ.0 ) ) .AND. - $ ( BETA.EQ.ONE ) ) )RETURN -* -* And when alpha.eq.zero. -* - IF( ALPHA.EQ.ZERO ) THEN - IF( UPPER ) THEN - IF( BETA.EQ.DBLE( ZERO ) ) THEN - DO 20 J = 1, N - DO 10 I = 1, J - C( I, J ) = ZERO - 10 CONTINUE - 20 CONTINUE - ELSE - DO 40 J = 1, N - DO 30 I = 1, J - 1 - C( I, J ) = BETA*C( I, J ) - 30 CONTINUE - C( J, J ) = BETA*DBLE( C( J, J ) ) - 40 CONTINUE - END IF - ELSE - IF( BETA.EQ.DBLE( ZERO ) ) THEN - DO 60 J = 1, N - DO 50 I = J, N - C( I, J ) = ZERO - 50 CONTINUE - 60 CONTINUE - ELSE - DO 80 J = 1, N - C( J, J ) = BETA*DBLE( C( J, J ) ) - DO 70 I = J + 1, N - C( I, J ) = BETA*C( I, J ) - 70 CONTINUE - 80 CONTINUE - END IF - END IF - RETURN - END IF -* -* Start the operations. -* - IF( LSAME( TRANS, 'N' ) ) THEN -* -* Form C := alpha*A*conjg( B' ) + conjg( alpha )*B*conjg( A' ) + -* C. -* - IF( UPPER ) THEN - DO 130 J = 1, N - IF( BETA.EQ.DBLE( ZERO ) ) THEN - DO 90 I = 1, J - C( I, J ) = ZERO - 90 CONTINUE - ELSE IF( BETA.NE.ONE ) THEN - DO 100 I = 1, J - 1 - C( I, J ) = BETA*C( I, J ) - 100 CONTINUE - C( J, J ) = BETA*DBLE( C( J, J ) ) - ELSE - C( J, J ) = DBLE( C( J, J ) ) - END IF - DO 120 L = 1, K - IF( ( A( J, L ).NE.ZERO ) .OR. ( B( J, L ).NE.ZERO ) ) - $ THEN - TEMP1 = ALPHA*DCONJG( B( J, L ) ) - TEMP2 = DCONJG( ALPHA*A( J, L ) ) - DO 110 I = 1, J - 1 - C( I, J ) = C( I, J ) + A( I, L )*TEMP1 + - $ B( I, L )*TEMP2 - 110 CONTINUE - C( J, J ) = DBLE( C( J, J ) ) + - $ DBLE( A( J, L )*TEMP1+B( J, L )*TEMP2 ) - END IF - 120 CONTINUE - 130 CONTINUE - ELSE - DO 180 J = 1, N - IF( BETA.EQ.DBLE( ZERO ) ) THEN - DO 140 I = J, N - C( I, J ) = ZERO - 140 CONTINUE - ELSE IF( BETA.NE.ONE ) THEN - DO 150 I = J + 1, N - C( I, J ) = BETA*C( I, J ) - 150 CONTINUE - C( J, J ) = BETA*DBLE( C( J, J ) ) - ELSE - C( J, J ) = DBLE( C( J, J ) ) - END IF - DO 170 L = 1, K - IF( ( A( J, L ).NE.ZERO ) .OR. ( B( J, L ).NE.ZERO ) ) - $ THEN - TEMP1 = ALPHA*DCONJG( B( J, L ) ) - TEMP2 = DCONJG( ALPHA*A( J, L ) ) - DO 160 I = J + 1, N - C( I, J ) = C( I, J ) + A( I, L )*TEMP1 + - $ B( I, L )*TEMP2 - 160 CONTINUE - C( J, J ) = DBLE( C( J, J ) ) + - $ DBLE( A( J, L )*TEMP1+B( J, L )*TEMP2 ) - END IF - 170 CONTINUE - 180 CONTINUE - END IF - ELSE -* -* Form C := alpha*conjg( A' )*B + conjg( alpha )*conjg( B' )*A + -* C. -* - IF( UPPER ) THEN - DO 210 J = 1, N - DO 200 I = 1, J - TEMP1 = ZERO - TEMP2 = ZERO - DO 190 L = 1, K - TEMP1 = TEMP1 + DCONJG( A( L, I ) )*B( L, J ) - TEMP2 = TEMP2 + DCONJG( B( L, I ) )*A( L, J ) - 190 CONTINUE - IF( I.EQ.J ) THEN - IF( BETA.EQ.DBLE( ZERO ) ) THEN - C( J, J ) = DBLE( ALPHA*TEMP1+DCONJG( ALPHA )* - $ TEMP2 ) - ELSE - C( J, J ) = BETA*DBLE( C( J, J ) ) + - $ DBLE( ALPHA*TEMP1+DCONJG( ALPHA )* - $ TEMP2 ) - END IF - ELSE - IF( BETA.EQ.DBLE( ZERO ) ) THEN - C( I, J ) = ALPHA*TEMP1 + DCONJG( ALPHA )*TEMP2 - ELSE - C( I, J ) = BETA*C( I, J ) + ALPHA*TEMP1 + - $ DCONJG( ALPHA )*TEMP2 - END IF - END IF - 200 CONTINUE - 210 CONTINUE - ELSE - DO 240 J = 1, N - DO 230 I = J, N - TEMP1 = ZERO - TEMP2 = ZERO - DO 220 L = 1, K - TEMP1 = TEMP1 + DCONJG( A( L, I ) )*B( L, J ) - TEMP2 = TEMP2 + DCONJG( B( L, I ) )*A( L, J ) - 220 CONTINUE - IF( I.EQ.J ) THEN - IF( BETA.EQ.DBLE( ZERO ) ) THEN - C( J, J ) = DBLE( ALPHA*TEMP1+DCONJG( ALPHA )* - $ TEMP2 ) - ELSE - C( J, J ) = BETA*DBLE( C( J, J ) ) + - $ DBLE( ALPHA*TEMP1+DCONJG( ALPHA )* - $ TEMP2 ) - END IF - ELSE - IF( BETA.EQ.DBLE( ZERO ) ) THEN - C( I, J ) = ALPHA*TEMP1 + DCONJG( ALPHA )*TEMP2 - ELSE - C( I, J ) = BETA*C( I, J ) + ALPHA*TEMP1 + - $ DCONJG( ALPHA )*TEMP2 - END IF - END IF - 230 CONTINUE - 240 CONTINUE - END IF - END IF -* - RETURN -* -* End of ZHER2K. -* - END diff --git a/src/lib/blas/zherk.f b/src/lib/blas/zherk.f deleted file mode 100644 index cfbf7180..00000000 --- a/src/lib/blas/zherk.f +++ /dev/null @@ -1,330 +0,0 @@ - SUBROUTINE ZHERK( UPLO, TRANS, N, K, ALPHA, A, LDA, BETA, C, LDC ) -* .. Scalar Arguments .. - CHARACTER TRANS, UPLO - INTEGER K, LDA, LDC, N - DOUBLE PRECISION ALPHA, BETA -* .. -* .. Array Arguments .. - COMPLEX*16 A( LDA, * ), C( LDC, * ) -* .. -* -* Purpose -* ======= -* -* ZHERK performs one of the hermitian rank k operations -* -* C := alpha*A*conjg( A' ) + beta*C, -* -* or -* -* C := alpha*conjg( A' )*A + beta*C, -* -* where alpha and beta are real scalars, C is an n by n hermitian -* matrix and A is an n by k matrix in the first case and a k by n -* matrix in the second case. -* -* 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 - DOUBLE PRECISION . -* On entry, ALPHA specifies the scalar alpha. -* Unchanged on exit. -* -* A - COMPLEX*16 array of DIMENSION ( LDA, ka ), where ka is -* k when TRANS = 'N' or 'n', and is n otherwise. -* Before entry with TRANS = 'N' or 'n', the leading n by k -* part of the array A must contain the matrix A, otherwise -* the leading k by n part of the array A must contain the -* matrix A. -* Unchanged on exit. -* -* LDA - INTEGER. -* On entry, LDA specifies the first dimension of A as declared -* in the calling (sub) program. When TRANS = 'N' or 'n' -* then LDA must be at least max( 1, n ), otherwise LDA must -* be at least max( 1, k ). -* Unchanged on exit. -* -* BETA - DOUBLE PRECISION. -* On entry, BETA specifies the scalar beta. -* Unchanged on exit. -* -* C - COMPLEX*16 array of DIMENSION ( LDC, n ). -* Before entry with UPLO = 'U' or 'u', the leading n by n -* upper triangular part of the array C must contain the upper -* triangular part of the hermitian matrix and the strictly -* lower triangular part of C is not referenced. On exit, the -* upper triangular part of the array C is overwritten by the -* upper triangular part of the updated matrix. -* Before entry with UPLO = 'L' or 'l', the leading n by n -* lower triangular part of the array C must contain the lower -* triangular part of the hermitian matrix and the strictly -* upper triangular part of C is not referenced. On exit, the -* lower triangular part of the array C is overwritten by the -* lower triangular part of the updated matrix. -* Note that the imaginary parts of the diagonal elements need -* not be set, they are assumed to be zero, and on exit they -* are set to zero. -* -* LDC - INTEGER. -* On entry, LDC specifies the first dimension of C as declared -* in the calling (sub) program. LDC must be at least -* max( 1, n ). -* Unchanged on exit. -* -* -* Level 3 Blas routine. -* -* -- Written on 8-February-1989. -* Jack Dongarra, Argonne National Laboratory. -* Iain Duff, AERE Harwell. -* Jeremy Du Croz, Numerical Algorithms Group Ltd. -* Sven Hammarling, Numerical Algorithms Group Ltd. -* -* -- Modified 8-Nov-93 to set C(J,J) to DBLE( C(J,J) ) when BETA = 1. -* Ed Anderson, Cray Research Inc. -* -* -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC DBLE, DCMPLX, DCONJG, MAX -* .. -* .. Local Scalars .. - LOGICAL UPPER - INTEGER I, INFO, J, L, NROWA - DOUBLE PRECISION RTEMP - COMPLEX*16 TEMP -* .. -* .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - IF( LSAME( TRANS, 'N' ) ) THEN - NROWA = N - ELSE - NROWA = K - END IF - UPPER = LSAME( UPLO, 'U' ) -* - INFO = 0 - IF( ( .NOT.UPPER ) .AND. ( .NOT.LSAME( UPLO, 'L' ) ) ) THEN - INFO = 1 - ELSE IF( ( .NOT.LSAME( TRANS, 'N' ) ) .AND. - $ ( .NOT.LSAME( TRANS, 'C' ) ) ) THEN - INFO = 2 - ELSE IF( N.LT.0 ) THEN - INFO = 3 - ELSE IF( K.LT.0 ) THEN - INFO = 4 - ELSE IF( LDA.LT.MAX( 1, NROWA ) ) THEN - INFO = 7 - ELSE IF( LDC.LT.MAX( 1, N ) ) THEN - INFO = 10 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'ZHERK ', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( ( N.EQ.0 ) .OR. ( ( ( ALPHA.EQ.ZERO ) .OR. ( K.EQ.0 ) ) .AND. - $ ( BETA.EQ.ONE ) ) )RETURN -* -* And when alpha.eq.zero. -* - IF( ALPHA.EQ.ZERO ) THEN - IF( UPPER ) THEN - IF( BETA.EQ.ZERO ) THEN - DO 20 J = 1, N - DO 10 I = 1, J - C( I, J ) = ZERO - 10 CONTINUE - 20 CONTINUE - ELSE - DO 40 J = 1, N - DO 30 I = 1, J - 1 - C( I, J ) = BETA*C( I, J ) - 30 CONTINUE - C( J, J ) = BETA*DBLE( C( J, J ) ) - 40 CONTINUE - END IF - ELSE - IF( BETA.EQ.ZERO ) THEN - DO 60 J = 1, N - DO 50 I = J, N - C( I, J ) = ZERO - 50 CONTINUE - 60 CONTINUE - ELSE - DO 80 J = 1, N - C( J, J ) = BETA*DBLE( C( J, J ) ) - DO 70 I = J + 1, N - C( I, J ) = BETA*C( I, J ) - 70 CONTINUE - 80 CONTINUE - END IF - END IF - RETURN - END IF -* -* Start the operations. -* - IF( LSAME( TRANS, 'N' ) ) THEN -* -* Form C := alpha*A*conjg( A' ) + beta*C. -* - IF( UPPER ) THEN - DO 130 J = 1, N - IF( BETA.EQ.ZERO ) THEN - DO 90 I = 1, J - C( I, J ) = ZERO - 90 CONTINUE - ELSE IF( BETA.NE.ONE ) THEN - DO 100 I = 1, J - 1 - C( I, J ) = BETA*C( I, J ) - 100 CONTINUE - C( J, J ) = BETA*DBLE( C( J, J ) ) - ELSE - C( J, J ) = DBLE( C( J, J ) ) - END IF - DO 120 L = 1, K - IF( A( J, L ).NE.DCMPLX( ZERO ) ) THEN - TEMP = ALPHA*DCONJG( A( J, L ) ) - DO 110 I = 1, J - 1 - C( I, J ) = C( I, J ) + TEMP*A( I, L ) - 110 CONTINUE - C( J, J ) = DBLE( C( J, J ) ) + - $ DBLE( TEMP*A( I, L ) ) - END IF - 120 CONTINUE - 130 CONTINUE - ELSE - DO 180 J = 1, N - IF( BETA.EQ.ZERO ) THEN - DO 140 I = J, N - C( I, J ) = ZERO - 140 CONTINUE - ELSE IF( BETA.NE.ONE ) THEN - C( J, J ) = BETA*DBLE( C( J, J ) ) - DO 150 I = J + 1, N - C( I, J ) = BETA*C( I, J ) - 150 CONTINUE - ELSE - C( J, J ) = DBLE( C( J, J ) ) - END IF - DO 170 L = 1, K - IF( A( J, L ).NE.DCMPLX( ZERO ) ) THEN - TEMP = ALPHA*DCONJG( A( J, L ) ) - C( J, J ) = DBLE( C( J, J ) ) + - $ DBLE( TEMP*A( J, L ) ) - DO 160 I = J + 1, N - C( I, J ) = C( I, J ) + TEMP*A( I, L ) - 160 CONTINUE - END IF - 170 CONTINUE - 180 CONTINUE - END IF - ELSE -* -* Form C := alpha*conjg( A' )*A + beta*C. -* - IF( UPPER ) THEN - DO 220 J = 1, N - DO 200 I = 1, J - 1 - TEMP = ZERO - DO 190 L = 1, K - TEMP = TEMP + DCONJG( A( L, I ) )*A( L, J ) - 190 CONTINUE - IF( BETA.EQ.ZERO ) THEN - C( I, J ) = ALPHA*TEMP - ELSE - C( I, J ) = ALPHA*TEMP + BETA*C( I, J ) - END IF - 200 CONTINUE - RTEMP = ZERO - DO 210 L = 1, K - RTEMP = RTEMP + DCONJG( A( L, J ) )*A( L, J ) - 210 CONTINUE - IF( BETA.EQ.ZERO ) THEN - C( J, J ) = ALPHA*RTEMP - ELSE - C( J, J ) = ALPHA*RTEMP + BETA*DBLE( C( J, J ) ) - END IF - 220 CONTINUE - ELSE - DO 260 J = 1, N - RTEMP = ZERO - DO 230 L = 1, K - RTEMP = RTEMP + DCONJG( A( L, J ) )*A( L, J ) - 230 CONTINUE - IF( BETA.EQ.ZERO ) THEN - C( J, J ) = ALPHA*RTEMP - ELSE - C( J, J ) = ALPHA*RTEMP + BETA*DBLE( C( J, J ) ) - END IF - DO 250 I = J + 1, N - TEMP = ZERO - DO 240 L = 1, K - TEMP = TEMP + DCONJG( A( L, I ) )*A( L, J ) - 240 CONTINUE - IF( BETA.EQ.ZERO ) THEN - C( I, J ) = ALPHA*TEMP - ELSE - C( I, J ) = ALPHA*TEMP + BETA*C( I, J ) - END IF - 250 CONTINUE - 260 CONTINUE - END IF - END IF -* - RETURN -* -* End of ZHERK . -* - END diff --git a/src/lib/blas/zhpmv.f b/src/lib/blas/zhpmv.f deleted file mode 100644 index 9cde9234..00000000 --- a/src/lib/blas/zhpmv.f +++ /dev/null @@ -1,270 +0,0 @@ - SUBROUTINE ZHPMV ( UPLO, N, ALPHA, AP, X, INCX, BETA, Y, INCY ) -* .. Scalar Arguments .. - COMPLEX*16 ALPHA, BETA - INTEGER INCX, INCY, N - CHARACTER*1 UPLO -* .. Array Arguments .. - COMPLEX*16 AP( * ), X( * ), Y( * ) -* .. -* -* Purpose -* ======= -* -* ZHPMV performs the matrix-vector operation -* -* y := alpha*A*x + beta*y, -* -* where alpha and beta are scalars, x and y are n element vectors and -* A is an n by n hermitian matrix, supplied in packed form. -* -* 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*16 . -* On entry, ALPHA specifies the scalar alpha. -* Unchanged on exit. -* -* AP - COMPLEX*16 array of DIMENSION at least -* ( ( n*( n + 1 ) )/2 ). -* Before entry with UPLO = 'U' or 'u', the array AP must -* contain the upper triangular part of the hermitian matrix -* packed sequentially, column by column, so that AP( 1 ) -* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 ) -* and a( 2, 2 ) respectively, and so on. -* Before entry with UPLO = 'L' or 'l', the array AP must -* contain the lower triangular part of the hermitian matrix -* packed sequentially, column by column, so that AP( 1 ) -* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 ) -* and a( 3, 1 ) respectively, and so on. -* Note that the imaginary parts of the diagonal elements need -* not be set and are assumed to be zero. -* Unchanged on exit. -* -* X - COMPLEX*16 array of dimension at least -* ( 1 + ( n - 1 )*abs( INCX ) ). -* Before entry, the incremented array X must contain the n -* element vector x. -* Unchanged on exit. -* -* INCX - INTEGER. -* On entry, INCX specifies the increment for the elements of -* X. INCX must not be zero. -* Unchanged on exit. -* -* BETA - COMPLEX*16 . -* On entry, BETA specifies the scalar beta. When BETA is -* supplied as zero then Y need not be set on input. -* Unchanged on exit. -* -* Y - COMPLEX*16 array of dimension at least -* ( 1 + ( n - 1 )*abs( INCY ) ). -* Before entry, the incremented array Y must contain the n -* element vector y. On exit, Y is overwritten by the updated -* vector y. -* -* INCY - INTEGER. -* On entry, INCY specifies the increment for the elements of -* Y. INCY must not be zero. -* Unchanged on exit. -* -* -* Level 2 Blas routine. -* -* -- Written on 22-October-1986. -* Jack Dongarra, Argonne National Lab. -* Jeremy Du Croz, Nag Central Office. -* Sven Hammarling, Nag Central Office. -* Richard Hanson, Sandia National Labs. -* -* -* .. Parameters .. - COMPLEX*16 ONE - PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) ) - COMPLEX*16 ZERO - PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) ) -* .. Local Scalars .. - COMPLEX*16 TEMP1, TEMP2 - INTEGER I, INFO, IX, IY, J, JX, JY, K, KK, KX, KY -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. External Subroutines .. - EXTERNAL XERBLA -* .. Intrinsic Functions .. - INTRINSIC DCONJG, DBLE -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - IF ( .NOT.LSAME( UPLO, 'U' ).AND. - $ .NOT.LSAME( UPLO, 'L' ) )THEN - INFO = 1 - ELSE IF( N.LT.0 )THEN - INFO = 2 - ELSE IF( INCX.EQ.0 )THEN - INFO = 6 - ELSE IF( INCY.EQ.0 )THEN - INFO = 9 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'ZHPMV ', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( ( N.EQ.0 ).OR.( ( ALPHA.EQ.ZERO ).AND.( BETA.EQ.ONE ) ) ) - $ RETURN -* -* Set up the start points in X and Y. -* - IF( INCX.GT.0 )THEN - KX = 1 - ELSE - KX = 1 - ( N - 1 )*INCX - END IF - IF( INCY.GT.0 )THEN - KY = 1 - ELSE - KY = 1 - ( N - 1 )*INCY - END IF -* -* 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.NE.ONE )THEN - IF( INCY.EQ.1 )THEN - IF( BETA.EQ.ZERO )THEN - DO 10, I = 1, N - Y( I ) = ZERO - 10 CONTINUE - ELSE - DO 20, I = 1, N - Y( I ) = BETA*Y( I ) - 20 CONTINUE - END IF - ELSE - IY = KY - IF( BETA.EQ.ZERO )THEN - DO 30, I = 1, N - Y( IY ) = ZERO - IY = IY + INCY - 30 CONTINUE - ELSE - DO 40, I = 1, N - Y( IY ) = BETA*Y( IY ) - IY = IY + INCY - 40 CONTINUE - END IF - END IF - END IF - IF( ALPHA.EQ.ZERO ) - $ RETURN - KK = 1 - IF( LSAME( UPLO, 'U' ) )THEN -* -* Form y when AP contains the upper triangle. -* - IF( ( INCX.EQ.1 ).AND.( INCY.EQ.1 ) )THEN - DO 60, J = 1, N - TEMP1 = ALPHA*X( J ) - TEMP2 = ZERO - K = KK - DO 50, I = 1, J - 1 - Y( I ) = Y( I ) + TEMP1*AP( K ) - TEMP2 = TEMP2 + DCONJG( AP( K ) )*X( I ) - K = K + 1 - 50 CONTINUE - Y( J ) = Y( J ) + TEMP1*DBLE( AP( KK + J - 1 ) ) - $ + ALPHA*TEMP2 - KK = KK + J - 60 CONTINUE - ELSE - JX = KX - JY = KY - DO 80, J = 1, N - TEMP1 = ALPHA*X( JX ) - TEMP2 = ZERO - IX = KX - IY = KY - DO 70, K = KK, KK + J - 2 - Y( IY ) = Y( IY ) + TEMP1*AP( K ) - TEMP2 = TEMP2 + DCONJG( AP( K ) )*X( IX ) - IX = IX + INCX - IY = IY + INCY - 70 CONTINUE - Y( JY ) = Y( JY ) + TEMP1*DBLE( AP( KK + J - 1 ) ) - $ + ALPHA*TEMP2 - JX = JX + INCX - JY = JY + INCY - KK = KK + J - 80 CONTINUE - END IF - ELSE -* -* Form y when AP contains the lower triangle. -* - IF( ( INCX.EQ.1 ).AND.( INCY.EQ.1 ) )THEN - DO 100, J = 1, N - TEMP1 = ALPHA*X( J ) - TEMP2 = ZERO - Y( J ) = Y( J ) + TEMP1*DBLE( AP( KK ) ) - K = KK + 1 - DO 90, I = J + 1, N - Y( I ) = Y( I ) + TEMP1*AP( K ) - TEMP2 = TEMP2 + DCONJG( AP( K ) )*X( I ) - K = K + 1 - 90 CONTINUE - Y( J ) = Y( J ) + ALPHA*TEMP2 - KK = KK + ( N - J + 1 ) - 100 CONTINUE - ELSE - JX = KX - JY = KY - DO 120, J = 1, N - TEMP1 = ALPHA*X( JX ) - TEMP2 = ZERO - Y( JY ) = Y( JY ) + TEMP1*DBLE( AP( KK ) ) - IX = JX - IY = JY - DO 110, K = KK + 1, KK + N - J - IX = IX + INCX - IY = IY + INCY - Y( IY ) = Y( IY ) + TEMP1*AP( K ) - TEMP2 = TEMP2 + DCONJG( AP( K ) )*X( IX ) - 110 CONTINUE - Y( JY ) = Y( JY ) + ALPHA*TEMP2 - JX = JX + INCX - JY = JY + INCY - KK = KK + ( N - J + 1 ) - 120 CONTINUE - END IF - END IF -* - RETURN -* -* End of ZHPMV . -* - END diff --git a/src/lib/blas/zhpr.f b/src/lib/blas/zhpr.f deleted file mode 100644 index 2e368de4..00000000 --- a/src/lib/blas/zhpr.f +++ /dev/null @@ -1,217 +0,0 @@ - SUBROUTINE ZHPR ( UPLO, N, ALPHA, X, INCX, AP ) -* .. Scalar Arguments .. - DOUBLE PRECISION ALPHA - INTEGER INCX, N - CHARACTER*1 UPLO -* .. Array Arguments .. - COMPLEX*16 AP( * ), X( * ) -* .. -* -* Purpose -* ======= -* -* ZHPR performs the hermitian rank 1 operation -* -* A := alpha*x*conjg( x' ) + A, -* -* where alpha is a real scalar, x is an n element vector and A is an -* n by n hermitian matrix, supplied in packed form. -* -* 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 - COMPLEX*16 array of dimension at least -* ( 1 + ( n - 1 )*abs( INCX ) ). -* Before entry, the incremented array X must contain the n -* element vector x. -* Unchanged on exit. -* -* INCX - INTEGER. -* On entry, INCX specifies the increment for the elements of -* X. INCX must not be zero. -* Unchanged on exit. -* -* AP - COMPLEX*16 array of DIMENSION at least -* ( ( n*( n + 1 ) )/2 ). -* Before entry with UPLO = 'U' or 'u', the array AP must -* contain the upper triangular part of the hermitian matrix -* packed sequentially, column by column, so that AP( 1 ) -* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 ) -* and a( 2, 2 ) respectively, and so on. On exit, the array -* AP is overwritten by the upper triangular part of the -* updated matrix. -* Before entry with UPLO = 'L' or 'l', the array AP must -* contain the lower triangular part of the hermitian matrix -* packed sequentially, column by column, so that AP( 1 ) -* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 ) -* and a( 3, 1 ) respectively, and so on. On exit, the array -* AP is overwritten by the lower triangular part of the -* updated matrix. -* Note that the imaginary parts of the diagonal elements need -* not be set, they are assumed to be zero, and on exit they -* are set to zero. -* -* -* Level 2 Blas routine. -* -* -- Written on 22-October-1986. -* Jack Dongarra, Argonne National Lab. -* Jeremy Du Croz, Nag Central Office. -* Sven Hammarling, Nag Central Office. -* Richard Hanson, Sandia National Labs. -* -* -* .. Parameters .. - COMPLEX*16 ZERO - PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) ) -* .. Local Scalars .. - COMPLEX*16 TEMP - INTEGER I, INFO, IX, J, JX, K, KK, KX -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. External Subroutines .. - EXTERNAL XERBLA -* .. Intrinsic Functions .. - INTRINSIC DCONJG, DBLE -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - IF ( .NOT.LSAME( UPLO, 'U' ).AND. - $ .NOT.LSAME( UPLO, 'L' ) )THEN - INFO = 1 - ELSE IF( N.LT.0 )THEN - INFO = 2 - ELSE IF( INCX.EQ.0 )THEN - INFO = 5 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'ZHPR ', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( ( N.EQ.0 ).OR.( ALPHA.EQ.DBLE( ZERO ) ) ) - $ RETURN -* -* Set the start point in X if the increment is not unity. -* - IF( INCX.LE.0 )THEN - KX = 1 - ( N - 1 )*INCX - ELSE IF( INCX.NE.1 )THEN - KX = 1 - END IF -* -* 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' ) )THEN -* -* Form A when upper triangle is stored in AP. -* - IF( INCX.EQ.1 )THEN - DO 20, J = 1, N - IF( X( J ).NE.ZERO )THEN - TEMP = ALPHA*DCONJG( X( J ) ) - K = KK - DO 10, I = 1, J - 1 - AP( K ) = AP( K ) + X( I )*TEMP - K = K + 1 - 10 CONTINUE - AP( KK + J - 1 ) = DBLE( AP( KK + J - 1 ) ) - $ + DBLE( X( J )*TEMP ) - ELSE - AP( KK + J - 1 ) = DBLE( AP( KK + J - 1 ) ) - END IF - KK = KK + J - 20 CONTINUE - ELSE - JX = KX - DO 40, J = 1, N - IF( X( JX ).NE.ZERO )THEN - TEMP = ALPHA*DCONJG( X( JX ) ) - IX = KX - DO 30, K = KK, KK + J - 2 - AP( K ) = AP( K ) + X( IX )*TEMP - IX = IX + INCX - 30 CONTINUE - AP( KK + J - 1 ) = DBLE( AP( KK + J - 1 ) ) - $ + DBLE( X( JX )*TEMP ) - ELSE - AP( KK + J - 1 ) = DBLE( AP( KK + J - 1 ) ) - END IF - JX = JX + INCX - KK = KK + J - 40 CONTINUE - END IF - ELSE -* -* Form A when lower triangle is stored in AP. -* - IF( INCX.EQ.1 )THEN - DO 60, J = 1, N - IF( X( J ).NE.ZERO )THEN - TEMP = ALPHA*DCONJG( X( J ) ) - AP( KK ) = DBLE( AP( KK ) ) + DBLE( TEMP*X( J ) ) - K = KK + 1 - DO 50, I = J + 1, N - AP( K ) = AP( K ) + X( I )*TEMP - K = K + 1 - 50 CONTINUE - ELSE - AP( KK ) = DBLE( AP( KK ) ) - END IF - KK = KK + N - J + 1 - 60 CONTINUE - ELSE - JX = KX - DO 80, J = 1, N - IF( X( JX ).NE.ZERO )THEN - TEMP = ALPHA*DCONJG( X( JX ) ) - AP( KK ) = DBLE( AP( KK ) ) + DBLE( TEMP*X( JX ) ) - IX = JX - DO 70, K = KK + 1, KK + N - J - IX = IX + INCX - AP( K ) = AP( K ) + X( IX )*TEMP - 70 CONTINUE - ELSE - AP( KK ) = DBLE( AP( KK ) ) - END IF - JX = JX + INCX - KK = KK + N - J + 1 - 80 CONTINUE - END IF - END IF -* - RETURN -* -* End of ZHPR . -* - END diff --git a/src/lib/blas/zhpr2.f b/src/lib/blas/zhpr2.f deleted file mode 100644 index e10774b1..00000000 --- a/src/lib/blas/zhpr2.f +++ /dev/null @@ -1,251 +0,0 @@ - SUBROUTINE ZHPR2 ( UPLO, N, ALPHA, X, INCX, Y, INCY, AP ) -* .. Scalar Arguments .. - COMPLEX*16 ALPHA - INTEGER INCX, INCY, N - CHARACTER*1 UPLO -* .. Array Arguments .. - COMPLEX*16 AP( * ), X( * ), Y( * ) -* .. -* -* Purpose -* ======= -* -* ZHPR2 performs the hermitian rank 2 operation -* -* A := alpha*x*conjg( y' ) + conjg( alpha )*y*conjg( x' ) + A, -* -* where alpha is a scalar, x and y are n element vectors and A is an -* n by n hermitian matrix, supplied in packed form. -* -* 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*16 . -* On entry, ALPHA specifies the scalar alpha. -* Unchanged on exit. -* -* X - COMPLEX*16 array of dimension at least -* ( 1 + ( n - 1 )*abs( INCX ) ). -* Before entry, the incremented array X must contain the n -* element vector x. -* Unchanged on exit. -* -* INCX - INTEGER. -* On entry, INCX specifies the increment for the elements of -* X. INCX must not be zero. -* Unchanged on exit. -* -* Y - COMPLEX*16 array of dimension at least -* ( 1 + ( n - 1 )*abs( INCY ) ). -* Before entry, the incremented array Y must contain the n -* element vector y. -* Unchanged on exit. -* -* INCY - INTEGER. -* On entry, INCY specifies the increment for the elements of -* Y. INCY must not be zero. -* Unchanged on exit. -* -* AP - COMPLEX*16 array of DIMENSION at least -* ( ( n*( n + 1 ) )/2 ). -* Before entry with UPLO = 'U' or 'u', the array AP must -* contain the upper triangular part of the hermitian matrix -* packed sequentially, column by column, so that AP( 1 ) -* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 ) -* and a( 2, 2 ) respectively, and so on. On exit, the array -* AP is overwritten by the upper triangular part of the -* updated matrix. -* Before entry with UPLO = 'L' or 'l', the array AP must -* contain the lower triangular part of the hermitian matrix -* packed sequentially, column by column, so that AP( 1 ) -* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 ) -* and a( 3, 1 ) respectively, and so on. On exit, the array -* AP is overwritten by the lower triangular part of the -* updated matrix. -* Note that the imaginary parts of the diagonal elements need -* not be set, they are assumed to be zero, and on exit they -* are set to zero. -* -* -* Level 2 Blas routine. -* -* -- Written on 22-October-1986. -* Jack Dongarra, Argonne National Lab. -* Jeremy Du Croz, Nag Central Office. -* Sven Hammarling, Nag Central Office. -* Richard Hanson, Sandia National Labs. -* -* -* .. Parameters .. - COMPLEX*16 ZERO - PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) ) -* .. Local Scalars .. - COMPLEX*16 TEMP1, TEMP2 - INTEGER I, INFO, IX, IY, J, JX, JY, K, KK, KX, KY -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. External Subroutines .. - EXTERNAL XERBLA -* .. Intrinsic Functions .. - INTRINSIC DCONJG, DBLE -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - IF ( .NOT.LSAME( UPLO, 'U' ).AND. - $ .NOT.LSAME( UPLO, 'L' ) )THEN - INFO = 1 - ELSE IF( N.LT.0 )THEN - INFO = 2 - ELSE IF( INCX.EQ.0 )THEN - INFO = 5 - ELSE IF( INCY.EQ.0 )THEN - INFO = 7 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'ZHPR2 ', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( ( N.EQ.0 ).OR.( ALPHA.EQ.ZERO ) ) - $ RETURN -* -* Set up the start points in X and Y if the increments are not both -* unity. -* - IF( ( INCX.NE.1 ).OR.( INCY.NE.1 ) )THEN - IF( INCX.GT.0 )THEN - KX = 1 - ELSE - KX = 1 - ( N - 1 )*INCX - END IF - IF( INCY.GT.0 )THEN - KY = 1 - ELSE - KY = 1 - ( N - 1 )*INCY - END IF - JX = KX - JY = KY - END IF -* -* 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' ) )THEN -* -* Form A when upper triangle is stored in AP. -* - IF( ( INCX.EQ.1 ).AND.( INCY.EQ.1 ) )THEN - DO 20, J = 1, N - IF( ( X( J ).NE.ZERO ).OR.( Y( J ).NE.ZERO ) )THEN - TEMP1 = ALPHA*DCONJG( Y( J ) ) - TEMP2 = DCONJG( ALPHA*X( J ) ) - K = KK - DO 10, I = 1, J - 1 - AP( K ) = AP( K ) + X( I )*TEMP1 + Y( I )*TEMP2 - K = K + 1 - 10 CONTINUE - AP( KK + J - 1 ) = DBLE( AP( KK + J - 1 ) ) + - $ DBLE( X( J )*TEMP1 + Y( J )*TEMP2 ) - ELSE - AP( KK + J - 1 ) = DBLE( AP( KK + J - 1 ) ) - END IF - KK = KK + J - 20 CONTINUE - ELSE - DO 40, J = 1, N - IF( ( X( JX ).NE.ZERO ).OR.( Y( JY ).NE.ZERO ) )THEN - TEMP1 = ALPHA*DCONJG( Y( JY ) ) - TEMP2 = DCONJG( ALPHA*X( JX ) ) - IX = KX - IY = KY - DO 30, K = KK, KK + J - 2 - AP( K ) = AP( K ) + X( IX )*TEMP1 + Y( IY )*TEMP2 - IX = IX + INCX - IY = IY + INCY - 30 CONTINUE - AP( KK + J - 1 ) = DBLE( AP( KK + J - 1 ) ) + - $ DBLE( X( JX )*TEMP1 + - $ Y( JY )*TEMP2 ) - ELSE - AP( KK + J - 1 ) = DBLE( AP( KK + J - 1 ) ) - END IF - JX = JX + INCX - JY = JY + INCY - KK = KK + J - 40 CONTINUE - END IF - ELSE -* -* Form A when lower triangle is stored in AP. -* - IF( ( INCX.EQ.1 ).AND.( INCY.EQ.1 ) )THEN - DO 60, J = 1, N - IF( ( X( J ).NE.ZERO ).OR.( Y( J ).NE.ZERO ) )THEN - TEMP1 = ALPHA*DCONJG( Y( J ) ) - TEMP2 = DCONJG( ALPHA*X( J ) ) - AP( KK ) = DBLE( AP( KK ) ) + - $ DBLE( X( J )*TEMP1 + Y( J )*TEMP2 ) - K = KK + 1 - DO 50, I = J + 1, N - AP( K ) = AP( K ) + X( I )*TEMP1 + Y( I )*TEMP2 - K = K + 1 - 50 CONTINUE - ELSE - AP( KK ) = DBLE( AP( KK ) ) - END IF - KK = KK + N - J + 1 - 60 CONTINUE - ELSE - DO 80, J = 1, N - IF( ( X( JX ).NE.ZERO ).OR.( Y( JY ).NE.ZERO ) )THEN - TEMP1 = ALPHA*DCONJG( Y( JY ) ) - TEMP2 = DCONJG( ALPHA*X( JX ) ) - AP( KK ) = DBLE( AP( KK ) ) + - $ DBLE( X( JX )*TEMP1 + Y( JY )*TEMP2 ) - IX = JX - IY = JY - DO 70, K = KK + 1, KK + N - J - IX = IX + INCX - IY = IY + INCY - AP( K ) = AP( K ) + X( IX )*TEMP1 + Y( IY )*TEMP2 - 70 CONTINUE - ELSE - AP( KK ) = DBLE( AP( KK ) ) - END IF - JX = JX + INCX - JY = JY + INCY - KK = KK + N - J + 1 - 80 CONTINUE - END IF - END IF -* - RETURN -* -* End of ZHPR2 . -* - END diff --git a/src/lib/blas/zrotg.f b/src/lib/blas/zrotg.f deleted file mode 100644 index f6a4aa12..00000000 --- a/src/lib/blas/zrotg.f +++ /dev/null @@ -1,21 +0,0 @@ - subroutine zrotg(ca,cb,c,s) - double complex ca,cb,s - double precision c - double precision norm,scale - double complex alpha - if (cdabs(ca) .ne. 0.0d0) go to 10 - c = 0.0d0 - s = (1.0d0,0.0d0) - ca = cb - go to 20 - 10 continue - scale = cdabs(ca) + cdabs(cb) - norm = scale*dsqrt((cdabs(ca/dcmplx(scale,0.0d0)))**2 + - * (cdabs(cb/dcmplx(scale,0.0d0)))**2) - alpha = ca /cdabs(ca) - c = cdabs(ca) / norm - s = alpha * dconjg(cb) / norm - ca = alpha * norm - 20 continue - return - end diff --git a/src/lib/blas/zscal.f b/src/lib/blas/zscal.f deleted file mode 100644 index 6fa85763..00000000 --- a/src/lib/blas/zscal.f +++ /dev/null @@ -1,29 +0,0 @@ - subroutine zscal(n,za,zx,incx) -c -c scales a vector by a constant. -c jack dongarra, 3/11/78. -c modified 3/93 to return if incx .le. 0. -c modified 12/3/93, array(1) declarations changed to array(*) -c - double complex za,zx(*) - integer i,incx,ix,n -c - if( n.le.0 .or. incx.le.0 )return - if(incx.eq.1)go to 20 -c -c code for increment not equal to 1 -c - ix = 1 - do 10 i = 1,n - zx(ix) = za*zx(ix) - ix = ix + incx - 10 continue - return -c -c code for increment equal to 1 -c - 20 do 30 i = 1,n - zx(i) = za*zx(i) - 30 continue - return - end diff --git a/src/lib/blas/zswap.f b/src/lib/blas/zswap.f deleted file mode 100644 index f28a4e41..00000000 --- a/src/lib/blas/zswap.f +++ /dev/null @@ -1,36 +0,0 @@ - subroutine zswap (n,zx,incx,zy,incy) -c -c interchanges two vectors. -c jack dongarra, 3/11/78. -c modified 12/3/93, array(1) declarations changed to array(*) -c - double complex zx(*),zy(*),ztemp - integer i,incx,incy,ix,iy,n -c - if(n.le.0)return - if(incx.eq.1.and.incy.eq.1)go to 20 -c -c code for unequal increments or equal increments not equal -c to 1 -c - ix = 1 - iy = 1 - if(incx.lt.0)ix = (-n+1)*incx + 1 - if(incy.lt.0)iy = (-n+1)*incy + 1 - do 10 i = 1,n - ztemp = zx(ix) - zx(ix) = zy(iy) - zy(iy) = ztemp - ix = ix + incx - iy = iy + incy - 10 continue - return -c -c code for both increments equal to 1 - 20 do 30 i = 1,n - ztemp = zx(i) - zx(i) = zy(i) - zy(i) = ztemp - 30 continue - return - end diff --git a/src/lib/blas/zsymm.f b/src/lib/blas/zsymm.f deleted file mode 100644 index 20b7c08d..00000000 --- a/src/lib/blas/zsymm.f +++ /dev/null @@ -1,296 +0,0 @@ - SUBROUTINE ZSYMM ( SIDE, UPLO, M, N, ALPHA, A, LDA, B, LDB, - $ BETA, C, LDC ) -* .. Scalar Arguments .. - CHARACTER*1 SIDE, UPLO - INTEGER M, N, LDA, LDB, LDC - COMPLEX*16 ALPHA, BETA -* .. Array Arguments .. - COMPLEX*16 A( LDA, * ), B( LDB, * ), C( LDC, * ) -* .. -* -* Purpose -* ======= -* -* ZSYMM performs one of the matrix-matrix operations -* -* C := alpha*A*B + beta*C, -* -* or -* -* C := alpha*B*A + beta*C, -* -* where alpha and beta are scalars, A is a symmetric matrix and B and -* C are m by n matrices. -* -* 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*16 . -* On entry, ALPHA specifies the scalar alpha. -* Unchanged on exit. -* -* A - COMPLEX*16 array of DIMENSION ( LDA, ka ), where ka is -* m when SIDE = 'L' or 'l' and is n otherwise. -* Before entry with SIDE = 'L' or 'l', the m by m part of -* the array A must contain the symmetric matrix, such that -* when UPLO = 'U' or 'u', the leading m by m upper triangular -* part of the array A must contain the upper triangular part -* of the symmetric matrix and the strictly lower triangular -* part of A is not referenced, and when UPLO = 'L' or 'l', -* the leading m by m lower triangular part of the array A -* must contain the lower triangular part of the symmetric -* matrix and the strictly upper triangular part of A is not -* referenced. -* Before entry with SIDE = 'R' or 'r', the n by n part of -* the array A must contain the symmetric matrix, such that -* when UPLO = 'U' or 'u', the leading n by n upper triangular -* part of the array A must contain the upper triangular part -* of the symmetric matrix and the strictly lower triangular -* part of A is not referenced, and when UPLO = 'L' or 'l', -* the leading n by n lower triangular part of the array A -* must contain the lower triangular part of the symmetric -* matrix and the strictly upper triangular part of A is not -* referenced. -* Unchanged on exit. -* -* LDA - INTEGER. -* On entry, LDA specifies the first dimension of A as declared -* in the calling (sub) program. When SIDE = 'L' or 'l' then -* LDA must be at least max( 1, m ), otherwise LDA must be at -* least max( 1, n ). -* Unchanged on exit. -* -* B - COMPLEX*16 array of DIMENSION ( LDB, n ). -* Before entry, the leading m by n part of the array B must -* contain the matrix B. -* Unchanged on exit. -* -* LDB - INTEGER. -* On entry, LDB specifies the first dimension of B as declared -* in the calling (sub) program. LDB must be at least -* max( 1, m ). -* Unchanged on exit. -* -* BETA - COMPLEX*16 . -* On entry, BETA specifies the scalar beta. When BETA is -* supplied as zero then C need not be set on input. -* Unchanged on exit. -* -* C - COMPLEX*16 array of DIMENSION ( LDC, n ). -* Before entry, the leading m by n part of the array C must -* contain the matrix C, except when beta is zero, in which -* case C need not be set on entry. -* On exit, the array C is overwritten by the m by n updated -* matrix. -* -* LDC - INTEGER. -* On entry, LDC specifies the first dimension of C as declared -* in the calling (sub) program. LDC must be at least -* max( 1, m ). -* Unchanged on exit. -* -* -* Level 3 Blas routine. -* -* -- Written on 8-February-1989. -* Jack Dongarra, Argonne National Laboratory. -* Iain Duff, AERE Harwell. -* Jeremy Du Croz, Numerical Algorithms Group Ltd. -* Sven Hammarling, Numerical Algorithms Group Ltd. -* -* -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. External Subroutines .. - EXTERNAL XERBLA -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. Local Scalars .. - LOGICAL UPPER - INTEGER I, INFO, J, K, NROWA - COMPLEX*16 TEMP1, TEMP2 -* .. Parameters .. - COMPLEX*16 ONE - PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) ) - COMPLEX*16 ZERO - PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) ) -* .. -* .. Executable Statements .. -* -* Set NROWA as the number of rows of A. -* - IF( LSAME( SIDE, 'L' ) )THEN - NROWA = M - ELSE - NROWA = N - END IF - UPPER = LSAME( UPLO, 'U' ) -* -* Test the input parameters. -* - INFO = 0 - IF( ( .NOT.LSAME( SIDE, 'L' ) ).AND. - $ ( .NOT.LSAME( SIDE, 'R' ) ) )THEN - INFO = 1 - ELSE IF( ( .NOT.UPPER ).AND. - $ ( .NOT.LSAME( UPLO, 'L' ) ) )THEN - INFO = 2 - ELSE IF( M .LT.0 )THEN - INFO = 3 - ELSE IF( N .LT.0 )THEN - INFO = 4 - ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN - INFO = 7 - ELSE IF( LDB.LT.MAX( 1, M ) )THEN - INFO = 9 - ELSE IF( LDC.LT.MAX( 1, M ) )THEN - INFO = 12 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'ZSYMM ', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR. - $ ( ( ALPHA.EQ.ZERO ).AND.( BETA.EQ.ONE ) ) ) - $ RETURN -* -* And when alpha.eq.zero. -* - IF( ALPHA.EQ.ZERO )THEN - IF( BETA.EQ.ZERO )THEN - DO 20, J = 1, N - DO 10, I = 1, M - C( I, J ) = ZERO - 10 CONTINUE - 20 CONTINUE - ELSE - DO 40, J = 1, N - DO 30, I = 1, M - C( I, J ) = BETA*C( I, J ) - 30 CONTINUE - 40 CONTINUE - END IF - RETURN - END IF -* -* Start the operations. -* - IF( LSAME( SIDE, 'L' ) )THEN -* -* Form C := alpha*A*B + beta*C. -* - IF( UPPER )THEN - DO 70, J = 1, N - DO 60, I = 1, M - TEMP1 = ALPHA*B( I, J ) - TEMP2 = ZERO - DO 50, K = 1, I - 1 - C( K, J ) = C( K, J ) + TEMP1 *A( K, I ) - TEMP2 = TEMP2 + B( K, J )*A( K, I ) - 50 CONTINUE - IF( BETA.EQ.ZERO )THEN - C( I, J ) = TEMP1*A( I, I ) + ALPHA*TEMP2 - ELSE - C( I, J ) = BETA *C( I, J ) + - $ TEMP1*A( I, I ) + ALPHA*TEMP2 - END IF - 60 CONTINUE - 70 CONTINUE - ELSE - DO 100, J = 1, N - DO 90, I = M, 1, -1 - TEMP1 = ALPHA*B( I, J ) - TEMP2 = ZERO - DO 80, K = I + 1, M - C( K, J ) = C( K, J ) + TEMP1 *A( K, I ) - TEMP2 = TEMP2 + B( K, J )*A( K, I ) - 80 CONTINUE - IF( BETA.EQ.ZERO )THEN - C( I, J ) = TEMP1*A( I, I ) + ALPHA*TEMP2 - ELSE - C( I, J ) = BETA *C( I, J ) + - $ TEMP1*A( I, I ) + ALPHA*TEMP2 - END IF - 90 CONTINUE - 100 CONTINUE - END IF - ELSE -* -* Form C := alpha*B*A + beta*C. -* - DO 170, J = 1, N - TEMP1 = ALPHA*A( J, J ) - IF( BETA.EQ.ZERO )THEN - DO 110, I = 1, M - C( I, J ) = TEMP1*B( I, J ) - 110 CONTINUE - ELSE - DO 120, I = 1, M - C( I, J ) = BETA*C( I, J ) + TEMP1*B( I, J ) - 120 CONTINUE - END IF - DO 140, K = 1, J - 1 - IF( UPPER )THEN - TEMP1 = ALPHA*A( K, J ) - ELSE - TEMP1 = ALPHA*A( J, K ) - END IF - DO 130, I = 1, M - C( I, J ) = C( I, J ) + TEMP1*B( I, K ) - 130 CONTINUE - 140 CONTINUE - DO 160, K = J + 1, N - IF( UPPER )THEN - TEMP1 = ALPHA*A( J, K ) - ELSE - TEMP1 = ALPHA*A( K, J ) - END IF - DO 150, I = 1, M - C( I, J ) = C( I, J ) + TEMP1*B( I, K ) - 150 CONTINUE - 160 CONTINUE - 170 CONTINUE - END IF -* - RETURN -* -* End of ZSYMM . -* - END diff --git a/src/lib/blas/zsyr2k.f b/src/lib/blas/zsyr2k.f deleted file mode 100644 index aba2071a..00000000 --- a/src/lib/blas/zsyr2k.f +++ /dev/null @@ -1,324 +0,0 @@ - SUBROUTINE ZSYR2K( UPLO, TRANS, N, K, ALPHA, A, LDA, B, LDB, - $ BETA, C, LDC ) -* .. Scalar Arguments .. - CHARACTER*1 UPLO, TRANS - INTEGER N, K, LDA, LDB, LDC - COMPLEX*16 ALPHA, BETA -* .. Array Arguments .. - COMPLEX*16 A( LDA, * ), B( LDB, * ), C( LDC, * ) -* .. -* -* Purpose -* ======= -* -* ZSYR2K performs one of the symmetric rank 2k operations -* -* C := alpha*A*B' + alpha*B*A' + beta*C, -* -* or -* -* C := alpha*A'*B + alpha*B'*A + beta*C, -* -* where alpha and beta are scalars, C is an n by n symmetric matrix -* and A and B are n by k matrices in the first case and k by n -* matrices in the second case. -* -* 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*16 . -* On entry, ALPHA specifies the scalar alpha. -* Unchanged on exit. -* -* A - COMPLEX*16 array of DIMENSION ( LDA, ka ), where ka is -* k when TRANS = 'N' or 'n', and is n otherwise. -* Before entry with TRANS = 'N' or 'n', the leading n by k -* part of the array A must contain the matrix A, otherwise -* the leading k by n part of the array A must contain the -* matrix A. -* Unchanged on exit. -* -* LDA - INTEGER. -* On entry, LDA specifies the first dimension of A as declared -* in the calling (sub) program. When TRANS = 'N' or 'n' -* then LDA must be at least max( 1, n ), otherwise LDA must -* be at least max( 1, k ). -* Unchanged on exit. -* -* B - COMPLEX*16 array of DIMENSION ( LDB, kb ), where kb is -* k when TRANS = 'N' or 'n', and is n otherwise. -* Before entry with TRANS = 'N' or 'n', the leading n by k -* part of the array B must contain the matrix B, otherwise -* the leading k by n part of the array B must contain the -* matrix B. -* Unchanged on exit. -* -* LDB - INTEGER. -* On entry, LDB specifies the first dimension of B as declared -* in the calling (sub) program. When TRANS = 'N' or 'n' -* then LDB must be at least max( 1, n ), otherwise LDB must -* be at least max( 1, k ). -* Unchanged on exit. -* -* BETA - COMPLEX*16 . -* On entry, BETA specifies the scalar beta. -* Unchanged on exit. -* -* C - COMPLEX*16 array of DIMENSION ( LDC, n ). -* Before entry with UPLO = 'U' or 'u', the leading n by n -* upper triangular part of the array C must contain the upper -* triangular part of the symmetric matrix and the strictly -* lower triangular part of C is not referenced. On exit, the -* upper triangular part of the array C is overwritten by the -* upper triangular part of the updated matrix. -* Before entry with UPLO = 'L' or 'l', the leading n by n -* lower triangular part of the array C must contain the lower -* triangular part of the symmetric matrix and the strictly -* upper triangular part of C is not referenced. On exit, the -* lower triangular part of the array C is overwritten by the -* lower triangular part of the updated matrix. -* -* LDC - INTEGER. -* On entry, LDC specifies the first dimension of C as declared -* in the calling (sub) program. LDC must be at least -* max( 1, n ). -* Unchanged on exit. -* -* -* Level 3 Blas routine. -* -* -- Written on 8-February-1989. -* Jack Dongarra, Argonne National Laboratory. -* Iain Duff, AERE Harwell. -* Jeremy Du Croz, Numerical Algorithms Group Ltd. -* Sven Hammarling, Numerical Algorithms Group Ltd. -* -* -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. External Subroutines .. - EXTERNAL XERBLA -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. Local Scalars .. - LOGICAL UPPER - INTEGER I, INFO, J, L, NROWA - COMPLEX*16 TEMP1, TEMP2 -* .. Parameters .. - COMPLEX*16 ONE - PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) ) - COMPLEX*16 ZERO - PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) ) -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - IF( LSAME( TRANS, 'N' ) )THEN - NROWA = N - ELSE - NROWA = K - END IF - UPPER = LSAME( UPLO, 'U' ) -* - INFO = 0 - IF( ( .NOT.UPPER ).AND. - $ ( .NOT.LSAME( UPLO , 'L' ) ) )THEN - INFO = 1 - ELSE IF( ( .NOT.LSAME( TRANS, 'N' ) ).AND. - $ ( .NOT.LSAME( TRANS, 'T' ) ) )THEN - INFO = 2 - ELSE IF( N .LT.0 )THEN - INFO = 3 - ELSE IF( K .LT.0 )THEN - INFO = 4 - ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN - INFO = 7 - ELSE IF( LDB.LT.MAX( 1, NROWA ) )THEN - INFO = 9 - ELSE IF( LDC.LT.MAX( 1, N ) )THEN - INFO = 12 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'ZSYR2K', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( ( N.EQ.0 ).OR. - $ ( ( ( ALPHA.EQ.ZERO ).OR.( K.EQ.0 ) ).AND.( BETA.EQ.ONE ) ) ) - $ RETURN -* -* And when alpha.eq.zero. -* - IF( ALPHA.EQ.ZERO )THEN - IF( UPPER )THEN - IF( BETA.EQ.ZERO )THEN - DO 20, J = 1, N - DO 10, I = 1, J - C( I, J ) = ZERO - 10 CONTINUE - 20 CONTINUE - ELSE - DO 40, J = 1, N - DO 30, I = 1, J - C( I, J ) = BETA*C( I, J ) - 30 CONTINUE - 40 CONTINUE - END IF - ELSE - IF( BETA.EQ.ZERO )THEN - DO 60, J = 1, N - DO 50, I = J, N - C( I, J ) = ZERO - 50 CONTINUE - 60 CONTINUE - ELSE - DO 80, J = 1, N - DO 70, I = J, N - C( I, J ) = BETA*C( I, J ) - 70 CONTINUE - 80 CONTINUE - END IF - END IF - RETURN - END IF -* -* Start the operations. -* - IF( LSAME( TRANS, 'N' ) )THEN -* -* Form C := alpha*A*B' + alpha*B*A' + C. -* - IF( UPPER )THEN - DO 130, J = 1, N - IF( BETA.EQ.ZERO )THEN - DO 90, I = 1, J - C( I, J ) = ZERO - 90 CONTINUE - ELSE IF( BETA.NE.ONE )THEN - DO 100, I = 1, J - C( I, J ) = BETA*C( I, J ) - 100 CONTINUE - END IF - DO 120, L = 1, K - IF( ( A( J, L ).NE.ZERO ).OR. - $ ( B( J, L ).NE.ZERO ) )THEN - TEMP1 = ALPHA*B( J, L ) - TEMP2 = ALPHA*A( J, L ) - DO 110, I = 1, J - C( I, J ) = C( I, J ) + A( I, L )*TEMP1 + - $ B( I, L )*TEMP2 - 110 CONTINUE - END IF - 120 CONTINUE - 130 CONTINUE - ELSE - DO 180, J = 1, N - IF( BETA.EQ.ZERO )THEN - DO 140, I = J, N - C( I, J ) = ZERO - 140 CONTINUE - ELSE IF( BETA.NE.ONE )THEN - DO 150, I = J, N - C( I, J ) = BETA*C( I, J ) - 150 CONTINUE - END IF - DO 170, L = 1, K - IF( ( A( J, L ).NE.ZERO ).OR. - $ ( B( J, L ).NE.ZERO ) )THEN - TEMP1 = ALPHA*B( J, L ) - TEMP2 = ALPHA*A( J, L ) - DO 160, I = J, N - C( I, J ) = C( I, J ) + A( I, L )*TEMP1 + - $ B( I, L )*TEMP2 - 160 CONTINUE - END IF - 170 CONTINUE - 180 CONTINUE - END IF - ELSE -* -* Form C := alpha*A'*B + alpha*B'*A + C. -* - IF( UPPER )THEN - DO 210, J = 1, N - DO 200, I = 1, J - TEMP1 = ZERO - TEMP2 = ZERO - DO 190, L = 1, K - TEMP1 = TEMP1 + A( L, I )*B( L, J ) - TEMP2 = TEMP2 + B( L, I )*A( L, J ) - 190 CONTINUE - IF( BETA.EQ.ZERO )THEN - C( I, J ) = ALPHA*TEMP1 + ALPHA*TEMP2 - ELSE - C( I, J ) = BETA *C( I, J ) + - $ ALPHA*TEMP1 + ALPHA*TEMP2 - END IF - 200 CONTINUE - 210 CONTINUE - ELSE - DO 240, J = 1, N - DO 230, I = J, N - TEMP1 = ZERO - TEMP2 = ZERO - DO 220, L = 1, K - TEMP1 = TEMP1 + A( L, I )*B( L, J ) - TEMP2 = TEMP2 + B( L, I )*A( L, J ) - 220 CONTINUE - IF( BETA.EQ.ZERO )THEN - C( I, J ) = ALPHA*TEMP1 + ALPHA*TEMP2 - ELSE - C( I, J ) = BETA *C( I, J ) + - $ ALPHA*TEMP1 + ALPHA*TEMP2 - END IF - 230 CONTINUE - 240 CONTINUE - END IF - END IF -* - RETURN -* -* End of ZSYR2K. -* - END diff --git a/src/lib/blas/zsyrk.f b/src/lib/blas/zsyrk.f deleted file mode 100644 index 77e2c20a..00000000 --- a/src/lib/blas/zsyrk.f +++ /dev/null @@ -1,293 +0,0 @@ - SUBROUTINE ZSYRK ( UPLO, TRANS, N, K, ALPHA, A, LDA, - $ BETA, C, LDC ) -* .. Scalar Arguments .. - CHARACTER*1 UPLO, TRANS - INTEGER N, K, LDA, LDC - COMPLEX*16 ALPHA, BETA -* .. Array Arguments .. - COMPLEX*16 A( LDA, * ), C( LDC, * ) -* .. -* -* Purpose -* ======= -* -* ZSYRK performs one of the symmetric rank k operations -* -* C := alpha*A*A' + beta*C, -* -* or -* -* C := alpha*A'*A + beta*C, -* -* where alpha and beta are scalars, C is an n by n symmetric matrix -* and A is an n by k matrix in the first case and a k by n matrix -* in the second case. -* -* 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*16 . -* On entry, ALPHA specifies the scalar alpha. -* Unchanged on exit. -* -* A - COMPLEX*16 array of DIMENSION ( LDA, ka ), where ka is -* k when TRANS = 'N' or 'n', and is n otherwise. -* Before entry with TRANS = 'N' or 'n', the leading n by k -* part of the array A must contain the matrix A, otherwise -* the leading k by n part of the array A must contain the -* matrix A. -* Unchanged on exit. -* -* LDA - INTEGER. -* On entry, LDA specifies the first dimension of A as declared -* in the calling (sub) program. When TRANS = 'N' or 'n' -* then LDA must be at least max( 1, n ), otherwise LDA must -* be at least max( 1, k ). -* Unchanged on exit. -* -* BETA - COMPLEX*16 . -* On entry, BETA specifies the scalar beta. -* Unchanged on exit. -* -* C - COMPLEX*16 array of DIMENSION ( LDC, n ). -* Before entry with UPLO = 'U' or 'u', the leading n by n -* upper triangular part of the array C must contain the upper -* triangular part of the symmetric matrix and the strictly -* lower triangular part of C is not referenced. On exit, the -* upper triangular part of the array C is overwritten by the -* upper triangular part of the updated matrix. -* Before entry with UPLO = 'L' or 'l', the leading n by n -* lower triangular part of the array C must contain the lower -* triangular part of the symmetric matrix and the strictly -* upper triangular part of C is not referenced. On exit, the -* lower triangular part of the array C is overwritten by the -* lower triangular part of the updated matrix. -* -* LDC - INTEGER. -* On entry, LDC specifies the first dimension of C as declared -* in the calling (sub) program. LDC must be at least -* max( 1, n ). -* Unchanged on exit. -* -* -* Level 3 Blas routine. -* -* -- Written on 8-February-1989. -* Jack Dongarra, Argonne National Laboratory. -* Iain Duff, AERE Harwell. -* Jeremy Du Croz, Numerical Algorithms Group Ltd. -* Sven Hammarling, Numerical Algorithms Group Ltd. -* -* -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. External Subroutines .. - EXTERNAL XERBLA -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. Local Scalars .. - LOGICAL UPPER - INTEGER I, INFO, J, L, NROWA - COMPLEX*16 TEMP -* .. Parameters .. - COMPLEX*16 ONE - PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) ) - COMPLEX*16 ZERO - PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) ) -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - IF( LSAME( TRANS, 'N' ) )THEN - NROWA = N - ELSE - NROWA = K - END IF - UPPER = LSAME( UPLO, 'U' ) -* - INFO = 0 - IF( ( .NOT.UPPER ).AND. - $ ( .NOT.LSAME( UPLO , 'L' ) ) )THEN - INFO = 1 - ELSE IF( ( .NOT.LSAME( TRANS, 'N' ) ).AND. - $ ( .NOT.LSAME( TRANS, 'T' ) ) )THEN - INFO = 2 - ELSE IF( N .LT.0 )THEN - INFO = 3 - ELSE IF( K .LT.0 )THEN - INFO = 4 - ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN - INFO = 7 - ELSE IF( LDC.LT.MAX( 1, N ) )THEN - INFO = 10 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'ZSYRK ', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( ( N.EQ.0 ).OR. - $ ( ( ( ALPHA.EQ.ZERO ).OR.( K.EQ.0 ) ).AND.( BETA.EQ.ONE ) ) ) - $ RETURN -* -* And when alpha.eq.zero. -* - IF( ALPHA.EQ.ZERO )THEN - IF( UPPER )THEN - IF( BETA.EQ.ZERO )THEN - DO 20, J = 1, N - DO 10, I = 1, J - C( I, J ) = ZERO - 10 CONTINUE - 20 CONTINUE - ELSE - DO 40, J = 1, N - DO 30, I = 1, J - C( I, J ) = BETA*C( I, J ) - 30 CONTINUE - 40 CONTINUE - END IF - ELSE - IF( BETA.EQ.ZERO )THEN - DO 60, J = 1, N - DO 50, I = J, N - C( I, J ) = ZERO - 50 CONTINUE - 60 CONTINUE - ELSE - DO 80, J = 1, N - DO 70, I = J, N - C( I, J ) = BETA*C( I, J ) - 70 CONTINUE - 80 CONTINUE - END IF - END IF - RETURN - END IF -* -* Start the operations. -* - IF( LSAME( TRANS, 'N' ) )THEN -* -* Form C := alpha*A*A' + beta*C. -* - IF( UPPER )THEN - DO 130, J = 1, N - IF( BETA.EQ.ZERO )THEN - DO 90, I = 1, J - C( I, J ) = ZERO - 90 CONTINUE - ELSE IF( BETA.NE.ONE )THEN - DO 100, I = 1, J - C( I, J ) = BETA*C( I, J ) - 100 CONTINUE - END IF - DO 120, L = 1, K - IF( A( J, L ).NE.ZERO )THEN - TEMP = ALPHA*A( J, L ) - DO 110, I = 1, J - C( I, J ) = C( I, J ) + TEMP*A( I, L ) - 110 CONTINUE - END IF - 120 CONTINUE - 130 CONTINUE - ELSE - DO 180, J = 1, N - IF( BETA.EQ.ZERO )THEN - DO 140, I = J, N - C( I, J ) = ZERO - 140 CONTINUE - ELSE IF( BETA.NE.ONE )THEN - DO 150, I = J, N - C( I, J ) = BETA*C( I, J ) - 150 CONTINUE - END IF - DO 170, L = 1, K - IF( A( J, L ).NE.ZERO )THEN - TEMP = ALPHA*A( J, L ) - DO 160, I = J, N - C( I, J ) = C( I, J ) + TEMP*A( I, L ) - 160 CONTINUE - END IF - 170 CONTINUE - 180 CONTINUE - END IF - ELSE -* -* Form C := alpha*A'*A + beta*C. -* - IF( UPPER )THEN - DO 210, J = 1, N - DO 200, I = 1, J - TEMP = ZERO - DO 190, L = 1, K - TEMP = TEMP + A( L, I )*A( L, J ) - 190 CONTINUE - IF( BETA.EQ.ZERO )THEN - C( I, J ) = ALPHA*TEMP - ELSE - C( I, J ) = ALPHA*TEMP + BETA*C( I, J ) - END IF - 200 CONTINUE - 210 CONTINUE - ELSE - DO 240, J = 1, N - DO 230, I = J, N - TEMP = ZERO - DO 220, L = 1, K - TEMP = TEMP + A( L, I )*A( L, J ) - 220 CONTINUE - IF( BETA.EQ.ZERO )THEN - C( I, J ) = ALPHA*TEMP - ELSE - C( I, J ) = ALPHA*TEMP + BETA*C( I, J ) - END IF - 230 CONTINUE - 240 CONTINUE - END IF - END IF -* - RETURN -* -* End of ZSYRK . -* - END diff --git a/src/lib/blas/ztbmv.f b/src/lib/blas/ztbmv.f deleted file mode 100644 index 17944082..00000000 --- a/src/lib/blas/ztbmv.f +++ /dev/null @@ -1,377 +0,0 @@ - SUBROUTINE ZTBMV ( UPLO, TRANS, DIAG, N, K, A, LDA, X, INCX ) -* .. Scalar Arguments .. - INTEGER INCX, K, LDA, N - CHARACTER*1 DIAG, TRANS, UPLO -* .. Array Arguments .. - COMPLEX*16 A( LDA, * ), X( * ) -* .. -* -* Purpose -* ======= -* -* ZTBMV performs one of the matrix-vector operations -* -* x := A*x, or x := A'*x, or x := conjg( A' )*x, -* -* where x is an n element vector and A is an n by n unit, or non-unit, -* upper or lower triangular band matrix, with ( k + 1 ) diagonals. -* -* 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*16 array of DIMENSION ( LDA, n ). -* Before entry with UPLO = 'U' or 'u', the leading ( k + 1 ) -* by n part of the array A must contain the upper triangular -* band part of the matrix of coefficients, supplied column by -* column, with the leading diagonal of the matrix in row -* ( k + 1 ) of the array, the first super-diagonal starting at -* position 2 in row k, and so on. The top left k by k triangle -* of the array A is not referenced. -* The following program segment will transfer an upper -* triangular band matrix from conventional full matrix storage -* to band storage: -* -* DO 20, J = 1, N -* M = K + 1 - J -* DO 10, I = MAX( 1, J - K ), J -* A( M + I, J ) = matrix( I, J ) -* 10 CONTINUE -* 20 CONTINUE -* -* Before entry with UPLO = 'L' or 'l', the leading ( k + 1 ) -* by n part of the array A must contain the lower triangular -* band part of the matrix of coefficients, supplied column by -* column, with the leading diagonal of the matrix in row 1 of -* the array, the first sub-diagonal starting at position 1 in -* row 2, and so on. The bottom right k by k triangle of the -* array A is not referenced. -* The following program segment will transfer a lower -* triangular band matrix from conventional full matrix storage -* to band storage: -* -* DO 20, J = 1, N -* M = 1 - J -* DO 10, I = J, MIN( N, J + K ) -* A( M + I, J ) = matrix( I, J ) -* 10 CONTINUE -* 20 CONTINUE -* -* Note that when DIAG = 'U' or 'u' the elements of the array A -* corresponding to the diagonal elements of the matrix are not -* referenced, but are assumed to be unity. -* Unchanged on exit. -* -* LDA - INTEGER. -* On entry, LDA specifies the first dimension of A as declared -* in the calling (sub) program. LDA must be at least -* ( k + 1 ). -* Unchanged on exit. -* -* X - COMPLEX*16 array of dimension at least -* ( 1 + ( n - 1 )*abs( INCX ) ). -* Before entry, the incremented array X must contain the n -* element vector x. On exit, X is overwritten with the -* tranformed vector x. -* -* INCX - INTEGER. -* On entry, INCX specifies the increment for the elements of -* X. INCX must not be zero. -* Unchanged on exit. -* -* -* Level 2 Blas routine. -* -* -- Written on 22-October-1986. -* Jack Dongarra, Argonne National Lab. -* Jeremy Du Croz, Nag Central Office. -* Sven Hammarling, Nag Central Office. -* Richard Hanson, Sandia National Labs. -* -* -* .. Parameters .. - COMPLEX*16 ZERO - PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) ) -* .. Local Scalars .. - COMPLEX*16 TEMP - INTEGER I, INFO, IX, J, JX, KPLUS1, KX, L - LOGICAL NOCONJ, NOUNIT -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. External Subroutines .. - EXTERNAL XERBLA -* .. Intrinsic Functions .. - INTRINSIC DCONJG, MAX, MIN -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - IF ( .NOT.LSAME( UPLO , 'U' ).AND. - $ .NOT.LSAME( UPLO , 'L' ) )THEN - INFO = 1 - ELSE IF( .NOT.LSAME( TRANS, 'N' ).AND. - $ .NOT.LSAME( TRANS, 'T' ).AND. - $ .NOT.LSAME( TRANS, 'C' ) )THEN - INFO = 2 - ELSE IF( .NOT.LSAME( DIAG , 'U' ).AND. - $ .NOT.LSAME( DIAG , 'N' ) )THEN - INFO = 3 - ELSE IF( N.LT.0 )THEN - INFO = 4 - ELSE IF( K.LT.0 )THEN - INFO = 5 - ELSE IF( LDA.LT.( K + 1 ) )THEN - INFO = 7 - ELSE IF( INCX.EQ.0 )THEN - INFO = 9 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'ZTBMV ', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( N.EQ.0 ) - $ RETURN -* - NOCONJ = LSAME( TRANS, 'T' ) - NOUNIT = LSAME( DIAG , 'N' ) -* -* Set up the start point in X if the increment is not unity. This -* will be ( N - 1 )*INCX too small for descending loops. -* - IF( INCX.LE.0 )THEN - KX = 1 - ( N - 1 )*INCX - ELSE IF( INCX.NE.1 )THEN - KX = 1 - END IF -* -* Start the operations. In this version the elements of A are -* accessed sequentially with one pass through A. -* - IF( LSAME( TRANS, 'N' ) )THEN -* -* Form x := A*x. -* - IF( LSAME( UPLO, 'U' ) )THEN - KPLUS1 = K + 1 - IF( INCX.EQ.1 )THEN - DO 20, J = 1, N - IF( X( J ).NE.ZERO )THEN - TEMP = X( J ) - L = KPLUS1 - J - DO 10, I = MAX( 1, J - K ), J - 1 - X( I ) = X( I ) + TEMP*A( L + I, J ) - 10 CONTINUE - IF( NOUNIT ) - $ X( J ) = X( J )*A( KPLUS1, J ) - END IF - 20 CONTINUE - ELSE - JX = KX - DO 40, J = 1, N - IF( X( JX ).NE.ZERO )THEN - TEMP = X( JX ) - IX = KX - L = KPLUS1 - J - DO 30, I = MAX( 1, J - K ), J - 1 - X( IX ) = X( IX ) + TEMP*A( L + I, J ) - IX = IX + INCX - 30 CONTINUE - IF( NOUNIT ) - $ X( JX ) = X( JX )*A( KPLUS1, J ) - END IF - JX = JX + INCX - IF( J.GT.K ) - $ KX = KX + INCX - 40 CONTINUE - END IF - ELSE - IF( INCX.EQ.1 )THEN - DO 60, J = N, 1, -1 - IF( X( J ).NE.ZERO )THEN - TEMP = X( J ) - L = 1 - J - DO 50, I = MIN( N, J + K ), J + 1, -1 - X( I ) = X( I ) + TEMP*A( L + I, J ) - 50 CONTINUE - IF( NOUNIT ) - $ X( J ) = X( J )*A( 1, J ) - END IF - 60 CONTINUE - ELSE - KX = KX + ( N - 1 )*INCX - JX = KX - DO 80, J = N, 1, -1 - IF( X( JX ).NE.ZERO )THEN - TEMP = X( JX ) - IX = KX - L = 1 - J - DO 70, I = MIN( N, J + K ), J + 1, -1 - X( IX ) = X( IX ) + TEMP*A( L + I, J ) - IX = IX - INCX - 70 CONTINUE - IF( NOUNIT ) - $ X( JX ) = X( JX )*A( 1, J ) - END IF - JX = JX - INCX - IF( ( N - J ).GE.K ) - $ KX = KX - INCX - 80 CONTINUE - END IF - END IF - ELSE -* -* Form x := A'*x or x := conjg( A' )*x. -* - IF( LSAME( UPLO, 'U' ) )THEN - KPLUS1 = K + 1 - IF( INCX.EQ.1 )THEN - DO 110, J = N, 1, -1 - TEMP = X( J ) - L = KPLUS1 - J - IF( NOCONJ )THEN - IF( NOUNIT ) - $ TEMP = TEMP*A( KPLUS1, J ) - DO 90, I = J - 1, MAX( 1, J - K ), -1 - TEMP = TEMP + A( L + I, J )*X( I ) - 90 CONTINUE - ELSE - IF( NOUNIT ) - $ TEMP = TEMP*DCONJG( A( KPLUS1, J ) ) - DO 100, I = J - 1, MAX( 1, J - K ), -1 - TEMP = TEMP + DCONJG( A( L + I, J ) )*X( I ) - 100 CONTINUE - END IF - X( J ) = TEMP - 110 CONTINUE - ELSE - KX = KX + ( N - 1 )*INCX - JX = KX - DO 140, J = N, 1, -1 - TEMP = X( JX ) - KX = KX - INCX - IX = KX - L = KPLUS1 - J - IF( NOCONJ )THEN - IF( NOUNIT ) - $ TEMP = TEMP*A( KPLUS1, J ) - DO 120, I = J - 1, MAX( 1, J - K ), -1 - TEMP = TEMP + A( L + I, J )*X( IX ) - IX = IX - INCX - 120 CONTINUE - ELSE - IF( NOUNIT ) - $ TEMP = TEMP*DCONJG( A( KPLUS1, J ) ) - DO 130, I = J - 1, MAX( 1, J - K ), -1 - TEMP = TEMP + DCONJG( A( L + I, J ) )*X( IX ) - IX = IX - INCX - 130 CONTINUE - END IF - X( JX ) = TEMP - JX = JX - INCX - 140 CONTINUE - END IF - ELSE - IF( INCX.EQ.1 )THEN - DO 170, J = 1, N - TEMP = X( J ) - L = 1 - J - IF( NOCONJ )THEN - IF( NOUNIT ) - $ TEMP = TEMP*A( 1, J ) - DO 150, I = J + 1, MIN( N, J + K ) - TEMP = TEMP + A( L + I, J )*X( I ) - 150 CONTINUE - ELSE - IF( NOUNIT ) - $ TEMP = TEMP*DCONJG( A( 1, J ) ) - DO 160, I = J + 1, MIN( N, J + K ) - TEMP = TEMP + DCONJG( A( L + I, J ) )*X( I ) - 160 CONTINUE - END IF - X( J ) = TEMP - 170 CONTINUE - ELSE - JX = KX - DO 200, J = 1, N - TEMP = X( JX ) - KX = KX + INCX - IX = KX - L = 1 - J - IF( NOCONJ )THEN - IF( NOUNIT ) - $ TEMP = TEMP*A( 1, J ) - DO 180, I = J + 1, MIN( N, J + K ) - TEMP = TEMP + A( L + I, J )*X( IX ) - IX = IX + INCX - 180 CONTINUE - ELSE - IF( NOUNIT ) - $ TEMP = TEMP*DCONJG( A( 1, J ) ) - DO 190, I = J + 1, MIN( N, J + K ) - TEMP = TEMP + DCONJG( A( L + I, J ) )*X( IX ) - IX = IX + INCX - 190 CONTINUE - END IF - X( JX ) = TEMP - JX = JX + INCX - 200 CONTINUE - END IF - END IF - END IF -* - RETURN -* -* End of ZTBMV . -* - END diff --git a/src/lib/blas/ztbsv.f b/src/lib/blas/ztbsv.f deleted file mode 100644 index f3ded819..00000000 --- a/src/lib/blas/ztbsv.f +++ /dev/null @@ -1,381 +0,0 @@ - SUBROUTINE ZTBSV ( UPLO, TRANS, DIAG, N, K, A, LDA, X, INCX ) -* .. Scalar Arguments .. - INTEGER INCX, K, LDA, N - CHARACTER*1 DIAG, TRANS, UPLO -* .. Array Arguments .. - COMPLEX*16 A( LDA, * ), X( * ) -* .. -* -* Purpose -* ======= -* -* ZTBSV solves one of the systems of equations -* -* A*x = b, or A'*x = b, or conjg( A' )*x = b, -* -* where b and x are n element vectors and A is an n by n unit, or -* non-unit, upper or lower triangular band matrix, with ( k + 1 ) -* diagonals. -* -* No test for singularity or near-singularity is included in this -* routine. Such tests must be performed before calling this routine. -* -* 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*16 array of DIMENSION ( LDA, n ). -* Before entry with UPLO = 'U' or 'u', the leading ( k + 1 ) -* by n part of the array A must contain the upper triangular -* band part of the matrix of coefficients, supplied column by -* column, with the leading diagonal of the matrix in row -* ( k + 1 ) of the array, the first super-diagonal starting at -* position 2 in row k, and so on. The top left k by k triangle -* of the array A is not referenced. -* The following program segment will transfer an upper -* triangular band matrix from conventional full matrix storage -* to band storage: -* -* DO 20, J = 1, N -* M = K + 1 - J -* DO 10, I = MAX( 1, J - K ), J -* A( M + I, J ) = matrix( I, J ) -* 10 CONTINUE -* 20 CONTINUE -* -* Before entry with UPLO = 'L' or 'l', the leading ( k + 1 ) -* by n part of the array A must contain the lower triangular -* band part of the matrix of coefficients, supplied column by -* column, with the leading diagonal of the matrix in row 1 of -* the array, the first sub-diagonal starting at position 1 in -* row 2, and so on. The bottom right k by k triangle of the -* array A is not referenced. -* The following program segment will transfer a lower -* triangular band matrix from conventional full matrix storage -* to band storage: -* -* DO 20, J = 1, N -* M = 1 - J -* DO 10, I = J, MIN( N, J + K ) -* A( M + I, J ) = matrix( I, J ) -* 10 CONTINUE -* 20 CONTINUE -* -* Note that when DIAG = 'U' or 'u' the elements of the array A -* corresponding to the diagonal elements of the matrix are not -* referenced, but are assumed to be unity. -* Unchanged on exit. -* -* LDA - INTEGER. -* On entry, LDA specifies the first dimension of A as declared -* in the calling (sub) program. LDA must be at least -* ( k + 1 ). -* Unchanged on exit. -* -* X - COMPLEX*16 array of dimension at least -* ( 1 + ( n - 1 )*abs( INCX ) ). -* Before entry, the incremented array X must contain the n -* element right-hand side vector b. On exit, X is overwritten -* with the solution vector x. -* -* INCX - INTEGER. -* On entry, INCX specifies the increment for the elements of -* X. INCX must not be zero. -* Unchanged on exit. -* -* -* Level 2 Blas routine. -* -* -- Written on 22-October-1986. -* Jack Dongarra, Argonne National Lab. -* Jeremy Du Croz, Nag Central Office. -* Sven Hammarling, Nag Central Office. -* Richard Hanson, Sandia National Labs. -* -* -* .. Parameters .. - COMPLEX*16 ZERO - PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) ) -* .. Local Scalars .. - COMPLEX*16 TEMP - INTEGER I, INFO, IX, J, JX, KPLUS1, KX, L - LOGICAL NOCONJ, NOUNIT -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. External Subroutines .. - EXTERNAL XERBLA -* .. Intrinsic Functions .. - INTRINSIC DCONJG, MAX, MIN -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - IF ( .NOT.LSAME( UPLO , 'U' ).AND. - $ .NOT.LSAME( UPLO , 'L' ) )THEN - INFO = 1 - ELSE IF( .NOT.LSAME( TRANS, 'N' ).AND. - $ .NOT.LSAME( TRANS, 'T' ).AND. - $ .NOT.LSAME( TRANS, 'C' ) )THEN - INFO = 2 - ELSE IF( .NOT.LSAME( DIAG , 'U' ).AND. - $ .NOT.LSAME( DIAG , 'N' ) )THEN - INFO = 3 - ELSE IF( N.LT.0 )THEN - INFO = 4 - ELSE IF( K.LT.0 )THEN - INFO = 5 - ELSE IF( LDA.LT.( K + 1 ) )THEN - INFO = 7 - ELSE IF( INCX.EQ.0 )THEN - INFO = 9 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'ZTBSV ', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( N.EQ.0 ) - $ RETURN -* - NOCONJ = LSAME( TRANS, 'T' ) - NOUNIT = LSAME( DIAG , 'N' ) -* -* Set up the start point in X if the increment is not unity. This -* will be ( N - 1 )*INCX too small for descending loops. -* - IF( INCX.LE.0 )THEN - KX = 1 - ( N - 1 )*INCX - ELSE IF( INCX.NE.1 )THEN - KX = 1 - END IF -* -* Start the operations. In this version the elements of A are -* accessed by sequentially with one pass through A. -* - IF( LSAME( TRANS, 'N' ) )THEN -* -* Form x := inv( A )*x. -* - IF( LSAME( UPLO, 'U' ) )THEN - KPLUS1 = K + 1 - IF( INCX.EQ.1 )THEN - DO 20, J = N, 1, -1 - IF( X( J ).NE.ZERO )THEN - L = KPLUS1 - J - IF( NOUNIT ) - $ X( J ) = X( J )/A( KPLUS1, J ) - TEMP = X( J ) - DO 10, I = J - 1, MAX( 1, J - K ), -1 - X( I ) = X( I ) - TEMP*A( L + I, J ) - 10 CONTINUE - END IF - 20 CONTINUE - ELSE - KX = KX + ( N - 1 )*INCX - JX = KX - DO 40, J = N, 1, -1 - KX = KX - INCX - IF( X( JX ).NE.ZERO )THEN - IX = KX - L = KPLUS1 - J - IF( NOUNIT ) - $ X( JX ) = X( JX )/A( KPLUS1, J ) - TEMP = X( JX ) - DO 30, I = J - 1, MAX( 1, J - K ), -1 - X( IX ) = X( IX ) - TEMP*A( L + I, J ) - IX = IX - INCX - 30 CONTINUE - END IF - JX = JX - INCX - 40 CONTINUE - END IF - ELSE - IF( INCX.EQ.1 )THEN - DO 60, J = 1, N - IF( X( J ).NE.ZERO )THEN - L = 1 - J - IF( NOUNIT ) - $ X( J ) = X( J )/A( 1, J ) - TEMP = X( J ) - DO 50, I = J + 1, MIN( N, J + K ) - X( I ) = X( I ) - TEMP*A( L + I, J ) - 50 CONTINUE - END IF - 60 CONTINUE - ELSE - JX = KX - DO 80, J = 1, N - KX = KX + INCX - IF( X( JX ).NE.ZERO )THEN - IX = KX - L = 1 - J - IF( NOUNIT ) - $ X( JX ) = X( JX )/A( 1, J ) - TEMP = X( JX ) - DO 70, I = J + 1, MIN( N, J + K ) - X( IX ) = X( IX ) - TEMP*A( L + I, J ) - IX = IX + INCX - 70 CONTINUE - END IF - JX = JX + INCX - 80 CONTINUE - END IF - END IF - ELSE -* -* Form x := inv( A' )*x or x := inv( conjg( A') )*x. -* - IF( LSAME( UPLO, 'U' ) )THEN - KPLUS1 = K + 1 - IF( INCX.EQ.1 )THEN - DO 110, J = 1, N - TEMP = X( J ) - L = KPLUS1 - J - IF( NOCONJ )THEN - DO 90, I = MAX( 1, J - K ), J - 1 - TEMP = TEMP - A( L + I, J )*X( I ) - 90 CONTINUE - IF( NOUNIT ) - $ TEMP = TEMP/A( KPLUS1, J ) - ELSE - DO 100, I = MAX( 1, J - K ), J - 1 - TEMP = TEMP - DCONJG( A( L + I, J ) )*X( I ) - 100 CONTINUE - IF( NOUNIT ) - $ TEMP = TEMP/DCONJG( A( KPLUS1, J ) ) - END IF - X( J ) = TEMP - 110 CONTINUE - ELSE - JX = KX - DO 140, J = 1, N - TEMP = X( JX ) - IX = KX - L = KPLUS1 - J - IF( NOCONJ )THEN - DO 120, I = MAX( 1, J - K ), J - 1 - TEMP = TEMP - A( L + I, J )*X( IX ) - IX = IX + INCX - 120 CONTINUE - IF( NOUNIT ) - $ TEMP = TEMP/A( KPLUS1, J ) - ELSE - DO 130, I = MAX( 1, J - K ), J - 1 - TEMP = TEMP - DCONJG( A( L + I, J ) )*X( IX ) - IX = IX + INCX - 130 CONTINUE - IF( NOUNIT ) - $ TEMP = TEMP/DCONJG( A( KPLUS1, J ) ) - END IF - X( JX ) = TEMP - JX = JX + INCX - IF( J.GT.K ) - $ KX = KX + INCX - 140 CONTINUE - END IF - ELSE - IF( INCX.EQ.1 )THEN - DO 170, J = N, 1, -1 - TEMP = X( J ) - L = 1 - J - IF( NOCONJ )THEN - DO 150, I = MIN( N, J + K ), J + 1, -1 - TEMP = TEMP - A( L + I, J )*X( I ) - 150 CONTINUE - IF( NOUNIT ) - $ TEMP = TEMP/A( 1, J ) - ELSE - DO 160, I = MIN( N, J + K ), J + 1, -1 - TEMP = TEMP - DCONJG( A( L + I, J ) )*X( I ) - 160 CONTINUE - IF( NOUNIT ) - $ TEMP = TEMP/DCONJG( A( 1, J ) ) - END IF - X( J ) = TEMP - 170 CONTINUE - ELSE - KX = KX + ( N - 1 )*INCX - JX = KX - DO 200, J = N, 1, -1 - TEMP = X( JX ) - IX = KX - L = 1 - J - IF( NOCONJ )THEN - DO 180, I = MIN( N, J + K ), J + 1, -1 - TEMP = TEMP - A( L + I, J )*X( IX ) - IX = IX - INCX - 180 CONTINUE - IF( NOUNIT ) - $ TEMP = TEMP/A( 1, J ) - ELSE - DO 190, I = MIN( N, J + K ), J + 1, -1 - TEMP = TEMP - DCONJG( A( L + I, J ) )*X( IX ) - IX = IX - INCX - 190 CONTINUE - IF( NOUNIT ) - $ TEMP = TEMP/DCONJG( A( 1, J ) ) - END IF - X( JX ) = TEMP - JX = JX - INCX - IF( ( N - J ).GE.K ) - $ KX = KX - INCX - 200 CONTINUE - END IF - END IF - END IF -* - RETURN -* -* End of ZTBSV . -* - END diff --git a/src/lib/blas/ztpmv.f b/src/lib/blas/ztpmv.f deleted file mode 100644 index 4fad3a8b..00000000 --- a/src/lib/blas/ztpmv.f +++ /dev/null @@ -1,338 +0,0 @@ - SUBROUTINE ZTPMV ( UPLO, TRANS, DIAG, N, AP, X, INCX ) -* .. Scalar Arguments .. - INTEGER INCX, N - CHARACTER*1 DIAG, TRANS, UPLO -* .. Array Arguments .. - COMPLEX*16 AP( * ), X( * ) -* .. -* -* Purpose -* ======= -* -* ZTPMV performs one of the matrix-vector operations -* -* x := A*x, or x := A'*x, or x := conjg( A' )*x, -* -* where x is an n element vector and A is an n by n unit, or non-unit, -* upper or lower triangular matrix, supplied in packed form. -* -* 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*16 array of DIMENSION at least -* ( ( n*( n + 1 ) )/2 ). -* Before entry with UPLO = 'U' or 'u', the array AP must -* contain the upper triangular matrix packed sequentially, -* column by column, so that AP( 1 ) contains a( 1, 1 ), -* AP( 2 ) and AP( 3 ) contain a( 1, 2 ) and a( 2, 2 ) -* respectively, and so on. -* Before entry with UPLO = 'L' or 'l', the array AP must -* contain the lower triangular matrix packed sequentially, -* column by column, so that AP( 1 ) contains a( 1, 1 ), -* AP( 2 ) and AP( 3 ) contain a( 2, 1 ) and a( 3, 1 ) -* respectively, and so on. -* Note that when DIAG = 'U' or 'u', the diagonal elements of -* A are not referenced, but are assumed to be unity. -* Unchanged on exit. -* -* X - COMPLEX*16 array of dimension at least -* ( 1 + ( n - 1 )*abs( INCX ) ). -* Before entry, the incremented array X must contain the n -* element vector x. On exit, X is overwritten with the -* tranformed vector x. -* -* INCX - INTEGER. -* On entry, INCX specifies the increment for the elements of -* X. INCX must not be zero. -* Unchanged on exit. -* -* -* Level 2 Blas routine. -* -* -- Written on 22-October-1986. -* Jack Dongarra, Argonne National Lab. -* Jeremy Du Croz, Nag Central Office. -* Sven Hammarling, Nag Central Office. -* Richard Hanson, Sandia National Labs. -* -* -* .. Parameters .. - COMPLEX*16 ZERO - PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) ) -* .. Local Scalars .. - COMPLEX*16 TEMP - INTEGER I, INFO, IX, J, JX, K, KK, KX - LOGICAL NOCONJ, NOUNIT -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. External Subroutines .. - EXTERNAL XERBLA -* .. Intrinsic Functions .. - INTRINSIC DCONJG -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - IF ( .NOT.LSAME( UPLO , 'U' ).AND. - $ .NOT.LSAME( UPLO , 'L' ) )THEN - INFO = 1 - ELSE IF( .NOT.LSAME( TRANS, 'N' ).AND. - $ .NOT.LSAME( TRANS, 'T' ).AND. - $ .NOT.LSAME( TRANS, 'C' ) )THEN - INFO = 2 - ELSE IF( .NOT.LSAME( DIAG , 'U' ).AND. - $ .NOT.LSAME( DIAG , 'N' ) )THEN - INFO = 3 - ELSE IF( N.LT.0 )THEN - INFO = 4 - ELSE IF( INCX.EQ.0 )THEN - INFO = 7 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'ZTPMV ', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( N.EQ.0 ) - $ RETURN -* - NOCONJ = LSAME( TRANS, 'T' ) - NOUNIT = LSAME( DIAG , 'N' ) -* -* Set up the start point in X if the increment is not unity. This -* will be ( N - 1 )*INCX too small for descending loops. -* - IF( INCX.LE.0 )THEN - KX = 1 - ( N - 1 )*INCX - ELSE IF( INCX.NE.1 )THEN - KX = 1 - END IF -* -* Start the operations. In this version the elements of AP are -* accessed sequentially with one pass through AP. -* - IF( LSAME( TRANS, 'N' ) )THEN -* -* Form x:= A*x. -* - IF( LSAME( UPLO, 'U' ) )THEN - KK = 1 - IF( INCX.EQ.1 )THEN - DO 20, J = 1, N - IF( X( J ).NE.ZERO )THEN - TEMP = X( J ) - K = KK - DO 10, I = 1, J - 1 - X( I ) = X( I ) + TEMP*AP( K ) - K = K + 1 - 10 CONTINUE - IF( NOUNIT ) - $ X( J ) = X( J )*AP( KK + J - 1 ) - END IF - KK = KK + J - 20 CONTINUE - ELSE - JX = KX - DO 40, J = 1, N - IF( X( JX ).NE.ZERO )THEN - TEMP = X( JX ) - IX = KX - DO 30, K = KK, KK + J - 2 - X( IX ) = X( IX ) + TEMP*AP( K ) - IX = IX + INCX - 30 CONTINUE - IF( NOUNIT ) - $ X( JX ) = X( JX )*AP( KK + J - 1 ) - END IF - JX = JX + INCX - KK = KK + J - 40 CONTINUE - END IF - ELSE - KK = ( N*( N + 1 ) )/2 - IF( INCX.EQ.1 )THEN - DO 60, J = N, 1, -1 - IF( X( J ).NE.ZERO )THEN - TEMP = X( J ) - K = KK - DO 50, I = N, J + 1, -1 - X( I ) = X( I ) + TEMP*AP( K ) - K = K - 1 - 50 CONTINUE - IF( NOUNIT ) - $ X( J ) = X( J )*AP( KK - N + J ) - END IF - KK = KK - ( N - J + 1 ) - 60 CONTINUE - ELSE - KX = KX + ( N - 1 )*INCX - JX = KX - DO 80, J = N, 1, -1 - IF( X( JX ).NE.ZERO )THEN - TEMP = X( JX ) - IX = KX - DO 70, K = KK, KK - ( N - ( J + 1 ) ), -1 - X( IX ) = X( IX ) + TEMP*AP( K ) - IX = IX - INCX - 70 CONTINUE - IF( NOUNIT ) - $ X( JX ) = X( JX )*AP( KK - N + J ) - END IF - JX = JX - INCX - KK = KK - ( N - J + 1 ) - 80 CONTINUE - END IF - END IF - ELSE -* -* Form x := A'*x or x := conjg( A' )*x. -* - IF( LSAME( UPLO, 'U' ) )THEN - KK = ( N*( N + 1 ) )/2 - IF( INCX.EQ.1 )THEN - DO 110, J = N, 1, -1 - TEMP = X( J ) - K = KK - 1 - IF( NOCONJ )THEN - IF( NOUNIT ) - $ TEMP = TEMP*AP( KK ) - DO 90, I = J - 1, 1, -1 - TEMP = TEMP + AP( K )*X( I ) - K = K - 1 - 90 CONTINUE - ELSE - IF( NOUNIT ) - $ TEMP = TEMP*DCONJG( AP( KK ) ) - DO 100, I = J - 1, 1, -1 - TEMP = TEMP + DCONJG( AP( K ) )*X( I ) - K = K - 1 - 100 CONTINUE - END IF - X( J ) = TEMP - KK = KK - J - 110 CONTINUE - ELSE - JX = KX + ( N - 1 )*INCX - DO 140, J = N, 1, -1 - TEMP = X( JX ) - IX = JX - IF( NOCONJ )THEN - IF( NOUNIT ) - $ TEMP = TEMP*AP( KK ) - DO 120, K = KK - 1, KK - J + 1, -1 - IX = IX - INCX - TEMP = TEMP + AP( K )*X( IX ) - 120 CONTINUE - ELSE - IF( NOUNIT ) - $ TEMP = TEMP*DCONJG( AP( KK ) ) - DO 130, K = KK - 1, KK - J + 1, -1 - IX = IX - INCX - TEMP = TEMP + DCONJG( AP( K ) )*X( IX ) - 130 CONTINUE - END IF - X( JX ) = TEMP - JX = JX - INCX - KK = KK - J - 140 CONTINUE - END IF - ELSE - KK = 1 - IF( INCX.EQ.1 )THEN - DO 170, J = 1, N - TEMP = X( J ) - K = KK + 1 - IF( NOCONJ )THEN - IF( NOUNIT ) - $ TEMP = TEMP*AP( KK ) - DO 150, I = J + 1, N - TEMP = TEMP + AP( K )*X( I ) - K = K + 1 - 150 CONTINUE - ELSE - IF( NOUNIT ) - $ TEMP = TEMP*DCONJG( AP( KK ) ) - DO 160, I = J + 1, N - TEMP = TEMP + DCONJG( AP( K ) )*X( I ) - K = K + 1 - 160 CONTINUE - END IF - X( J ) = TEMP - KK = KK + ( N - J + 1 ) - 170 CONTINUE - ELSE - JX = KX - DO 200, J = 1, N - TEMP = X( JX ) - IX = JX - IF( NOCONJ )THEN - IF( NOUNIT ) - $ TEMP = TEMP*AP( KK ) - DO 180, K = KK + 1, KK + N - J - IX = IX + INCX - TEMP = TEMP + AP( K )*X( IX ) - 180 CONTINUE - ELSE - IF( NOUNIT ) - $ TEMP = TEMP*DCONJG( AP( KK ) ) - DO 190, K = KK + 1, KK + N - J - IX = IX + INCX - TEMP = TEMP + DCONJG( AP( K ) )*X( IX ) - 190 CONTINUE - END IF - X( JX ) = TEMP - JX = JX + INCX - KK = KK + ( N - J + 1 ) - 200 CONTINUE - END IF - END IF - END IF -* - RETURN -* -* End of ZTPMV . -* - END diff --git a/src/lib/blas/ztpsv.f b/src/lib/blas/ztpsv.f deleted file mode 100644 index 8649f474..00000000 --- a/src/lib/blas/ztpsv.f +++ /dev/null @@ -1,341 +0,0 @@ - SUBROUTINE ZTPSV ( UPLO, TRANS, DIAG, N, AP, X, INCX ) -* .. Scalar Arguments .. - INTEGER INCX, N - CHARACTER*1 DIAG, TRANS, UPLO -* .. Array Arguments .. - COMPLEX*16 AP( * ), X( * ) -* .. -* -* Purpose -* ======= -* -* ZTPSV solves one of the systems of equations -* -* A*x = b, or A'*x = b, or conjg( A' )*x = b, -* -* where b and x are n element vectors and A is an n by n unit, or -* non-unit, upper or lower triangular matrix, supplied in packed form. -* -* No test for singularity or near-singularity is included in this -* routine. Such tests must be performed before calling this routine. -* -* 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*16 array of DIMENSION at least -* ( ( n*( n + 1 ) )/2 ). -* Before entry with UPLO = 'U' or 'u', the array AP must -* contain the upper triangular matrix packed sequentially, -* column by column, so that AP( 1 ) contains a( 1, 1 ), -* AP( 2 ) and AP( 3 ) contain a( 1, 2 ) and a( 2, 2 ) -* respectively, and so on. -* Before entry with UPLO = 'L' or 'l', the array AP must -* contain the lower triangular matrix packed sequentially, -* column by column, so that AP( 1 ) contains a( 1, 1 ), -* AP( 2 ) and AP( 3 ) contain a( 2, 1 ) and a( 3, 1 ) -* respectively, and so on. -* Note that when DIAG = 'U' or 'u', the diagonal elements of -* A are not referenced, but are assumed to be unity. -* Unchanged on exit. -* -* X - COMPLEX*16 array of dimension at least -* ( 1 + ( n - 1 )*abs( INCX ) ). -* Before entry, the incremented array X must contain the n -* element right-hand side vector b. On exit, X is overwritten -* with the solution vector x. -* -* INCX - INTEGER. -* On entry, INCX specifies the increment for the elements of -* X. INCX must not be zero. -* Unchanged on exit. -* -* -* Level 2 Blas routine. -* -* -- Written on 22-October-1986. -* Jack Dongarra, Argonne National Lab. -* Jeremy Du Croz, Nag Central Office. -* Sven Hammarling, Nag Central Office. -* Richard Hanson, Sandia National Labs. -* -* -* .. Parameters .. - COMPLEX*16 ZERO - PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) ) -* .. Local Scalars .. - COMPLEX*16 TEMP - INTEGER I, INFO, IX, J, JX, K, KK, KX - LOGICAL NOCONJ, NOUNIT -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. External Subroutines .. - EXTERNAL XERBLA -* .. Intrinsic Functions .. - INTRINSIC DCONJG -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - IF ( .NOT.LSAME( UPLO , 'U' ).AND. - $ .NOT.LSAME( UPLO , 'L' ) )THEN - INFO = 1 - ELSE IF( .NOT.LSAME( TRANS, 'N' ).AND. - $ .NOT.LSAME( TRANS, 'T' ).AND. - $ .NOT.LSAME( TRANS, 'C' ) )THEN - INFO = 2 - ELSE IF( .NOT.LSAME( DIAG , 'U' ).AND. - $ .NOT.LSAME( DIAG , 'N' ) )THEN - INFO = 3 - ELSE IF( N.LT.0 )THEN - INFO = 4 - ELSE IF( INCX.EQ.0 )THEN - INFO = 7 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'ZTPSV ', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( N.EQ.0 ) - $ RETURN -* - NOCONJ = LSAME( TRANS, 'T' ) - NOUNIT = LSAME( DIAG , 'N' ) -* -* Set up the start point in X if the increment is not unity. This -* will be ( N - 1 )*INCX too small for descending loops. -* - IF( INCX.LE.0 )THEN - KX = 1 - ( N - 1 )*INCX - ELSE IF( INCX.NE.1 )THEN - KX = 1 - END IF -* -* Start the operations. In this version the elements of AP are -* accessed sequentially with one pass through AP. -* - IF( LSAME( TRANS, 'N' ) )THEN -* -* Form x := inv( A )*x. -* - IF( LSAME( UPLO, 'U' ) )THEN - KK = ( N*( N + 1 ) )/2 - IF( INCX.EQ.1 )THEN - DO 20, J = N, 1, -1 - IF( X( J ).NE.ZERO )THEN - IF( NOUNIT ) - $ X( J ) = X( J )/AP( KK ) - TEMP = X( J ) - K = KK - 1 - DO 10, I = J - 1, 1, -1 - X( I ) = X( I ) - TEMP*AP( K ) - K = K - 1 - 10 CONTINUE - END IF - KK = KK - J - 20 CONTINUE - ELSE - JX = KX + ( N - 1 )*INCX - DO 40, J = N, 1, -1 - IF( X( JX ).NE.ZERO )THEN - IF( NOUNIT ) - $ X( JX ) = X( JX )/AP( KK ) - TEMP = X( JX ) - IX = JX - DO 30, K = KK - 1, KK - J + 1, -1 - IX = IX - INCX - X( IX ) = X( IX ) - TEMP*AP( K ) - 30 CONTINUE - END IF - JX = JX - INCX - KK = KK - J - 40 CONTINUE - END IF - ELSE - KK = 1 - IF( INCX.EQ.1 )THEN - DO 60, J = 1, N - IF( X( J ).NE.ZERO )THEN - IF( NOUNIT ) - $ X( J ) = X( J )/AP( KK ) - TEMP = X( J ) - K = KK + 1 - DO 50, I = J + 1, N - X( I ) = X( I ) - TEMP*AP( K ) - K = K + 1 - 50 CONTINUE - END IF - KK = KK + ( N - J + 1 ) - 60 CONTINUE - ELSE - JX = KX - DO 80, J = 1, N - IF( X( JX ).NE.ZERO )THEN - IF( NOUNIT ) - $ X( JX ) = X( JX )/AP( KK ) - TEMP = X( JX ) - IX = JX - DO 70, K = KK + 1, KK + N - J - IX = IX + INCX - X( IX ) = X( IX ) - TEMP*AP( K ) - 70 CONTINUE - END IF - JX = JX + INCX - KK = KK + ( N - J + 1 ) - 80 CONTINUE - END IF - END IF - ELSE -* -* Form x := inv( A' )*x or x := inv( conjg( A' ) )*x. -* - IF( LSAME( UPLO, 'U' ) )THEN - KK = 1 - IF( INCX.EQ.1 )THEN - DO 110, J = 1, N - TEMP = X( J ) - K = KK - IF( NOCONJ )THEN - DO 90, I = 1, J - 1 - TEMP = TEMP - AP( K )*X( I ) - K = K + 1 - 90 CONTINUE - IF( NOUNIT ) - $ TEMP = TEMP/AP( KK + J - 1 ) - ELSE - DO 100, I = 1, J - 1 - TEMP = TEMP - DCONJG( AP( K ) )*X( I ) - K = K + 1 - 100 CONTINUE - IF( NOUNIT ) - $ TEMP = TEMP/DCONJG( AP( KK + J - 1 ) ) - END IF - X( J ) = TEMP - KK = KK + J - 110 CONTINUE - ELSE - JX = KX - DO 140, J = 1, N - TEMP = X( JX ) - IX = KX - IF( NOCONJ )THEN - DO 120, K = KK, KK + J - 2 - TEMP = TEMP - AP( K )*X( IX ) - IX = IX + INCX - 120 CONTINUE - IF( NOUNIT ) - $ TEMP = TEMP/AP( KK + J - 1 ) - ELSE - DO 130, K = KK, KK + J - 2 - TEMP = TEMP - DCONJG( AP( K ) )*X( IX ) - IX = IX + INCX - 130 CONTINUE - IF( NOUNIT ) - $ TEMP = TEMP/DCONJG( AP( KK + J - 1 ) ) - END IF - X( JX ) = TEMP - JX = JX + INCX - KK = KK + J - 140 CONTINUE - END IF - ELSE - KK = ( N*( N + 1 ) )/2 - IF( INCX.EQ.1 )THEN - DO 170, J = N, 1, -1 - TEMP = X( J ) - K = KK - IF( NOCONJ )THEN - DO 150, I = N, J + 1, -1 - TEMP = TEMP - AP( K )*X( I ) - K = K - 1 - 150 CONTINUE - IF( NOUNIT ) - $ TEMP = TEMP/AP( KK - N + J ) - ELSE - DO 160, I = N, J + 1, -1 - TEMP = TEMP - DCONJG( AP( K ) )*X( I ) - K = K - 1 - 160 CONTINUE - IF( NOUNIT ) - $ TEMP = TEMP/DCONJG( AP( KK - N + J ) ) - END IF - X( J ) = TEMP - KK = KK - ( N - J + 1 ) - 170 CONTINUE - ELSE - KX = KX + ( N - 1 )*INCX - JX = KX - DO 200, J = N, 1, -1 - TEMP = X( JX ) - IX = KX - IF( NOCONJ )THEN - DO 180, K = KK, KK - ( N - ( J + 1 ) ), -1 - TEMP = TEMP - AP( K )*X( IX ) - IX = IX - INCX - 180 CONTINUE - IF( NOUNIT ) - $ TEMP = TEMP/AP( KK - N + J ) - ELSE - DO 190, K = KK, KK - ( N - ( J + 1 ) ), -1 - TEMP = TEMP - DCONJG( AP( K ) )*X( IX ) - IX = IX - INCX - 190 CONTINUE - IF( NOUNIT ) - $ TEMP = TEMP/DCONJG( AP( KK - N + J ) ) - END IF - X( JX ) = TEMP - JX = JX - INCX - KK = KK - ( N - J + 1 ) - 200 CONTINUE - END IF - END IF - END IF -* - RETURN -* -* End of ZTPSV . -* - END diff --git a/src/lib/blas/ztrmm.f b/src/lib/blas/ztrmm.f deleted file mode 100644 index 30910d1d..00000000 --- a/src/lib/blas/ztrmm.f +++ /dev/null @@ -1,392 +0,0 @@ - SUBROUTINE ZTRMM ( SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA, - $ B, LDB ) -* .. Scalar Arguments .. - CHARACTER*1 SIDE, UPLO, TRANSA, DIAG - INTEGER M, N, LDA, LDB - COMPLEX*16 ALPHA -* .. Array Arguments .. - COMPLEX*16 A( LDA, * ), B( LDB, * ) -* .. -* -* Purpose -* ======= -* -* ZTRMM performs one of the matrix-matrix operations -* -* B := alpha*op( A )*B, or B := alpha*B*op( A ) -* -* where alpha is a scalar, B is an m by n matrix, A is a unit, or -* non-unit, upper or lower triangular matrix and op( A ) is one of -* -* op( A ) = A or op( A ) = A' or op( A ) = conjg( A' ). -* -* 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*16 . -* On entry, ALPHA specifies the scalar alpha. When alpha is -* zero then A is not referenced and B need not be set before -* entry. -* Unchanged on exit. -* -* A - COMPLEX*16 array of DIMENSION ( LDA, k ), where k is m -* when SIDE = 'L' or 'l' and is n when SIDE = 'R' or 'r'. -* Before entry with UPLO = 'U' or 'u', the leading k by k -* upper triangular part of the array A must contain the upper -* triangular matrix and the strictly lower triangular part of -* A is not referenced. -* Before entry with UPLO = 'L' or 'l', the leading k by k -* lower triangular part of the array A must contain the lower -* triangular matrix and the strictly upper triangular part of -* A is not referenced. -* Note that when DIAG = 'U' or 'u', the diagonal elements of -* A are not referenced either, but are assumed to be unity. -* Unchanged on exit. -* -* LDA - INTEGER. -* On entry, LDA specifies the first dimension of A as declared -* in the calling (sub) program. When SIDE = 'L' or 'l' then -* LDA must be at least max( 1, m ), when SIDE = 'R' or 'r' -* then LDA must be at least max( 1, n ). -* Unchanged on exit. -* -* B - COMPLEX*16 array of DIMENSION ( LDB, n ). -* Before entry, the leading m by n part of the array B must -* contain the matrix B, and on exit is overwritten by the -* transformed matrix. -* -* LDB - INTEGER. -* On entry, LDB specifies the first dimension of B as declared -* in the calling (sub) program. LDB must be at least -* max( 1, m ). -* Unchanged on exit. -* -* -* Level 3 Blas routine. -* -* -- Written on 8-February-1989. -* Jack Dongarra, Argonne National Laboratory. -* Iain Duff, AERE Harwell. -* Jeremy Du Croz, Numerical Algorithms Group Ltd. -* Sven Hammarling, Numerical Algorithms Group Ltd. -* -* -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. External Subroutines .. - EXTERNAL XERBLA -* .. Intrinsic Functions .. - INTRINSIC DCONJG, MAX -* .. Local Scalars .. - LOGICAL LSIDE, NOCONJ, NOUNIT, UPPER - INTEGER I, INFO, J, K, NROWA - COMPLEX*16 TEMP -* .. Parameters .. - COMPLEX*16 ONE - PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) ) - COMPLEX*16 ZERO - PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) ) -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - LSIDE = LSAME( SIDE , 'L' ) - IF( LSIDE )THEN - NROWA = M - ELSE - NROWA = N - END IF - NOCONJ = LSAME( TRANSA, 'T' ) - NOUNIT = LSAME( DIAG , 'N' ) - UPPER = LSAME( UPLO , 'U' ) -* - INFO = 0 - IF( ( .NOT.LSIDE ).AND. - $ ( .NOT.LSAME( SIDE , 'R' ) ) )THEN - INFO = 1 - ELSE IF( ( .NOT.UPPER ).AND. - $ ( .NOT.LSAME( UPLO , 'L' ) ) )THEN - INFO = 2 - ELSE IF( ( .NOT.LSAME( TRANSA, 'N' ) ).AND. - $ ( .NOT.LSAME( TRANSA, 'T' ) ).AND. - $ ( .NOT.LSAME( TRANSA, 'C' ) ) )THEN - INFO = 3 - ELSE IF( ( .NOT.LSAME( DIAG , 'U' ) ).AND. - $ ( .NOT.LSAME( DIAG , 'N' ) ) )THEN - INFO = 4 - ELSE IF( M .LT.0 )THEN - INFO = 5 - ELSE IF( N .LT.0 )THEN - INFO = 6 - ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN - INFO = 9 - ELSE IF( LDB.LT.MAX( 1, M ) )THEN - INFO = 11 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'ZTRMM ', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( N.EQ.0 ) - $ RETURN -* -* And when alpha.eq.zero. -* - IF( ALPHA.EQ.ZERO )THEN - DO 20, J = 1, N - DO 10, I = 1, M - B( I, J ) = ZERO - 10 CONTINUE - 20 CONTINUE - RETURN - END IF -* -* Start the operations. -* - IF( LSIDE )THEN - IF( LSAME( TRANSA, 'N' ) )THEN -* -* Form B := alpha*A*B. -* - IF( UPPER )THEN - DO 50, J = 1, N - DO 40, K = 1, M - IF( B( K, J ).NE.ZERO )THEN - TEMP = ALPHA*B( K, J ) - DO 30, I = 1, K - 1 - B( I, J ) = B( I, J ) + TEMP*A( I, K ) - 30 CONTINUE - IF( NOUNIT ) - $ TEMP = TEMP*A( K, K ) - B( K, J ) = TEMP - END IF - 40 CONTINUE - 50 CONTINUE - ELSE - DO 80, J = 1, N - DO 70 K = M, 1, -1 - IF( B( K, J ).NE.ZERO )THEN - TEMP = ALPHA*B( K, J ) - B( K, J ) = TEMP - IF( NOUNIT ) - $ B( K, J ) = B( K, J )*A( K, K ) - DO 60, I = K + 1, M - B( I, J ) = B( I, J ) + TEMP*A( I, K ) - 60 CONTINUE - END IF - 70 CONTINUE - 80 CONTINUE - END IF - ELSE -* -* Form B := alpha*A'*B or B := alpha*conjg( A' )*B. -* - IF( UPPER )THEN - DO 120, J = 1, N - DO 110, I = M, 1, -1 - TEMP = B( I, J ) - IF( NOCONJ )THEN - IF( NOUNIT ) - $ TEMP = TEMP*A( I, I ) - DO 90, K = 1, I - 1 - TEMP = TEMP + A( K, I )*B( K, J ) - 90 CONTINUE - ELSE - IF( NOUNIT ) - $ TEMP = TEMP*DCONJG( A( I, I ) ) - DO 100, K = 1, I - 1 - TEMP = TEMP + DCONJG( A( K, I ) )*B( K, J ) - 100 CONTINUE - END IF - B( I, J ) = ALPHA*TEMP - 110 CONTINUE - 120 CONTINUE - ELSE - DO 160, J = 1, N - DO 150, I = 1, M - TEMP = B( I, J ) - IF( NOCONJ )THEN - IF( NOUNIT ) - $ TEMP = TEMP*A( I, I ) - DO 130, K = I + 1, M - TEMP = TEMP + A( K, I )*B( K, J ) - 130 CONTINUE - ELSE - IF( NOUNIT ) - $ TEMP = TEMP*DCONJG( A( I, I ) ) - DO 140, K = I + 1, M - TEMP = TEMP + DCONJG( A( K, I ) )*B( K, J ) - 140 CONTINUE - END IF - B( I, J ) = ALPHA*TEMP - 150 CONTINUE - 160 CONTINUE - END IF - END IF - ELSE - IF( LSAME( TRANSA, 'N' ) )THEN -* -* Form B := alpha*B*A. -* - IF( UPPER )THEN - DO 200, J = N, 1, -1 - TEMP = ALPHA - IF( NOUNIT ) - $ TEMP = TEMP*A( J, J ) - DO 170, I = 1, M - B( I, J ) = TEMP*B( I, J ) - 170 CONTINUE - DO 190, K = 1, J - 1 - IF( A( K, J ).NE.ZERO )THEN - TEMP = ALPHA*A( K, J ) - DO 180, I = 1, M - B( I, J ) = B( I, J ) + TEMP*B( I, K ) - 180 CONTINUE - END IF - 190 CONTINUE - 200 CONTINUE - ELSE - DO 240, J = 1, N - TEMP = ALPHA - IF( NOUNIT ) - $ TEMP = TEMP*A( J, J ) - DO 210, I = 1, M - B( I, J ) = TEMP*B( I, J ) - 210 CONTINUE - DO 230, K = J + 1, N - IF( A( K, J ).NE.ZERO )THEN - TEMP = ALPHA*A( K, J ) - DO 220, I = 1, M - B( I, J ) = B( I, J ) + TEMP*B( I, K ) - 220 CONTINUE - END IF - 230 CONTINUE - 240 CONTINUE - END IF - ELSE -* -* Form B := alpha*B*A' or B := alpha*B*conjg( A' ). -* - IF( UPPER )THEN - DO 280, K = 1, N - DO 260, J = 1, K - 1 - IF( A( J, K ).NE.ZERO )THEN - IF( NOCONJ )THEN - TEMP = ALPHA*A( J, K ) - ELSE - TEMP = ALPHA*DCONJG( A( J, K ) ) - END IF - DO 250, I = 1, M - B( I, J ) = B( I, J ) + TEMP*B( I, K ) - 250 CONTINUE - END IF - 260 CONTINUE - TEMP = ALPHA - IF( NOUNIT )THEN - IF( NOCONJ )THEN - TEMP = TEMP*A( K, K ) - ELSE - TEMP = TEMP*DCONJG( A( K, K ) ) - END IF - END IF - IF( TEMP.NE.ONE )THEN - DO 270, I = 1, M - B( I, K ) = TEMP*B( I, K ) - 270 CONTINUE - END IF - 280 CONTINUE - ELSE - DO 320, K = N, 1, -1 - DO 300, J = K + 1, N - IF( A( J, K ).NE.ZERO )THEN - IF( NOCONJ )THEN - TEMP = ALPHA*A( J, K ) - ELSE - TEMP = ALPHA*DCONJG( A( J, K ) ) - END IF - DO 290, I = 1, M - B( I, J ) = B( I, J ) + TEMP*B( I, K ) - 290 CONTINUE - END IF - 300 CONTINUE - TEMP = ALPHA - IF( NOUNIT )THEN - IF( NOCONJ )THEN - TEMP = TEMP*A( K, K ) - ELSE - TEMP = TEMP*DCONJG( A( K, K ) ) - END IF - END IF - IF( TEMP.NE.ONE )THEN - DO 310, I = 1, M - B( I, K ) = TEMP*B( I, K ) - 310 CONTINUE - END IF - 320 CONTINUE - END IF - END IF - END IF -* - RETURN -* -* End of ZTRMM . -* - END diff --git a/src/lib/blas/ztrmv.f b/src/lib/blas/ztrmv.f deleted file mode 100644 index 677e212b..00000000 --- a/src/lib/blas/ztrmv.f +++ /dev/null @@ -1,321 +0,0 @@ - SUBROUTINE ZTRMV ( UPLO, TRANS, DIAG, N, A, LDA, X, INCX ) -* .. Scalar Arguments .. - INTEGER INCX, LDA, N - CHARACTER*1 DIAG, TRANS, UPLO -* .. Array Arguments .. - COMPLEX*16 A( LDA, * ), X( * ) -* .. -* -* Purpose -* ======= -* -* ZTRMV performs one of the matrix-vector operations -* -* x := A*x, or x := A'*x, or x := conjg( A' )*x, -* -* where x is an n element vector and A is an n by n unit, or non-unit, -* upper or lower triangular matrix. -* -* 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*16 array of DIMENSION ( LDA, n ). -* Before entry with UPLO = 'U' or 'u', the leading n by n -* upper triangular part of the array A must contain the upper -* triangular matrix and the strictly lower triangular part of -* A is not referenced. -* Before entry with UPLO = 'L' or 'l', the leading n by n -* lower triangular part of the array A must contain the lower -* triangular matrix and the strictly upper triangular part of -* A is not referenced. -* Note that when DIAG = 'U' or 'u', the diagonal elements of -* A are not referenced either, but are assumed to be unity. -* Unchanged on exit. -* -* LDA - INTEGER. -* On entry, LDA specifies the first dimension of A as declared -* in the calling (sub) program. LDA must be at least -* max( 1, n ). -* Unchanged on exit. -* -* X - COMPLEX*16 array of dimension at least -* ( 1 + ( n - 1 )*abs( INCX ) ). -* Before entry, the incremented array X must contain the n -* element vector x. On exit, X is overwritten with the -* tranformed vector x. -* -* INCX - INTEGER. -* On entry, INCX specifies the increment for the elements of -* X. INCX must not be zero. -* Unchanged on exit. -* -* -* Level 2 Blas routine. -* -* -- Written on 22-October-1986. -* Jack Dongarra, Argonne National Lab. -* Jeremy Du Croz, Nag Central Office. -* Sven Hammarling, Nag Central Office. -* Richard Hanson, Sandia National Labs. -* -* -* .. Parameters .. - COMPLEX*16 ZERO - PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) ) -* .. Local Scalars .. - COMPLEX*16 TEMP - INTEGER I, INFO, IX, J, JX, KX - LOGICAL NOCONJ, NOUNIT -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. External Subroutines .. - EXTERNAL XERBLA -* .. Intrinsic Functions .. - INTRINSIC DCONJG, MAX -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - IF ( .NOT.LSAME( UPLO , 'U' ).AND. - $ .NOT.LSAME( UPLO , 'L' ) )THEN - INFO = 1 - ELSE IF( .NOT.LSAME( TRANS, 'N' ).AND. - $ .NOT.LSAME( TRANS, 'T' ).AND. - $ .NOT.LSAME( TRANS, 'C' ) )THEN - INFO = 2 - ELSE IF( .NOT.LSAME( DIAG , 'U' ).AND. - $ .NOT.LSAME( DIAG , 'N' ) )THEN - INFO = 3 - ELSE IF( N.LT.0 )THEN - INFO = 4 - ELSE IF( LDA.LT.MAX( 1, N ) )THEN - INFO = 6 - ELSE IF( INCX.EQ.0 )THEN - INFO = 8 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'ZTRMV ', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( N.EQ.0 ) - $ RETURN -* - NOCONJ = LSAME( TRANS, 'T' ) - NOUNIT = LSAME( DIAG , 'N' ) -* -* Set up the start point in X if the increment is not unity. This -* will be ( N - 1 )*INCX too small for descending loops. -* - IF( INCX.LE.0 )THEN - KX = 1 - ( N - 1 )*INCX - ELSE IF( INCX.NE.1 )THEN - KX = 1 - END IF -* -* Start the operations. In this version the elements of A are -* accessed sequentially with one pass through A. -* - IF( LSAME( TRANS, 'N' ) )THEN -* -* Form x := A*x. -* - IF( LSAME( UPLO, 'U' ) )THEN - IF( INCX.EQ.1 )THEN - DO 20, J = 1, N - IF( X( J ).NE.ZERO )THEN - TEMP = X( J ) - DO 10, I = 1, J - 1 - X( I ) = X( I ) + TEMP*A( I, J ) - 10 CONTINUE - IF( NOUNIT ) - $ X( J ) = X( J )*A( J, J ) - END IF - 20 CONTINUE - ELSE - JX = KX - DO 40, J = 1, N - IF( X( JX ).NE.ZERO )THEN - TEMP = X( JX ) - IX = KX - DO 30, I = 1, J - 1 - X( IX ) = X( IX ) + TEMP*A( I, J ) - IX = IX + INCX - 30 CONTINUE - IF( NOUNIT ) - $ X( JX ) = X( JX )*A( J, J ) - END IF - JX = JX + INCX - 40 CONTINUE - END IF - ELSE - IF( INCX.EQ.1 )THEN - DO 60, J = N, 1, -1 - IF( X( J ).NE.ZERO )THEN - TEMP = X( J ) - DO 50, I = N, J + 1, -1 - X( I ) = X( I ) + TEMP*A( I, J ) - 50 CONTINUE - IF( NOUNIT ) - $ X( J ) = X( J )*A( J, J ) - END IF - 60 CONTINUE - ELSE - KX = KX + ( N - 1 )*INCX - JX = KX - DO 80, J = N, 1, -1 - IF( X( JX ).NE.ZERO )THEN - TEMP = X( JX ) - IX = KX - DO 70, I = N, J + 1, -1 - X( IX ) = X( IX ) + TEMP*A( I, J ) - IX = IX - INCX - 70 CONTINUE - IF( NOUNIT ) - $ X( JX ) = X( JX )*A( J, J ) - END IF - JX = JX - INCX - 80 CONTINUE - END IF - END IF - ELSE -* -* Form x := A'*x or x := conjg( A' )*x. -* - IF( LSAME( UPLO, 'U' ) )THEN - IF( INCX.EQ.1 )THEN - DO 110, J = N, 1, -1 - TEMP = X( J ) - IF( NOCONJ )THEN - IF( NOUNIT ) - $ TEMP = TEMP*A( J, J ) - DO 90, I = J - 1, 1, -1 - TEMP = TEMP + A( I, J )*X( I ) - 90 CONTINUE - ELSE - IF( NOUNIT ) - $ TEMP = TEMP*DCONJG( A( J, J ) ) - DO 100, I = J - 1, 1, -1 - TEMP = TEMP + DCONJG( A( I, J ) )*X( I ) - 100 CONTINUE - END IF - X( J ) = TEMP - 110 CONTINUE - ELSE - JX = KX + ( N - 1 )*INCX - DO 140, J = N, 1, -1 - TEMP = X( JX ) - IX = JX - IF( NOCONJ )THEN - IF( NOUNIT ) - $ TEMP = TEMP*A( J, J ) - DO 120, I = J - 1, 1, -1 - IX = IX - INCX - TEMP = TEMP + A( I, J )*X( IX ) - 120 CONTINUE - ELSE - IF( NOUNIT ) - $ TEMP = TEMP*DCONJG( A( J, J ) ) - DO 130, I = J - 1, 1, -1 - IX = IX - INCX - TEMP = TEMP + DCONJG( A( I, J ) )*X( IX ) - 130 CONTINUE - END IF - X( JX ) = TEMP - JX = JX - INCX - 140 CONTINUE - END IF - ELSE - IF( INCX.EQ.1 )THEN - DO 170, J = 1, N - TEMP = X( J ) - IF( NOCONJ )THEN - IF( NOUNIT ) - $ TEMP = TEMP*A( J, J ) - DO 150, I = J + 1, N - TEMP = TEMP + A( I, J )*X( I ) - 150 CONTINUE - ELSE - IF( NOUNIT ) - $ TEMP = TEMP*DCONJG( A( J, J ) ) - DO 160, I = J + 1, N - TEMP = TEMP + DCONJG( A( I, J ) )*X( I ) - 160 CONTINUE - END IF - X( J ) = TEMP - 170 CONTINUE - ELSE - JX = KX - DO 200, J = 1, N - TEMP = X( JX ) - IX = JX - IF( NOCONJ )THEN - IF( NOUNIT ) - $ TEMP = TEMP*A( J, J ) - DO 180, I = J + 1, N - IX = IX + INCX - TEMP = TEMP + A( I, J )*X( IX ) - 180 CONTINUE - ELSE - IF( NOUNIT ) - $ TEMP = TEMP*DCONJG( A( J, J ) ) - DO 190, I = J + 1, N - IX = IX + INCX - TEMP = TEMP + DCONJG( A( I, J ) )*X( IX ) - 190 CONTINUE - END IF - X( JX ) = TEMP - JX = JX + INCX - 200 CONTINUE - END IF - END IF - END IF -* - RETURN -* -* End of ZTRMV . -* - END diff --git a/src/lib/blas/ztrsm.f b/src/lib/blas/ztrsm.f deleted file mode 100644 index e414ec66..00000000 --- a/src/lib/blas/ztrsm.f +++ /dev/null @@ -1,414 +0,0 @@ - SUBROUTINE ZTRSM ( SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA, - $ B, LDB ) -* .. Scalar Arguments .. - CHARACTER*1 SIDE, UPLO, TRANSA, DIAG - INTEGER M, N, LDA, LDB - COMPLEX*16 ALPHA -* .. Array Arguments .. - COMPLEX*16 A( LDA, * ), B( LDB, * ) -* .. -* -* Purpose -* ======= -* -* ZTRSM solves one of the matrix equations -* -* op( A )*X = alpha*B, or X*op( A ) = alpha*B, -* -* where alpha is a scalar, X and B are m by n matrices, A is a unit, or -* non-unit, upper or lower triangular matrix and op( A ) is one of -* -* op( A ) = A or op( A ) = A' or op( A ) = conjg( A' ). -* -* The matrix X is overwritten on B. -* -* 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*16 . -* On entry, ALPHA specifies the scalar alpha. When alpha is -* zero then A is not referenced and B need not be set before -* entry. -* Unchanged on exit. -* -* A - COMPLEX*16 array of DIMENSION ( LDA, k ), where k is m -* when SIDE = 'L' or 'l' and is n when SIDE = 'R' or 'r'. -* Before entry with UPLO = 'U' or 'u', the leading k by k -* upper triangular part of the array A must contain the upper -* triangular matrix and the strictly lower triangular part of -* A is not referenced. -* Before entry with UPLO = 'L' or 'l', the leading k by k -* lower triangular part of the array A must contain the lower -* triangular matrix and the strictly upper triangular part of -* A is not referenced. -* Note that when DIAG = 'U' or 'u', the diagonal elements of -* A are not referenced either, but are assumed to be unity. -* Unchanged on exit. -* -* LDA - INTEGER. -* On entry, LDA specifies the first dimension of A as declared -* in the calling (sub) program. When SIDE = 'L' or 'l' then -* LDA must be at least max( 1, m ), when SIDE = 'R' or 'r' -* then LDA must be at least max( 1, n ). -* Unchanged on exit. -* -* B - COMPLEX*16 array of DIMENSION ( LDB, n ). -* Before entry, the leading m by n part of the array B must -* contain the right-hand side matrix B, and on exit is -* overwritten by the solution matrix X. -* -* LDB - INTEGER. -* On entry, LDB specifies the first dimension of B as declared -* in the calling (sub) program. LDB must be at least -* max( 1, m ). -* Unchanged on exit. -* -* -* Level 3 Blas routine. -* -* -- Written on 8-February-1989. -* Jack Dongarra, Argonne National Laboratory. -* Iain Duff, AERE Harwell. -* Jeremy Du Croz, Numerical Algorithms Group Ltd. -* Sven Hammarling, Numerical Algorithms Group Ltd. -* -* -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. External Subroutines .. - EXTERNAL XERBLA -* .. Intrinsic Functions .. - INTRINSIC DCONJG, MAX -* .. Local Scalars .. - LOGICAL LSIDE, NOCONJ, NOUNIT, UPPER - INTEGER I, INFO, J, K, NROWA - COMPLEX*16 TEMP -* .. Parameters .. - COMPLEX*16 ONE - PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) ) - COMPLEX*16 ZERO - PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) ) -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - LSIDE = LSAME( SIDE , 'L' ) - IF( LSIDE )THEN - NROWA = M - ELSE - NROWA = N - END IF - NOCONJ = LSAME( TRANSA, 'T' ) - NOUNIT = LSAME( DIAG , 'N' ) - UPPER = LSAME( UPLO , 'U' ) -* - INFO = 0 - IF( ( .NOT.LSIDE ).AND. - $ ( .NOT.LSAME( SIDE , 'R' ) ) )THEN - INFO = 1 - ELSE IF( ( .NOT.UPPER ).AND. - $ ( .NOT.LSAME( UPLO , 'L' ) ) )THEN - INFO = 2 - ELSE IF( ( .NOT.LSAME( TRANSA, 'N' ) ).AND. - $ ( .NOT.LSAME( TRANSA, 'T' ) ).AND. - $ ( .NOT.LSAME( TRANSA, 'C' ) ) )THEN - INFO = 3 - ELSE IF( ( .NOT.LSAME( DIAG , 'U' ) ).AND. - $ ( .NOT.LSAME( DIAG , 'N' ) ) )THEN - INFO = 4 - ELSE IF( M .LT.0 )THEN - INFO = 5 - ELSE IF( N .LT.0 )THEN - INFO = 6 - ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN - INFO = 9 - ELSE IF( LDB.LT.MAX( 1, M ) )THEN - INFO = 11 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'ZTRSM ', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( N.EQ.0 ) - $ RETURN -* -* And when alpha.eq.zero. -* - IF( ALPHA.EQ.ZERO )THEN - DO 20, J = 1, N - DO 10, I = 1, M - B( I, J ) = ZERO - 10 CONTINUE - 20 CONTINUE - RETURN - END IF -* -* Start the operations. -* - IF( LSIDE )THEN - IF( LSAME( TRANSA, 'N' ) )THEN -* -* Form B := alpha*inv( A )*B. -* - IF( UPPER )THEN - DO 60, J = 1, N - IF( ALPHA.NE.ONE )THEN - DO 30, I = 1, M - B( I, J ) = ALPHA*B( I, J ) - 30 CONTINUE - END IF - DO 50, K = M, 1, -1 - IF( B( K, J ).NE.ZERO )THEN - IF( NOUNIT ) - $ B( K, J ) = B( K, J )/A( K, K ) - DO 40, I = 1, K - 1 - B( I, J ) = B( I, J ) - B( K, J )*A( I, K ) - 40 CONTINUE - END IF - 50 CONTINUE - 60 CONTINUE - ELSE - DO 100, J = 1, N - IF( ALPHA.NE.ONE )THEN - DO 70, I = 1, M - B( I, J ) = ALPHA*B( I, J ) - 70 CONTINUE - END IF - DO 90 K = 1, M - IF( B( K, J ).NE.ZERO )THEN - IF( NOUNIT ) - $ B( K, J ) = B( K, J )/A( K, K ) - DO 80, I = K + 1, M - B( I, J ) = B( I, J ) - B( K, J )*A( I, K ) - 80 CONTINUE - END IF - 90 CONTINUE - 100 CONTINUE - END IF - ELSE -* -* Form B := alpha*inv( A' )*B -* or B := alpha*inv( conjg( A' ) )*B. -* - IF( UPPER )THEN - DO 140, J = 1, N - DO 130, I = 1, M - TEMP = ALPHA*B( I, J ) - IF( NOCONJ )THEN - DO 110, K = 1, I - 1 - TEMP = TEMP - A( K, I )*B( K, J ) - 110 CONTINUE - IF( NOUNIT ) - $ TEMP = TEMP/A( I, I ) - ELSE - DO 120, K = 1, I - 1 - TEMP = TEMP - DCONJG( A( K, I ) )*B( K, J ) - 120 CONTINUE - IF( NOUNIT ) - $ TEMP = TEMP/DCONJG( A( I, I ) ) - END IF - B( I, J ) = TEMP - 130 CONTINUE - 140 CONTINUE - ELSE - DO 180, J = 1, N - DO 170, I = M, 1, -1 - TEMP = ALPHA*B( I, J ) - IF( NOCONJ )THEN - DO 150, K = I + 1, M - TEMP = TEMP - A( K, I )*B( K, J ) - 150 CONTINUE - IF( NOUNIT ) - $ TEMP = TEMP/A( I, I ) - ELSE - DO 160, K = I + 1, M - TEMP = TEMP - DCONJG( A( K, I ) )*B( K, J ) - 160 CONTINUE - IF( NOUNIT ) - $ TEMP = TEMP/DCONJG( A( I, I ) ) - END IF - B( I, J ) = TEMP - 170 CONTINUE - 180 CONTINUE - END IF - END IF - ELSE - IF( LSAME( TRANSA, 'N' ) )THEN -* -* Form B := alpha*B*inv( A ). -* - IF( UPPER )THEN - DO 230, J = 1, N - IF( ALPHA.NE.ONE )THEN - DO 190, I = 1, M - B( I, J ) = ALPHA*B( I, J ) - 190 CONTINUE - END IF - DO 210, K = 1, J - 1 - IF( A( K, J ).NE.ZERO )THEN - DO 200, I = 1, M - B( I, J ) = B( I, J ) - A( K, J )*B( I, K ) - 200 CONTINUE - END IF - 210 CONTINUE - IF( NOUNIT )THEN - TEMP = ONE/A( J, J ) - DO 220, I = 1, M - B( I, J ) = TEMP*B( I, J ) - 220 CONTINUE - END IF - 230 CONTINUE - ELSE - DO 280, J = N, 1, -1 - IF( ALPHA.NE.ONE )THEN - DO 240, I = 1, M - B( I, J ) = ALPHA*B( I, J ) - 240 CONTINUE - END IF - DO 260, K = J + 1, N - IF( A( K, J ).NE.ZERO )THEN - DO 250, I = 1, M - B( I, J ) = B( I, J ) - A( K, J )*B( I, K ) - 250 CONTINUE - END IF - 260 CONTINUE - IF( NOUNIT )THEN - TEMP = ONE/A( J, J ) - DO 270, I = 1, M - B( I, J ) = TEMP*B( I, J ) - 270 CONTINUE - END IF - 280 CONTINUE - END IF - ELSE -* -* Form B := alpha*B*inv( A' ) -* or B := alpha*B*inv( conjg( A' ) ). -* - IF( UPPER )THEN - DO 330, K = N, 1, -1 - IF( NOUNIT )THEN - IF( NOCONJ )THEN - TEMP = ONE/A( K, K ) - ELSE - TEMP = ONE/DCONJG( A( K, K ) ) - END IF - DO 290, I = 1, M - B( I, K ) = TEMP*B( I, K ) - 290 CONTINUE - END IF - DO 310, J = 1, K - 1 - IF( A( J, K ).NE.ZERO )THEN - IF( NOCONJ )THEN - TEMP = A( J, K ) - ELSE - TEMP = DCONJG( A( J, K ) ) - END IF - DO 300, I = 1, M - B( I, J ) = B( I, J ) - TEMP*B( I, K ) - 300 CONTINUE - END IF - 310 CONTINUE - IF( ALPHA.NE.ONE )THEN - DO 320, I = 1, M - B( I, K ) = ALPHA*B( I, K ) - 320 CONTINUE - END IF - 330 CONTINUE - ELSE - DO 380, K = 1, N - IF( NOUNIT )THEN - IF( NOCONJ )THEN - TEMP = ONE/A( K, K ) - ELSE - TEMP = ONE/DCONJG( A( K, K ) ) - END IF - DO 340, I = 1, M - B( I, K ) = TEMP*B( I, K ) - 340 CONTINUE - END IF - DO 360, J = K + 1, N - IF( A( J, K ).NE.ZERO )THEN - IF( NOCONJ )THEN - TEMP = A( J, K ) - ELSE - TEMP = DCONJG( A( J, K ) ) - END IF - DO 350, I = 1, M - B( I, J ) = B( I, J ) - TEMP*B( I, K ) - 350 CONTINUE - END IF - 360 CONTINUE - IF( ALPHA.NE.ONE )THEN - DO 370, I = 1, M - B( I, K ) = ALPHA*B( I, K ) - 370 CONTINUE - END IF - 380 CONTINUE - END IF - END IF - END IF -* - RETURN -* -* End of ZTRSM . -* - END diff --git a/src/lib/blas/ztrsv.f b/src/lib/blas/ztrsv.f deleted file mode 100644 index d0a57c44..00000000 --- a/src/lib/blas/ztrsv.f +++ /dev/null @@ -1,324 +0,0 @@ - SUBROUTINE ZTRSV ( UPLO, TRANS, DIAG, N, A, LDA, X, INCX ) -* .. Scalar Arguments .. - INTEGER INCX, LDA, N - CHARACTER*1 DIAG, TRANS, UPLO -* .. Array Arguments .. - COMPLEX*16 A( LDA, * ), X( * ) -* .. -* -* Purpose -* ======= -* -* ZTRSV solves one of the systems of equations -* -* A*x = b, or A'*x = b, or conjg( A' )*x = b, -* -* where b and x are n element vectors and A is an n by n unit, or -* non-unit, upper or lower triangular matrix. -* -* No test for singularity or near-singularity is included in this -* routine. Such tests must be performed before calling this routine. -* -* 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*16 array of DIMENSION ( LDA, n ). -* Before entry with UPLO = 'U' or 'u', the leading n by n -* upper triangular part of the array A must contain the upper -* triangular matrix and the strictly lower triangular part of -* A is not referenced. -* Before entry with UPLO = 'L' or 'l', the leading n by n -* lower triangular part of the array A must contain the lower -* triangular matrix and the strictly upper triangular part of -* A is not referenced. -* Note that when DIAG = 'U' or 'u', the diagonal elements of -* A are not referenced either, but are assumed to be unity. -* Unchanged on exit. -* -* LDA - INTEGER. -* On entry, LDA specifies the first dimension of A as declared -* in the calling (sub) program. LDA must be at least -* max( 1, n ). -* Unchanged on exit. -* -* X - COMPLEX*16 array of dimension at least -* ( 1 + ( n - 1 )*abs( INCX ) ). -* Before entry, the incremented array X must contain the n -* element right-hand side vector b. On exit, X is overwritten -* with the solution vector x. -* -* INCX - INTEGER. -* On entry, INCX specifies the increment for the elements of -* X. INCX must not be zero. -* Unchanged on exit. -* -* -* Level 2 Blas routine. -* -* -- Written on 22-October-1986. -* Jack Dongarra, Argonne National Lab. -* Jeremy Du Croz, Nag Central Office. -* Sven Hammarling, Nag Central Office. -* Richard Hanson, Sandia National Labs. -* -* -* .. Parameters .. - COMPLEX*16 ZERO - PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) ) -* .. Local Scalars .. - COMPLEX*16 TEMP - INTEGER I, INFO, IX, J, JX, KX - LOGICAL NOCONJ, NOUNIT -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. External Subroutines .. - EXTERNAL XERBLA -* .. Intrinsic Functions .. - INTRINSIC DCONJG, MAX -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - IF ( .NOT.LSAME( UPLO , 'U' ).AND. - $ .NOT.LSAME( UPLO , 'L' ) )THEN - INFO = 1 - ELSE IF( .NOT.LSAME( TRANS, 'N' ).AND. - $ .NOT.LSAME( TRANS, 'T' ).AND. - $ .NOT.LSAME( TRANS, 'C' ) )THEN - INFO = 2 - ELSE IF( .NOT.LSAME( DIAG , 'U' ).AND. - $ .NOT.LSAME( DIAG , 'N' ) )THEN - INFO = 3 - ELSE IF( N.LT.0 )THEN - INFO = 4 - ELSE IF( LDA.LT.MAX( 1, N ) )THEN - INFO = 6 - ELSE IF( INCX.EQ.0 )THEN - INFO = 8 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'ZTRSV ', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( N.EQ.0 ) - $ RETURN -* - NOCONJ = LSAME( TRANS, 'T' ) - NOUNIT = LSAME( DIAG , 'N' ) -* -* Set up the start point in X if the increment is not unity. This -* will be ( N - 1 )*INCX too small for descending loops. -* - IF( INCX.LE.0 )THEN - KX = 1 - ( N - 1 )*INCX - ELSE IF( INCX.NE.1 )THEN - KX = 1 - END IF -* -* Start the operations. In this version the elements of A are -* accessed sequentially with one pass through A. -* - IF( LSAME( TRANS, 'N' ) )THEN -* -* Form x := inv( A )*x. -* - IF( LSAME( UPLO, 'U' ) )THEN - IF( INCX.EQ.1 )THEN - DO 20, J = N, 1, -1 - IF( X( J ).NE.ZERO )THEN - IF( NOUNIT ) - $ X( J ) = X( J )/A( J, J ) - TEMP = X( J ) - DO 10, I = J - 1, 1, -1 - X( I ) = X( I ) - TEMP*A( I, J ) - 10 CONTINUE - END IF - 20 CONTINUE - ELSE - JX = KX + ( N - 1 )*INCX - DO 40, J = N, 1, -1 - IF( X( JX ).NE.ZERO )THEN - IF( NOUNIT ) - $ X( JX ) = X( JX )/A( J, J ) - TEMP = X( JX ) - IX = JX - DO 30, I = J - 1, 1, -1 - IX = IX - INCX - X( IX ) = X( IX ) - TEMP*A( I, J ) - 30 CONTINUE - END IF - JX = JX - INCX - 40 CONTINUE - END IF - ELSE - IF( INCX.EQ.1 )THEN - DO 60, J = 1, N - IF( X( J ).NE.ZERO )THEN - IF( NOUNIT ) - $ X( J ) = X( J )/A( J, J ) - TEMP = X( J ) - DO 50, I = J + 1, N - X( I ) = X( I ) - TEMP*A( I, J ) - 50 CONTINUE - END IF - 60 CONTINUE - ELSE - JX = KX - DO 80, J = 1, N - IF( X( JX ).NE.ZERO )THEN - IF( NOUNIT ) - $ X( JX ) = X( JX )/A( J, J ) - TEMP = X( JX ) - IX = JX - DO 70, I = J + 1, N - IX = IX + INCX - X( IX ) = X( IX ) - TEMP*A( I, J ) - 70 CONTINUE - END IF - JX = JX + INCX - 80 CONTINUE - END IF - END IF - ELSE -* -* Form x := inv( A' )*x or x := inv( conjg( A' ) )*x. -* - IF( LSAME( UPLO, 'U' ) )THEN - IF( INCX.EQ.1 )THEN - DO 110, J = 1, N - TEMP = X( J ) - IF( NOCONJ )THEN - DO 90, I = 1, J - 1 - TEMP = TEMP - A( I, J )*X( I ) - 90 CONTINUE - IF( NOUNIT ) - $ TEMP = TEMP/A( J, J ) - ELSE - DO 100, I = 1, J - 1 - TEMP = TEMP - DCONJG( A( I, J ) )*X( I ) - 100 CONTINUE - IF( NOUNIT ) - $ TEMP = TEMP/DCONJG( A( J, J ) ) - END IF - X( J ) = TEMP - 110 CONTINUE - ELSE - JX = KX - DO 140, J = 1, N - IX = KX - TEMP = X( JX ) - IF( NOCONJ )THEN - DO 120, I = 1, J - 1 - TEMP = TEMP - A( I, J )*X( IX ) - IX = IX + INCX - 120 CONTINUE - IF( NOUNIT ) - $ TEMP = TEMP/A( J, J ) - ELSE - DO 130, I = 1, J - 1 - TEMP = TEMP - DCONJG( A( I, J ) )*X( IX ) - IX = IX + INCX - 130 CONTINUE - IF( NOUNIT ) - $ TEMP = TEMP/DCONJG( A( J, J ) ) - END IF - X( JX ) = TEMP - JX = JX + INCX - 140 CONTINUE - END IF - ELSE - IF( INCX.EQ.1 )THEN - DO 170, J = N, 1, -1 - TEMP = X( J ) - IF( NOCONJ )THEN - DO 150, I = N, J + 1, -1 - TEMP = TEMP - A( I, J )*X( I ) - 150 CONTINUE - IF( NOUNIT ) - $ TEMP = TEMP/A( J, J ) - ELSE - DO 160, I = N, J + 1, -1 - TEMP = TEMP - DCONJG( A( I, J ) )*X( I ) - 160 CONTINUE - IF( NOUNIT ) - $ TEMP = TEMP/DCONJG( A( J, J ) ) - END IF - X( J ) = TEMP - 170 CONTINUE - ELSE - KX = KX + ( N - 1 )*INCX - JX = KX - DO 200, J = N, 1, -1 - IX = KX - TEMP = X( JX ) - IF( NOCONJ )THEN - DO 180, I = N, J + 1, -1 - TEMP = TEMP - A( I, J )*X( IX ) - IX = IX - INCX - 180 CONTINUE - IF( NOUNIT ) - $ TEMP = TEMP/A( J, J ) - ELSE - DO 190, I = N, J + 1, -1 - TEMP = TEMP - DCONJG( A( I, J ) )*X( IX ) - IX = IX - INCX - 190 CONTINUE - IF( NOUNIT ) - $ TEMP = TEMP/DCONJG( A( J, J ) ) - END IF - X( JX ) = TEMP - JX = JX - INCX - 200 CONTINUE - END IF - END IF - END IF -* - RETURN -* -* End of ZTRSV . -* - END |